![[site community profile]](https://www.dreamwidth.org/img/comm_staff.png){kind=small}
[dw-free] Atom Publishing Protocol Implementation Out of Date
[commit: http://hg.dwscoalition.org/dw-free/rev/c03034073124]
http://bugs.dwscoalition.org/show_bug.cgi?id=852
Clean out old version of the XML::Atom modules so we can use newer versions
(installed on the system), and tweak code to use the newer interface. Change
format of the service document from draft version (0.3?) to version that's
understood by modern clients and update URL scheme accordingly (all can be
automatically discovered by checking the service document). Move the code
into a controller (modernization).
Patch by![[personal profile]](https://www.dreamwidth.org/img/silk/identity/user.png)
fu.
Files modified:
http://bugs.dwscoalition.org/show_bug.cgi?id=852
Clean out old version of the XML::Atom modules so we can use newer versions
(installed on the system), and tweak code to use the newer interface. Change
format of the service document from draft version (0.3?) to version that's
understood by modern clients and update URL scheme accordingly (all can be
automatically discovered by checking the service document). Move the code
into a controller (modernization).
Patch by
fu.Files modified:
- cgi-bin/Apache/LiveJournal.pm
- cgi-bin/Apache/LiveJournal/Interface/AtomAPI.pm
- cgi-bin/DW/Controller/Interface/AtomAPI.pm
- cgi-bin/DW/Controller/Interface/S2.pm
- cgi-bin/DW/Request/Apache2.pm
- cgi-bin/DW/Request/Standard.pm
- cgi-bin/DW/Routing.pm
- cgi-bin/LJ/Entry.pm
- cgi-bin/LJ/ModuleCheck.pm
- cgi-bin/LJ/S2.pm
- cgi-bin/LJ/User.pm
- cgi-bin/XML/Atom.pm
- cgi-bin/XML/Atom/Client.pm
- cgi-bin/XML/Atom/Content.pm
- cgi-bin/XML/Atom/Entry.pm
- cgi-bin/XML/Atom/ErrorHandler.pm
- cgi-bin/XML/Atom/Feed.pm
- cgi-bin/XML/Atom/Link.pm
- cgi-bin/XML/Atom/Person.pm
- cgi-bin/XML/Atom/Server.pm
- cgi-bin/XML/Atom/Thing.pm
- cgi-bin/XML/Atom/Util.pm
- cgi-bin/XML/README.txt
- cgi-bin/ljfeed.pl
- t/atom-post.t
--------------------------------------------------------------------------------
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/Apache/LiveJournal.pm
--- a/cgi-bin/Apache/LiveJournal.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/Apache/LiveJournal.pm Mon Feb 07 12:52:01 2011 +0800
@@ -25,7 +25,6 @@ use Apache2::Const qw/ :common REDIRECT
# needed to call S2::set_domain() so early:
use LJ::S2;
use Apache::LiveJournal::Interface::Blogger;
-use Apache::LiveJournal::Interface::AtomAPI;
use Apache::LiveJournal::PalImg;
use LJ::ModuleCheck;
use LJ::AccessLogSink;
@@ -959,7 +958,7 @@ sub trans
if ($uri =~ m!^/(?:interface/(\w+))|cgi-bin/log\.cgi!) {
my $int = $1 || "flat";
$r->handler("perl-script");
- if ($int =~ /^flat|xmlrpc|blogger|elsewhere_info|atom(?:api)?$/) {
+ if ($int =~ /^flat|xmlrpc|blogger|elsewhere_info$/) {
$RQ{'interface'} = $int;
$RQ{'is_ssl'} = $is_ssl;
$r->push_handlers(PerlResponseHandler => \&interface_content);
@@ -1654,14 +1653,6 @@ sub interface_content
return OK;
}
- if ($RQ{'interface'} =~ /atom(?:api)?/) {
- Apache::LiveJournal::Interface::AtomAPI->load;
- # the interface package will set up all headers and
- # print everything
- Apache::LiveJournal::Interface::AtomAPI::handle($r);
- return OK;
- }
-
if ($RQ{'interface'} ne "flat") {
$r->content_type("text/plain");
$r->print("Unknown interface.");
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/Apache/LiveJournal/Interface/AtomAPI.pm
--- a/cgi-bin/Apache/LiveJournal/Interface/AtomAPI.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,660 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-#
-# AtomAPI support for LJ
-
-package Apache::LiveJournal::Interface::AtomAPI;
-
-use strict;
-use Apache2::Const qw(:common);
-use Digest::SHA1;
-use MIME::Base64;
-use lib "$LJ::HOME/cgi-bin";
-use LJ::ModuleCheck;
-use LJ::ParseFeed;
-
-# for Class::Autouse (so callers can 'ping' this method to lazy-load this class)
-sub load { 1 }
-
-# check allowed Atom upload filetypes
-sub check_mime
-{
- my $mime = shift;
- return unless $mime;
-
- # TODO: add audio/etc support
- my %allowed_mime = (
- image => qr{^image\/(?:gif|jpe?g|png|tiff?)$}i,
- #audio => qr{^(?:application|audio)\/(?:(?:x-)?ogg|wav)$}i
- );
-
- foreach (keys %allowed_mime) {
- return $_ if $mime =~ $allowed_mime{$_}
- }
- return;
-}
-
-sub respond {
- my ($r, $status, $body, $type) = @_;
-
- my %msgs = (
- 200 => 'OK',
- 201 => 'Created',
-
- 400 => 'Bad Request',
- 401 => 'Authentication Failed',
- 403 => 'Forbidden',
- 404 => 'Not Found',
- 500 => 'Server Error',
- ),
-
- my %mime = (
- html => 'text/html',
- atom => 'application/x.atom+xml',
- xml => "text/xml; charset='utf-8'",
- );
-
- # if the passed in body was a reference, send it
- # without any modification. otherwise, send some
- # prettier html to the client.
- my $out;
- if (ref $body) {
- $out = $$body;
- } else {
- $out = <<HTML;
-<html><head><title>$status $msgs{$status}</title></head><body>
-<h1>$msgs{$status}</h1><hr /><p>$body</p>
-</body></html>
-HTML
- }
-
- $type = $mime{$type} || 'text/html';
- $r->status_line("$status $msgs{$status}");
- $r->content_type($type);
- $r->print($out);
- return OK;
-};
-
-sub handle_upload
-{
- my ($r, $remote, $u, $opts, $entry) = @_;
-
- # entry could already be populated from a standalone
- # service.post posting.
- my $standalone = $entry ? 1 : 0;
- unless ($entry) {
- my $buff;
-
- # Check length
- my $len = $r->header_in("Content-length");
- return respond($r, 400, "Content is too long")
- if $len > $LJ::MAX_ATOM_UPLOAD;
-
- $r->read($buff, $len);
-
- eval { $entry = XML::Atom::Entry->new( \$buff ); };
- return respond($r, 400, "Could not parse the entry due to invalid markup.<br /><pre>$@</pre>")
- if $@;
- }
-
- my $mime = $entry->content()->type();
- my $mime_area = check_mime( $mime );
- return respond($r, 400, "Unsupported MIME type: $mime") unless $mime_area;
-
- if ($mime_area eq 'image') {
- return respond( $r, 400, "Unable to upload media." );
- }
-}
-
-sub handle_post {
- my ($r, $remote, $u, $opts) = @_;
- my ($buff, $entry);
-
- # Check length
- my $len = $r->header_in("Content-length");
- return respond($r, 400, "Content is too long")
- if $len > $LJ::MAX_ATOM_UPLOAD;
-
- # read the content
- $r->read($buff, $len);
-
- # try parsing it
- eval { $entry = XML::Atom::Entry->new( \$buff ); };
- return respond($r, 400, "Could not parse the entry due to invalid markup.<br /><pre>$@</pre>")
- if $@;
-
- # on post, the entry must NOT include an id
- return respond($r, 400, "Must not include an <b><id></b> field in a new entry.")
- if $entry->id;
-
- # detect 'standalone' media posts
- return handle_upload( @_, $entry )
- if $entry->get("http://sixapart.com/atom/typepad#", 'standalone');
-
- # remove the SvUTF8 flag. See same code in synsuck.pl for
- # an explanation
- $entry->title( LJ::no_utf8_flag( $entry->title ));
- $entry->link( LJ::no_utf8_flag( $entry->link ));
- $entry->content( LJ::no_utf8_flag( $entry->content->body ))
- if $entry->content;
-
- my @tags;
-
- eval {
- my @subjects = $entry->getlist('http://purl.org/dc/elements/1.1/', 'subject');
- push @tags, @subjects;
- };
- warn "Subjects parsing from ATOM died: $@" if $@;
-
- eval {
- my @categories = $entry->categories;
- push @tags, map { $_->label || $_->term } @categories;
- };
- warn "Categories parsing from ATOM died: $@" if $@;
-
- my $security_opts = { security => 'public' };
-
- # TODO Add code for handling this with XML::Atom::ext
- if ( ! $XML::Atom::Version || ( $XML::Atom::Version <= .13 ) ) {
- eval {
- foreach my $allow_element (map { XML::Atom::Util::nodelist($_, 'http://www.sixapart.com/ns/atom/privacy', 'allow') }
- XML::Atom::Util::nodelist($entry->{doc}, 'http://www.sixapart.com/ns/atom/privacy', 'privacy')) {
-
- my $policy = $allow_element->getAttribute('policy');
- next unless $policy eq 'http://www.sixapart.com/ns/atom/permissions#read';
-
- my $ref = $allow_element->getAttribute('ref');
-
- if ($ref =~ m/#(everyone|friends|self)$/) {
- $security_opts = {
- everyone => {
- security => 'public',
- },
- friends => {
- security => 'usemask',
- allowmask => 1,
- },
- self => {
- security => 'private',
- },
- }->{$1};
- }
- }
- };
-
- if ($@) {
- warn "While parsing privacy handling on AtomAPI call: $@\n";
- }
- }
-
- my $clb = $entry->get( "http://sixapart.com/atom/post#", "convertLineBreaks" );
- my $preformatted = ( $clb && $clb eq 'false' ) ? 1 : 0;
-
- # build a post event request.
- my $req = {
- 'usejournal' => ( $remote->{'userid'} != $u->{'userid'} ) ? $u->{'user'} : undef,
- 'ver' => 1,
- 'username' => $u->{'user'},
- 'lineendings' => 'unix',
- 'subject' => $entry->title(),
- 'event' => $entry->content()->body(),
- 'props' => { opt_preformatted => $preformatted, taglist => \@tags },
- 'tz' => 'guess',
- %$security_opts,
- };
-
- $req->{'props'}->{'interface'} = "atom";
-
- my $err;
- my $res = LJ::Protocol::do_request("postevent",
- $req, \$err, { 'noauth' => 1 });
-
- if ($err) {
- my $errstr = LJ::Protocol::error_message($err);
- return respond($r, 500, "Unable to post new entry. Protocol error: <b>$errstr</b>.");
- }
-
- my $atom_reply = XML::Atom::Entry->new();
- $atom_reply->title( $entry->title );
-
- my $content_body = $entry->content->body;
- $atom_reply->summary( substr( $content_body, 0, 100 ) );
- $atom_reply->content( $content_body );
-
- my $lj_entry = LJ::Entry->new($u, jitemid => $res->{itemid});
- $atom_reply->id( $lj_entry->atom_id );
-
- my $link;
- my $edit_url = "$LJ::SITEROOT/interface/atom/edit/$res->{'itemid'}";
-
- my $add_category = sub {
- my $category = XML::Atom::Category->new;
- $category->term(shift);
- $atom_reply->add_category($category);
- };
-
- # Old versions of XML::Atom don't have a category object, do it manually
- if ($XML::Atom::VERSION <= .21) {
- $add_category = sub {
- my $term = shift;
- $atom_reply->category(undef, { term => $term });
- };
- }
-
- foreach my $tag (@tags) {
- local $@;
- eval { $add_category->($tag) };
- warn "Unable to add category to XML::Atom feed: $@"
- if $@;
- }
-
- $link = XML::Atom::Link->new();
- $link->type('application/x.atom+xml');
- $link->rel('service.edit');
- $link->href( $edit_url );
- $link->title( $entry->title() );
- $atom_reply->add_link($link);
-
- $link = XML::Atom::Link->new();
- $link->type('text/html');
- $link->rel('alternate');
- $link->href( $res->{url} );
- $link->title( $entry->title() );
- $atom_reply->add_link($link);
-
- $r->header_out("Location", $edit_url);
- return respond($r, 201, \$atom_reply->as_xml(), 'atom');
-}
-
-sub handle_edit {
- my ($r, $remote, $u, $opts) = @_;
-
- my $method = $opts->{'method'};
-
- # first, try to load the item and fail if it's not there
- my $jitemid = $opts->{'param'};
- my $req = {
- 'usejournal' => ($remote->{'userid'} != $u->{'userid'}) ?
- $u->{'user'} : undef,
- 'ver' => 1,
- 'username' => $u->{'user'},
- 'selecttype' => 'one',
- 'itemid' => $jitemid,
- };
-
- my $err;
- my $olditem = LJ::Protocol::do_request("getevents",
- $req, \$err, { 'noauth' => 1 });
-
- if ($err) {
- my $errstr = LJ::Protocol::error_message($err);
- return respond($r, 404, "Unable to retrieve the item requested for editing. Protocol error: <b>$errstr</b>.");
- }
- $olditem = $olditem->{'events'}->[0];
-
- if ($method eq "GET") {
- # return an AtomEntry for this item
- # use the interface between make_feed and create_view_atom in
- # ljfeed.pl
-
- # get the log2 row (need logtime for createtime)
- my $row = LJ::get_log2_row($u, $jitemid) ||
- return respond($r, 404, "Could not load the original entry.");
-
- # we need to put into $item: itemid, ditemid, subject, event,
- # createtime, eventtime, modtime
-
- my $ctime = LJ::mysqldate_to_time($row->{'logtime'}, 1);
-
- my $tagstring = $olditem->{'props'}->{'taglist'} || '';
- my $tags = [ split(/\s*,\s*/, $tagstring) ];
-
- my $item = {
- 'itemid' => $olditem->{'itemid'},
- 'ditemid' => $olditem->{'itemid'}*256 + $olditem->{'anum'},
- 'eventtime' => LJ::alldatepart_s2($row->{'eventtime'}),
- 'createtime' => $ctime,
- 'modtime' => $olditem->{'props'}->{'revtime'} || $ctime,
- 'subject' => $olditem->{'subject'},
- 'event' => $olditem->{'event'},
- 'tags' => $tags,
- };
-
- my $ret = LJ::Feed::create_view_atom(
- { 'u' => $u },
- $u,
- {
- 'single_entry' => 1,
- 'apilinks' => 1,
- },
- [$item]
- );
-
- return respond($r, 200, \$ret, 'xml');
- }
-
- if ($method eq "PUT") {
- # Check length
- my $len = $r->header_in("Content-length");
- return respond($r, 400, "Content is too long")
- if $len > $LJ::MAX_ATOM_UPLOAD;
-
- # read the content
- my $buff;
- $r->read($buff, $len);
-
- # try parsing it
- my $entry;
- eval { $entry = XML::Atom::Entry->new( \$buff ); };
- return respond($r, 400, "Could not parse the entry due to invalid markup.<br /><pre>$@</pre>")
- if $@;
-
- # remove the SvUTF8 flag. See same code in synsuck.pl for
- # an explanation
- $entry->title( LJ::no_utf8_flag( $entry->title ));
- $entry->link( LJ::no_utf8_flag( $entry->link ));
- $entry->content( LJ::no_utf8_flag( $entry->content->body ));
-
- # the AtomEntry must include <id> which must match the one we sent
- # on GET
- unless ($entry->id =~ m#,\d{4}-\d{2}-\d{2}:$u->{userid}:(\d+)$# &&
- $1 == $olditem->{'itemid'}*256 + $olditem->{'anum'}) {
- return respond($r, 400, "Incorrect <b><id></b> field in this request.");
- }
-
- # build an edit event request. Preserve fields that aren't being
- # changed by this item (perhaps the AtomEntry isn't carrying the
- # complete information).
-
- $req = {
- 'usejournal' => ( $remote->{'userid'} != $u->{'userid'} ) ? $u->{'user'} : undef,
- 'ver' => 1,
- 'username' => $u->{'user'},
- 'itemid' => $jitemid,
- 'lineendings' => 'unix',
- 'subject' => $entry->title() || $olditem->{'subject'},
- 'event' => $entry->content()->body() || $olditem->{'event'},
- 'props' => $olditem->{'props'},
- 'security' => $olditem->{'security'},
- 'allowmask' => $olditem->{'allowmask'},
- };
-
- $err = undef;
- my $res = LJ::Protocol::do_request("editevent",
- $req, \$err, { 'noauth' => 1 });
-
- if ($err) {
- my $errstr = LJ::Protocol::error_message($err);
- return respond($r, 500, "Unable to update entry. Protocol error: <b>$errstr</b>.");
- }
-
- return respond($r, 200, "The entry was successfully updated.");
- }
-
- if ($method eq "DELETE") {
-
- # build an edit event request to delete the entry.
-
- $req = {
- 'usejournal' => ($remote->{'userid'} != $u->{'userid'}) ?
- $u->{'user'}:undef,
- 'ver' => 1,
- 'username' => $u->{'user'},
- 'itemid' => $jitemid,
- 'lineendings' => 'unix',
- 'event' => '',
- };
-
- $err = undef;
- my $res = LJ::Protocol::do_request("editevent",
- $req, \$err, { 'noauth' => 1 });
-
- if ($err) {
- my $errstr = LJ::Protocol::error_message($err);
- return respond($r, 500, "Unable to delete entry. Protocol error: <b>$errstr</b>.");
- }
-
- return respond($r, 200, "Entry successfully deleted.");
- }
-
-}
-
-# fetch lj tags, display as categories
-sub handle_categories
-{
- my ($r, $remote, $u, $opts) = @_;
- my $ret = '<?xml version="1.0"?>';
- $ret .= '<categories xmlns="http://sixapart.com/atom/category#">';
-
- my $tags = LJ::Tags::get_usertags($u, { remote => $remote }) || {};
- foreach (sort { $a->{name} cmp $b->{name} } values %$tags) {
- $ret .= "<subject xmlns=\"http://purl.org/dc/elements/1.1/\">$_->{name}</subject>";
- }
- $ret .= '</categories>';
-
- return respond($r, 200, \$ret, 'xml');
-}
-
-sub handle_feed {
- my ($r, $remote, $u, $opts) = @_;
-
- # simulate a call to the S1 data view creator, with appropriate
- # options
-
- my %op = ('pathextra' => "/atom",
- 'apilinks' => 1,
- );
- my $ret = LJ::Feed::make_feed($r, $u, $remote, \%op);
-
- unless (defined $ret) {
- if ($op{'redir'}) {
- # this happens if the account was renamed or a syn account.
- # the redir URL is wrong because ljfeed.pl is too
- # dataview-specific. Since this is an admin interface, we can
- # just fail.
- return respond ($r, 404, "The account <b>$u->{'user'} </b> is of a wrong type and does not allow AtomAPI administration.");
- }
- if ($op{'handler_return'}) {
- # this could be a conditional GET shortcut, honor it
- $r->status($op{'handler_return'});
- return OK;
- }
- # should never get here
- return respond ($r, 404, "Unknown error.");
- }
-
- # everything's fine, return the XML body with the correct content type
- return respond($r, 200, \$ret, 'xml');
-
-}
-
-# this routine accepts the apache request handle, performs
-# authentication, calls the appropriate method handler, and
-# prints the response.
-sub handle {
- # FIXME: Move this up to caller(s).
- my $r = DW::Request->get;
-
- return respond($r, 404, "This server does not support the Atom API.")
- unless LJ::ModuleCheck->have_xmlatom;
-
- # break the uri down: /interface/atom/<verb>[/<number>]
- # or old format: /interface/atomapi/<username>/<verb>[/<number>]
- my $uri = $r->uri;
-
- # convert old format to new format:
- my $username; # old
- if ($uri =~ s!^/interface/atomapi/(\w+)/!/interface/atom/!) {
- $username = $1;
- }
-
- $uri =~ s!^/interface/atom/?!! or return respond($r, 404, "Bogus URL");
- my ($action, $param) = split(m!/!, $uri);
-
- my $valid_actions = qr{feed|edit|post|upload|categories};
-
- # let's authenticate.
- #
- # if wsse information is supplied, use it.
- # if not, fall back to digest.
- my $wsse = $r->header_in('X-WSSE');
- my $nonce_dup;
- my $u = $wsse ? auth_wsse($wsse, \$nonce_dup) : LJ::auth_digest($r);
- return respond( $r, 401, "Authentication failed for this AtomAPI request.")
- unless $u;
-
- return respond( $r, 401, "Authentication failed for this AtomAPI request.")
- if $nonce_dup && $action && $action ne 'post';
-
- # service autodiscovery
- # TODO: Add communities?
- my $method = $r->method;
- if ( $method eq 'GET' && ! $action ) {
- my $title = $u->prop( 'journaltitle' ) || $u->user;
- my $feed = XML::Atom::Feed->new();
-
- my $add_link = sub {
- my $subservice = shift;
- my $link = XML::Atom::Link->new();
- $link->title($title);
- $link->type('application/x.atom+xml');
- $link->rel("service.$subservice");
- $link->href("$LJ::SITEROOT/interface/atom/$subservice");
- $feed->add_link($link);
- };
-
- foreach my $subservice (qw/ post edit feed categories /) {
- $add_link->($subservice);
- }
-
- my $link = XML::Atom::Link->new();
- $link->title($title);
- $link->type('text/html');
- $link->rel('alternate');
- $link->href( $u->journal_base );
- $feed->add_link($link);
-
- return respond($r, 200, \$feed->as_xml(), 'atom');
- }
-
- $action =~ /^$valid_actions$/
- or return respond($r, 400, "Unknown URI scheme: /interface/atom/<b>" . LJ::ehtml($action) . "</b>");
-
- unless (($action eq 'feed' and $method eq 'GET') or
- ($action eq 'categories' and $method eq 'GET') or
- ($action eq 'post' and $method eq 'POST') or
- ($action eq 'upload' and $method eq 'POST') or
- ($action eq 'edit' and
- {'GET'=>1,'PUT'=>1,'DELETE'=>1}->{$method})) {
- return respond($r, 400, "URI scheme /interface/atom/<b>" . LJ::ehtml($action) . "</b> is incompatible with request method <b>$method</b>.");
- }
-
- if (($action ne 'edit' && $param) or
- ($action eq 'edit' && $param !~ m#^\d+$#)) {
- return respond($r, 400, "Either the URI lacks a required parameter, or its format is improper.");
- }
-
- # we've authenticated successfully and remote is set. But can remote
- # manage the requested account?
- my $remote = LJ::get_remote();
- unless ( $remote && $remote->can_manage( $u ) ) {
- return respond( $r, 403, "User <b>$remote->{user}</b> has no administrative access to account <b>$u->{user}</b>." );
- }
-
- # handle the requested action
- my $opts = {
- 'action' => $action,
- 'method' => $method,
- 'param' => $param
- };
-
- {
- 'feed' => \&handle_feed,
- 'post' => \&handle_post,
- 'edit' => \&handle_edit,
- 'upload' => \&handle_upload,
- 'categories' => \&handle_categories,
- }->{$action}->( $r, $remote, $u, $opts );
-
- return OK;
-}
-
-# Authenticate via the WSSE header.
-# Returns valid $u on success, undef on failure.
-sub auth_wsse
-{
- my ($wsse, $nonce_dup) = @_;
- my $fail = sub {
- my $reason = shift;
- return undef;
- };
- $wsse =~ s/UsernameToken // or return $fail->("no username token");
-
- # parse credentials into a hash.
- my %creds;
- foreach (split /, /, $wsse) {
- my ($k, $v) = split '=', $_, 2;
- $v =~ s/^[\'\"]//;
- $v =~ s/[\'\"]$//;
- $v =~ s/=$// if $k =~ /passworddigest/i; # strip base64 newline char
- $creds{ lc($k) } = $v;
- }
-
- # invalid create time? invalid wsse.
- my $ctime = LJ::ParseFeed::w3cdtf_to_time( $creds{created} ) or
- return $fail->("no created date");
-
- # prevent replay attacks.
- $ctime = LJ::mysqldate_to_time( $ctime, 'gmt' );
- return $fail->("replay time skew") if abs(time() - $ctime) > 42300;
-
- my $u = LJ::load_user( LJ::canonical_username( $creds{'username'} ) )
- or return $fail->("invalid username [$creds{username}]");
-
- if (@LJ::MEMCACHE_SERVERS && ref $nonce_dup) {
- $$nonce_dup = 1
- unless LJ::MemCache::add( "wsse_auth:$creds{username}:$creds{nonce}", 1, 180 )
- }
-
- # validate hash
- my $hash =
- Digest::SHA1::sha1_base64(
- $creds{nonce} . $creds{created} . $u->password );
-
- if (LJ::login_ip_banned($u)) {
- return $fail->("ip_ratelimiting");
- }
-
- # Nokia's WSSE implementation is incorrect as of 1.5, and they
- # base64 encode their nonce *value*. If the initial comparison
- # fails, we need to try this as well before saying it's invalid.
- if ($hash ne $creds{passworddigest}) {
-
- $hash =
- Digest::SHA1::sha1_base64(
- MIME::Base64::decode_base64( $creds{nonce} ) .
- $creds{created} .
- $u->password );
-
- if ($hash ne $creds{passworddigest}) {
- LJ::handle_bad_login($u);
- return $fail->("hash wrong");
- }
- }
-
- # If we're here, we're valid.
- LJ::set_remote($u);
- return $u;
-}
-
-1;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/DW/Controller/Interface/AtomAPI.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/DW/Controller/Interface/AtomAPI.pm Mon Feb 07 12:52:01 2011 +0800
@@ -0,0 +1,566 @@
+#!/usr/bin/perl
+#
+# DW::Controller::Interface::AtomAPI
+#
+# This controller is for the Atom Publishing Protocol interface
+#
+# Authors:
+# Afuna <coder.dw@afunamatata.com>
+#
+# Copyright (c) 2011 by Dreamwidth Studios, LLC.
+#
+# This program is free software; you may redistribute it and/or modify it under
+# the same terms as Perl itself. For a copy of the license, please reference
+# 'perldoc perlartistic' or 'perldoc perlgpl'.
+#
+
+package DW::Controller::Interface::AtomAPI;
+
+use strict;
+use DW::Routing;
+use LJ::ParseFeed;
+
+use XML::Atom::Entry;
+use XML::Atom::Category;
+use Digest::SHA1;
+use MIME::Base64;
+
+require 'ljprotocol.pl';
+
+# service document URL is the same for all users
+DW::Routing->register_string( "/interface/atom", \&service_document, app => 1, format => "atom" );
+
+# note: safe to put these pages in the user subdomain even if they modify data
+# because we don't use cookies (so even if a user's cookies are stolen...)
+DW::Routing->register_string( "/interface/atom/entries", \&entries_handler, user => 1, format => "atom" );
+DW::Routing->register_string( "/interface/atom/entries/tags", \&categories_document, user => 1, format => "atom" );
+DW::Routing->register_regex( qr#/interface/atom/entries/(\d+)#, \&entry_handler, user => 1, format => "atom" );
+
+sub ok {
+ my ( $message, $status, $content_type ) = @_;
+ return DW::Template->render_string(
+ $message,
+ { status => $status || DW::Request->get->OK,
+ content_type => $content_type || "application/atom+xml",
+ no_sitescheme => 1,
+ }
+ );
+}
+
+sub err {
+ my ( $message, $status ) = @_;
+ return DW::Template->render_string(
+ $message,
+ { status => $status || DW::Request->get->NOT_FOUND,
+ content_type => "text/plain",
+ no_sitescheme => 1,
+ }
+ );
+}
+
+sub check_enabled {
+ return ( 0, err( "This server does not support the Atom API." ) )
+ unless LJ::ModuleCheck->have_xmlatom;
+
+ return ( 1 );
+}
+
+sub authenticate {
+ my ( %opts ) = @_;
+ my $r = DW::Request->get;
+
+ # if wsse information is provided, use it
+ # if not, fall back to digest
+ my $nonce_dup;
+ my $wsse = $r->header_in( "X-WSSE" );
+ my $remote = $wsse ? _auth_wsse( $wsse, \$nonce_dup ) : LJ::auth_digest( $r );
+ my $u = LJ::load_user( $opts{journal} ) || $remote;
+
+ return ( 0, err( "Authentication failed for this AtomAPI request.",
+ $r->HTTP_UNAUTHORIZED ) )
+ if ! $remote || ( $nonce_dup && ! $opts{allow_duplicate_nonce} );
+
+ return ( 0, err( "User $remote->{user} has no posting access to account $u->{user}.",
+ $r->HTTP_UNAUTHORIZED ) )
+ if ! $remote->can_post_to( $u );
+
+ return ( 1, { u => $u, remote => $remote } );
+}
+sub _auth_wsse {
+ my ( $wsse, $nonce_dup ) = @_;
+
+ my $fail = sub {
+ my $reason = shift;
+ return undef;
+ };
+
+ $wsse =~ s/UsernameToken // or return $fail->( "no username token" );
+
+ # parse credentials into a hash.
+ my %creds;
+ foreach ( split /, /, $wsse ) {
+ my ($k, $v) = split '=', $_, 2;
+ $v =~ s/^[\'\"]//;
+ $v =~ s/[\'\"]$//;
+ $v =~ s/=$// if $k =~ /passworddigest/i; # strip base64 newline char
+ $creds{ lc($k) } = $v;
+ }
+
+ # invalid create time? invalid wsse.
+ my $ctime = LJ::ParseFeed::w3cdtf_to_time( $creds{created} ) or
+ return $fail->( "no created date" );
+
+ # prevent replay attacks.
+ $ctime = LJ::mysqldate_to_time( $ctime, 'gmt' );
+ return $fail->( "replay time skew" ) if abs( time() - $ctime ) > 42300;
+
+ my $u = LJ::load_user( LJ::canonical_username( $creds{username} ) )
+ or return $fail->( "invalid username [$creds{username}]" );
+
+ if (@LJ::MEMCACHE_SERVERS && ref $nonce_dup) {
+ $$nonce_dup = 1
+ unless LJ::MemCache::add( "wsse_auth:$creds{username}:$creds{nonce}", 1, 180 )
+ }
+
+ # validate hash
+ my $hash =
+ Digest::SHA1::sha1_base64(
+ $creds{nonce} . $creds{created} . $u->password );
+
+ # Nokia's WSSE implementation is incorrect as of 1.5, and they
+ # base64 encode their nonce *value*. If the initial comparison
+ # fails, we need to try this as well before saying it's invalid.
+ if ( $hash ne $creds{passworddigest} ) {
+ $hash =
+ Digest::SHA1::sha1_base64(
+ MIME::Base64::decode_base64( $creds{nonce} ) .
+ $creds{created} .
+ $u->password );
+
+ if ( $hash ne $creds{passworddigest} ) {
+ LJ::handle_bad_login( $u );
+ return $fail->( "hash wrong" );
+ }
+ }
+
+ return $fail->( "ip_ratelimiting" )
+ if LJ::login_ip_banned( $u );
+
+ # If we're here, we're valid.
+ LJ::set_remote( $u );
+ return $u;
+}
+
+sub _create_workspace {
+ my ( $u ) = @_;
+
+ my $atom_base = $u->atom_base;
+ my $title = LJ::exml( $u->prop( "journaltitle" ) || $u->user );
+
+ my $ret = qq{
+ <workspace>
+ <atom:title>$title</atom:title>
+ };
+
+ # entries
+ $ret .= qq{<collection href="$atom_base/entries">
+ <atom:title>Entries</atom:title>
+ <accept>application/atom+xml;type=entry</accept>
+ <categories href="$atom_base/entries/tags" />
+ </collection>
+ };
+
+ # add media, etc collections when available
+
+ $ret .= "</workspace>";
+
+ return $ret;
+}
+sub service_document {
+ my ( $call_info ) = @_;
+
+ my ( $ok, $rv ) = check_enabled();
+ return $rv unless $ok;
+
+ # detect the user's journal based on the account they log in as
+ # not based on the journal subdomain they are currently trying to view
+ # (since we're not on a subdomain)
+ ( $ok, $rv ) = authenticate();
+ return $rv unless $ok;
+
+ my $r = DW::Request->get;
+
+ my $method = $r->method;
+ return err( "URI scheme /interface/atom/ is incompatible with $method" )
+ unless $method eq "GET";
+
+ # FIXME: use XML::Atom::Service?
+ my $ret = qq{<?xml version="1.0"?>};
+ $ret .= qq{<service xmlns="http://www.w3.org/2007/app" xmlns:atom="http://www.w3.org/2005/Atom">};
+
+ $ret .= _create_workspace( $rv->{u} );
+
+ my @comms = $rv->{u}->posting_access_list;
+ $ret .= _create_workspace( $_ ) foreach @comms;
+
+ $ret .= "</service>";
+
+ return ok( $ret, $r->OK, "application/atomsvc+xml; charset=utf-8" );
+}
+
+sub categories_document {
+ my ( $call_info ) = @_;
+
+ my ( $ok, $rv ) = check_enabled();
+ return $rv unless $ok;
+
+ ( $ok, $rv ) = authenticate( journal => $call_info->username );
+ return $rv unless $ok;
+
+ my $u = $rv->{u};
+ my $remote = $rv->{remote};
+
+ my $r = DW::Request->get;
+
+ return err( "URI scheme /interface/atom/entries/tags is incompatible with " . $r->method ) unless $r->method eq "GET";
+
+ my $ret = qq{<?xml version="1.0"?>};
+ $ret .= qq{<categories xmlns="http://www.w3.org/2007/app" xmlns:atom="http://www.w3.org/2005/Atom">};
+
+ my $tags = LJ::Tags::get_usertags( $u, { remote => $remote } ) || {};
+ foreach ( sort { $a->{name} cmp $b->{name} } values %$tags ) {
+ my $name = LJ::exml( $_->{name} );
+ $ret .= qq{<atom:category term="$name" />};
+ }
+
+ $ret .= '</categories>';
+
+ return ok( $ret, $r->OK, "application/atomcat+xml; charset=utf-8" );
+}
+
+
+sub entries_handler {
+ my ( $call_info ) = @_;
+
+ my ( $ok, $rv ) = check_enabled();
+ return $rv unless $ok;
+
+ ( $ok, $rv ) = authenticate( allow_duplicate_nonce => 1, journal => $call_info->username );
+ return $rv unless $ok;
+
+ my $r = DW::Request->get;
+ return _create_entry( %$rv ) if $r->method eq "POST";
+ return _list_entries( %$rv ) if $r->method eq "GET";
+
+ return err( "URI scheme /interface/atom/entries is incompatible with " . $r->method );
+}
+
+sub _create_entry {
+ my ( %opts ) = @_;
+ my $u = $opts{u};
+ my $remote = $opts{remote};
+
+ my $r = DW::Request->get;
+
+ my ( $buff, $len, $entry );
+ $buff = $r->pnote( "input" ) if $LJ::T_PASS_INPUT_THROUGH_REQUEST;
+
+ unless ( $buff ) {
+ # check length
+ $len = $r->header_in( "Content-length" );
+ return err( "Content is too long", $r->HTTP_BAD_REQUEST )
+ if $len > $LJ::MAX_ATOM_UPLOAD;
+
+ # read the content
+ $r->read( $buff, $len );
+ }
+
+ # try parsing
+ eval { $entry = XML::Atom::Entry->new( \$buff ); };
+ return err( "Could not parse the entry due to invalid markup.\n\n $@" )
+ if $@;
+
+ # remove the SvUTF8 flag. See same code in LJ::SynSuck for
+ # an explanation
+ $entry->title( LJ::no_utf8_flag( $entry->title ));
+ $entry->link( LJ::no_utf8_flag( $entry->link ));
+ $entry->content( LJ::no_utf8_flag( $entry->content->body ))
+ if $entry->content;
+
+ # extract the list of tags from the provided categories
+ my @tags = map { LJ::no_utf8_flag( $_->term ) } $entry->category;
+
+ # post to the protocol
+ # we ignore some things provided by the user,
+ # such as the entry id, and the update time
+ # FIXME: use an XML::Atom extension to add security options
+ my $req = {
+ ver => 1,
+ username => $remote->user,
+ usejournal => ! $remote->equals( $u ) ? $u->user : undef,
+ lineendings => 'unix',
+ subject => $entry->title,
+ event => $entry->content->body,
+ props => { taglist => \@tags, },
+ tz => 'guess',
+ };
+
+ $req->{props}->{interface} = "atom";
+
+ my $err;
+ my $res = LJ::Protocol::do_request( "postevent", $req, \$err, { noauth => 1 } );
+ if ( $err ) {
+ my $errstr = LJ::Protocol::error_message( $err );
+ return err( "Unable to post new entry. Protocol error: $errstr", $r->HTTP_SERVER_ERROR );
+ }
+
+ my $entry_obj = LJ::Entry->new( $u, jitemid => $res->{itemid} );
+ my $atom_reply = $entry_obj->atom_entry( apilinks => 1, synlevel => 'full' );
+
+ $r->header_out( "Location", $entry_obj->atom_url );
+ return ok( $atom_reply->as_xml, $r->HTTP_CREATED );
+}
+
+sub _list_entries {
+ my ( %opts ) = @_;
+ my $u = $opts{u};
+ my $remote = $opts{remote};
+
+ my $r = DW::Request->get;
+
+ # simulate a call to the S1 data view creator, with appropriate options
+ my %op = (
+ pathextra => "/atom",
+ apilinks => 1,
+ );
+ my $ret = LJ::Feed::make_feed( $r, $u, $remote, \%op );
+
+ unless ( defined $ret ) {
+ if ( $op{redir} ) {
+ # this happens if the account was renamed or a syn account.
+ # the redir URL is wrong because ljfeed.pl is too
+ # dataview-specific. Since this is an admin interface, we can
+ # just fail.
+ return err( qq{The account "$u->{user}" is of a wrong type and does not allow AtomAPI administration.}, $r->NOT_FOUND );
+ }
+ if ( $op{handler_return} ) {
+ # this could be a conditional GET shortcut, honor it
+ $r->status( $op{handler_return} );
+ return $r->OK;
+ }
+
+ # should never get here
+ return err( "Unknown error", $r->NOT_FOUND );
+ }
+
+ return ok( $ret );
+}
+
+
+sub entry_handler {
+ my ( $call_info ) = @_;
+
+ my ( $ok, $rv ) = check_enabled();
+ return $rv unless $ok;
+
+ ( $ok, $rv ) = authenticate( journal => $call_info->username, allow_duplicate_nonce => 1 );
+ return $rv unless $ok;
+
+ my $r = DW::Request->get;
+
+ my $u = $rv->{u};
+ my $remote = $rv->{remote};
+
+ my $jitemid = int( $call_info->subpatterns->[0] || 0 );
+
+ my $req = {
+ ver => 1,
+ username => $remote->user,
+ usejournal => ! $remote->equals( $u ) ? $u->user : undef,
+ itemid => $jitemid,
+ selecttype => 'one'
+ };
+
+ my $err;
+ my $olditem = LJ::Protocol::do_request( "getevents",
+ $req, \$err, { noauth => 1 } );
+
+ if ( $err ) {
+ my $errstr = LJ::Protocol::error_message( $err );
+ return err( "Unable to retrieve the item requested for editing. Protocol error: $errstr", $r->NOT_FOUND );
+ }
+
+ return err( "No entry found.", $r->NOT_FOUND )
+ unless scalar @{ $olditem->{events} };
+
+ my $entry_obj = LJ::Entry->new( $u, jitemid => $jitemid );
+ return err( "You aren't authorize to view this entry.", $r->HTTP_UNAUTHORIZED )
+ unless $entry_obj && $entry_obj->visible_to( $remote );
+
+ return _retrieve_entry( %$rv, item => $olditem->{events}->[0], entry_obj => $entry_obj ) if $r->method eq "GET";
+ return _edit_entry( %$rv, item => $olditem->{events}->[0], entry_obj => $entry_obj ) if $r->method eq "PUT";
+ return _delete_entry( %$rv, item => $olditem->{events}->[0], entry_obj => $entry_obj ) if $r->method eq "DELETE";
+
+ return err( "URI scheme /interface/atom/entries/$jitemid is incompatible with " . $r->method );
+}
+
+sub _retrieve_entry {
+ my ( %opts ) = @_;
+
+ my $u = $opts{u};
+ my $remote = $opts{remote};
+ my $olditem = $opts{item};
+ my $e = $opts{entry_obj};
+
+ my $r = DW::Request->get;
+
+ return ( 0, err( "You aren't authorized to retrieve this entry.",
+ $r->HTTP_UNAUTHORIZED ) )
+ unless $e->poster->equals( $remote ) || $remote->can_manage( $u );
+
+ return ok( $e->atom_entry( apilinks => 1, synlevel => 'full' )->as_xml, );
+}
+
+# Perhaps check If-Match and If-Unmodified-Since?
+sub _edit_entry {
+ my ( %opts ) = @_;
+
+ my $u = $opts{u};
+ my $remote = $opts{remote};
+ my $olditem = $opts{item};
+ my $entry_obj = $opts{entry_obj};
+
+ my $r = DW::Request->get;
+
+ return ( 0, err( "You aren't authorized to edit this entry.",
+ $r->HTTP_UNAUTHORIZED ) )
+ unless $entry_obj->poster->equals( $remote );
+
+ return ( 0, err( "Can't edit entry: journal is readonly.",
+ $r->BAD_REQUEST ) )
+ if $u->is_readonly || $remote->is_readonly;
+
+
+ my ( $buff, $len, $atom_entry );
+ $buff = $r->pnote( "input" ) if $LJ::T_PASS_INPUT_THROUGH_REQUEST;
+
+ unless ( $buff ) {
+ # check length
+ $len = $r->header_in( "Content-length" );
+ return err( "Content is too long", $r->HTTP_BAD_REQUEST )
+ if $len > $LJ::MAX_ATOM_UPLOAD;
+
+ # read the content
+ $r->read( $buff, $len );
+ }
+
+ # try parsing
+ eval { $atom_entry = XML::Atom::Entry->new( \$buff ); };
+ return err( "Could not parse the entry due to invalid markup.\n\n $@" )
+ if $@;
+
+ # the AtomEntry must include <id> which must match the one we sent
+ # on GET
+
+ return err( "Incorrect id field for entry in this request.", $r->HTTP_BAD_REQUEST )
+ unless $atom_entry->id eq $entry_obj->atom_id;
+
+ # remove the SvUTF8 flag. See same code in LJ::SynSuck for
+ # an explanation
+ $atom_entry->title( LJ::no_utf8_flag( $atom_entry->title ));
+ $atom_entry->link( LJ::no_utf8_flag( $atom_entry->link ));
+ $atom_entry->content( LJ::no_utf8_flag( $atom_entry->content->body ))
+ if $atom_entry->content;
+
+ # extract the list of tags from the provided categories
+ my @tags = map { LJ::no_utf8_flag( $_->term ) } $atom_entry->category;
+
+ # build an edit event request. Preserve fields that aren't being
+ # changed by this item (perhaps the AtomEntry isn't carrying the
+ # complete information).
+
+ my $props = $olditem->{props};
+ delete $props->{revnum};
+ delete $props->{revtime};
+ $props->{taglist} = join( ", ", @tags ) if @tags;
+
+ my $req = {
+ ver => 1,
+ username => $remote->user,
+ usejournal => ! $remote->equals( $u ) ? $u->user : undef,
+ itemid => $olditem->{itemid},
+ lineendings => 'unix',
+ subject => $atom_entry->title || $olditem->{subject},
+ event => $atom_entry->content->body || $olditem->{event},
+ props => $props,
+ security => $olditem->{security},
+ allowmask => $olditem->{allowmask},
+ };
+
+ my $err = undef;
+ my $res = LJ::Protocol::do_request( "editevent", $req, \$err, { noauth => 1 } );
+ if ( $err ) {
+ my $errstr = LJ::Protocol::error_message( $err );
+ return err( "Unable to edit entry. Protocol error: $errstr", $r->HTTP_SERVER_ERROR );
+ }
+
+ return ok( "The entry was succesfully updated.", $r->OK );
+}
+
+sub _delete_entry {
+ # build an edit event request to delete the entry.
+ my ( %opts ) = @_;
+
+ my $u = $opts{u};
+ my $remote = $opts{remote};
+ my $olditem = $opts{item};
+ my $entry_obj = $opts{entry_obj};
+
+ my $r = DW::Request->get;
+
+ return ( 0, err( "You aren't authorized to delete this entry.",
+ $r->HTTP_UNAUTHORIZED ) )
+ unless $entry_obj->poster->equals( $remote ) || $remote->can_manage( $u );
+
+
+ my $req = {
+ usejournal => ! $remote->equals( $u ) ? $u->user : undef,
+ ver => 1,
+ username => $remote->user,
+ itemid => $olditem->{itemid},
+ lineendings => 'unix',
+ event => '',
+ };
+
+ my $err = undef;
+ my $res = LJ::Protocol::do_request( "editevent", $req, \$err, { noauth => 1 } );
+
+ if ( $err ) {
+ my $errstr = LJ::Protocol::error_message( $err );
+ return err( "Unable to delete entry. Protocol error: $errstr", $r->HTTP_SERVER_ERROR );
+ }
+
+ return ok( "Entry was succesfully deleted.", $r->OK );
+}
+
+
+# old URL format, retaining for compatibility with old simple clients like LoudTwitter, which don't support service discovery
+DW::Routing->register_string( "/interface/atom/post", \&post_entry_compat, app => 1, format => "atom" );
+sub post_entry_compat {
+ my ( $call_info ) = @_;
+
+ my ( $ok, $rv ) = check_enabled();
+ return $rv unless $ok;
+
+ ( $ok, $rv ) = authenticate( allow_duplicate_nonce => 1 );
+ return $rv unless $ok;
+
+ my $r = DW::Request->get;
+ return _create_entry( %$rv ) if $r->method eq "POST";
+ return ok( "The method at this URL is deprecated. Use the service document URL, " . $rv->{u}->atom_service_document . ", when setting up your client." ) if $r->method eq "GET";
+
+ return err( "URI scheme /interface/atom/entries is incompatible with " . $r->method );
+}
+
+
+1;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/DW/Controller/Interface/S2.pm
--- a/cgi-bin/DW/Controller/Interface/S2.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/DW/Controller/Interface/S2.pm Mon Feb 07 12:52:01 2011 +0800
@@ -86,7 +86,7 @@ sub interface_handler {
LJ::S2::layer_compile( $lay, \$error, { s2ref => \$s2code } );
if ( $error ) {
- error( $r, $r->HTTP_INTERNAL_SERVER_ERROR, "Layer Compile Error", "An error was encountered while compiling the layer." );
+ error( $r, $r->HTTP_SERVER_ERROR, "Layer Compile Error", "An error was encountered while compiling the layer." );
## Strip any absolute paths
$error =~ s/LJ::.+//s;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/DW/Request/Apache2.pm
--- a/cgi-bin/DW/Request/Apache2.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/DW/Request/Apache2.pm Mon Feb 07 12:52:01 2011 +0800
@@ -274,6 +274,10 @@ sub OK {
return Apache2::Const::OK;
}
+sub HTTP_CREATED {
+ return Apache2::Const::HTTP_CREATED;
+}
+
sub REDIRECT {
my DW::Request::Apache2 $self = $_[0];
return Apache2::Const::REDIRECT;
@@ -300,7 +304,7 @@ sub HTTP_UNSUPPORTED_MEDIA_TYPE {
return Apache2::Const::HTTP_UNSUPPORTED_MEDIA_TYPE;
}
-sub HTTP_INTERNAL_SERVER_ERROR {
+sub HTTP_SERVER_ERROR {
return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
}
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/DW/Request/Standard.pm
--- a/cgi-bin/DW/Request/Standard.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/DW/Request/Standard.pm Mon Feb 07 12:52:01 2011 +0800
@@ -240,8 +240,17 @@ sub status_line {
}
# meets conditions
+# conditional GET triggered on:
+# If-Modified-Since
+# If-Unmodified-Since FIXME: implement
+# If-Match FIXME: implement
+# If-None-Match FIXME: implement
+# If-Range FIXME: implement
sub meets_conditions {
my DW::Request::Standard $self = $_[0];
+
+ return $self->OK
+ if LJ::http_to_time( $self->header_in("If-Modified-Since") ) <= LJ::http_to_time( $self->header_out("Last-Modified") );
# FIXME: this should be pretty easy ... check the If headers (only time ones?)
# and see if they're good or not. return proper status code here (OK, NOT_MODIFIED)
@@ -280,7 +289,10 @@ sub call_bml {
# constants sometimes used
sub OK { return 200; }
+sub HTTP_CREATED { return 201; }
sub REDIRECT { return 302; }
+sub HTTP_BAD_REQUEST { return 400; }
+sub HTTP_UNAUTHORIZED { return 403; }
sub NOT_FOUND { return 404; }
sub HTTP_SERVER_ERROR { return 500; }
@@ -289,4 +301,11 @@ sub spawn {
confess "Sorry, spawning not implemented.\n";
}
+# simply sets the location header and returns REDIRECT
+sub redirect {
+ my $self = $_[0];
+ $self->header_out( Location => $_[1] );
+ return $self->REDIRECT;
+}
+
1;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/DW/Routing.pm
--- a/cgi-bin/DW/Routing.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/DW/Routing.pm Mon Feb 07 12:52:01 2011 +0800
@@ -36,6 +36,7 @@ my $default_content_types = {
'json' => "application/json; charset=utf-8",
'plain' => "text/plain; charset=utf-8",
'png' => "image/png",
+ 'atom' => "application/atom+xml; charset=utf-8",
};
LJ::ModuleLoader->require_subclasses( "DW::Controller" )
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/LJ/Entry.pm
--- a/cgi-bin/LJ/Entry.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/LJ/Entry.pm Mon Feb 07 12:52:01 2011 +0800
@@ -333,6 +333,11 @@ sub modtime_unix {
return LJ::mysqldate_to_time($self->{logtime}, 1);
}
+sub revtime_unix {
+ my $self = $_[0];
+ return $self->prop( "revtime" );
+}
+
sub security {
my $self = $_[0];
__PACKAGE__->preload_rows([ $self ]) unless $self->{_loaded_row};
@@ -570,63 +575,45 @@ sub atom_id {
}
# returns an XML::Atom::Entry object for a feed
+# opts: synlevel ("full"), apilinks (bool)
sub atom_entry {
- my ( $self, $opts ) = @_;
- $opts ||= {}; # synlevel ("full"), apilinks (bool)
+ my ( $self, %opts ) = @_;
- my $entry = XML::Atom::Entry->new();
- my $entry_xml = $entry->{doc};
+ my $atom_entry = XML::Atom::Entry->new( Version => 1 );
my $u = $self->{u};
- my $ditemid = $self->ditemid;
- my $jitemid = $self->{jitemid};
-
- # AtomAPI interface path
- my $api = $opts->{'apilinks'} ? "$LJ::SITEROOT/interface/atom" :
- "$LJ::SITEROOT/users/$u->{user}/data/atom";
-
- $entry->title($self->subject_text);
- $entry->id($self->atom_id);
-
- my $author = XML::Atom::Person->new();
- $author->name($self->poster->{name});
- $entry->author($author);
my $make_link = sub {
- my ( $rel, $type, $href, $title ) = @_;
- my $link = XML::Atom::Link->new;
- $link->rel($rel);
- $link->type($type);
- $link->href($href);
- $link->title($title) if $title;
+ my ( $rel, $href, $type, $title ) = @_;
+ my $link = XML::Atom::Link->new( Version => 1 );
+ $link->rel( $rel );
+ $link->href( $href );
+ $link->title( $title ) if $title;
+ $link->type( $type ) if $type;
return $link;
};
- $entry->add_link($make_link->( 'alternate', 'text/html', $self->url));
- $entry->add_link($make_link->(
- 'service.edit', 'application/x.atom+xml',
- "$api/edit/$jitemid", 'Edit this post'
- )
- ) if $opts->{'apilinks'};
+ $atom_entry->id( $self->atom_id );
+ $atom_entry->title( $self->subject_text );
- my $event_date = LJ::time_to_w3c($self->logtime_unix, "");
- my $modtime = LJ::time_to_w3c($self->modtime_unix, 'Z');
+ $atom_entry->published( LJ::time_to_w3c( $self->logtime_unix, "Z" ) );
+ $atom_entry->updated( LJ::time_to_w3c( $self->revtime_unix || $self->logtime_unix, 'Z' ) );
- $entry->published($event_date);
- $entry->issued ($event_date); # COMPAT
+ my $author = XML::Atom::Person->new( Version => 1 );
+ $author->name( $self->poster->name_orig );
+ $atom_entry->author($author);
- $entry->updated ($modtime);
- $entry->modified($modtime);
+ $atom_entry->add_link( $make_link->( "alternate", $self->url, "text/html" ) );
+ $atom_entry->add_link( $make_link->( "edit", $self->atom_url, "application/atom+xml", "Edit this post" ) )
+ if $opts{apilinks};
- # XML::Atom 0.9 doesn't support categories. Maybe later?
- foreach my $tag ($self->tags) {
- $tag = LJ::exml($tag);
- my $category = $entry_xml->createElement( 'category' );
- $category->setAttribute( 'term', $tag );
- $entry_xml->getDocumentElement->appendChild( $category );
+ foreach my $tag ( $self->tags ) {
+ my $category = XML::Atom::Category->new( Version => 1 );
+ $category->term( $tag );
+ $atom_entry->add_category( $category );
}
- my $syn_level = $opts->{synlevel} || $u->prop("opt_synlevel") || "full";
+ my $syn_level = $opts{synlevel} || $u->prop( "opt_synlevel" ) || "full";
# if syndicating the complete entry
# -print a content tag
@@ -638,21 +625,21 @@ sub atom_entry {
#
# a lack of a content element is allowed, as long
# as we maintain a proper 'alternate' link (above)
- if ($syn_level eq 'full') {
- # Do this manually for now, until XML::Atom supports new
- # content type classifications.
- my $content = $entry_xml->createElement( 'content' );
- $content->setAttribute( 'type', 'html' );
- $content->appendTextNode( $self->event_html );
- $entry_xml->getDocumentElement->appendChild( $content );
- } elsif ($syn_level eq 'summary') {
- my $summary = $entry_xml->createElement( 'summary' );
- $summary->setAttribute( 'type', 'html' );
- $summary->appendTextNode( $self->event_summary );
- $entry_xml->getDocumentElement->appendChild( $summary );
+ if ( $syn_level eq 'full' || $syn_level eq 'cut' ) {
+ $atom_entry->content( $self->event_html );
+ $atom_entry->content->type( "html" );
+ } elsif ( $syn_level eq 'summary' ) {
+ $atom_entry->summary( $self->event_summary );
+ $atom_entry->summary->type( "html" );
}
- return $entry;
+ return $atom_entry;
+}
+
+sub atom_url {
+ my $self = $_[0];
+ return "" unless $self->journal;
+ return $self->journal->atom_base . "/entries/" . $self->jitemid;
}
# returns the entry as an XML Atom string, without the XML prologue
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/LJ/ModuleCheck.pm
--- a/cgi-bin/LJ/ModuleCheck.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/LJ/ModuleCheck.pm Mon Feb 07 12:52:01 2011 +0800
@@ -31,7 +31,8 @@ sub have_xmlatom {
use XML::Atom::Feed;
use XML::Atom::Entry;
use XML::Atom::Link;
- XML::Atom->VERSION < 0.09 ? 0 : 1;
+ use XML::Atom::Category;
+ XML::Atom->VERSION < 0.21 ? 0 : 1;
};
}
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/LJ/S2.pm
--- a/cgi-bin/LJ/S2.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/LJ/S2.pm Mon Feb 07 12:52:01 2011 +0800
@@ -2164,8 +2164,7 @@ sub Page
}
$p->{'head_content'} .= qq{<link rel="alternate" type="application/rss+xml" title="RSS: all entries" href="$p->{'base_url'}/data/rss" />\n};
$p->{'head_content'} .= qq{<link rel="alternate" type="application/atom+xml" title="Atom: all entries" href="$p->{'base_url'}/data/atom" />\n};
- $p->{'head_content'} .= qq{<link rel="service.feed" type="application/atom+xml" title="AtomAPI-enabled feed" href="$LJ::SITEROOT/interface/atomapi/$u->{'user'}/feed" />\n};
- $p->{'head_content'} .= qq{<link rel="service.post" type="application/atom+xml" title="Create a new post" href="$LJ::SITEROOT/interface/atomapi/$u->{'user'}/post" />\n};
+ $p->{'head_content'} .= qq{<link rel="service" type="application/atomsvc+xml" title="AtomAPI service document" href="} . $u->atom_service_document . qq{" />\n};
}
# OpenID information if the caller asked us to include it here.
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/LJ/User.pm
--- a/cgi-bin/LJ/User.pm Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/LJ/User.pm Mon Feb 07 12:52:01 2011 +0800
@@ -5976,6 +5976,15 @@ sub atomid {
return "tag:$LJ::DOMAIN,$journalcreated:$u->{userid}";
}
+sub atom_service_document {
+ return "$LJ::SITEROOT/interface/atom";
+}
+
+sub atom_base {
+ my ( $u ) = @_;
+ return $u->journal_base . "/interface/atom";
+}
+
# retrieve hash of basic syndicated info
sub get_syndicated {
my $u = shift;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom.pm
--- a/cgi-bin/XML/Atom.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,94 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Atom.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom;
-use strict;
-
-BEGIN {
- @XML::Atom::EXPORT = qw( LIBXML );
- if (eval { require XML::LibXML }) {
- *{XML::Atom::LIBXML} = sub() {1};
- } else {
- require XML::XPath;
- *{XML::Atom::LIBXML} = sub() {0};
- }
- local $^W = 0;
- *XML::XPath::Function::namespace_uri = sub {
- my $self = shift;
- my($node, @params) = @_;
- my $ns = $node->getNamespace($node->getPrefix);
- if (!$ns) {
- $ns = ($node->getNamespaces)[0];
- }
- XML::XPath::Literal->new($ns ? $ns->getExpanded : '');
- };
-}
-
-use base qw( XML::Atom::ErrorHandler Exporter );
-
-# This is actually version 0.13_01, but I'm renaming it to 0.13
-# so our Atom version checks don't complain about non-numeric comparisons.
-our $VERSION = '0.13';
-
-package XML::Atom::Namespace;
-use strict;
-
-sub new {
- my $class = shift;
- my($prefix, $uri) = @_;
- bless { prefix => $prefix, uri => $uri }, $class;
-}
-
-sub DESTROY { }
-
-our $AUTOLOAD;
-sub AUTOLOAD {
- (my $var = $AUTOLOAD) =~ s!.+::!!;
- no strict 'refs';
- ($_[0], $var);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-XML::Atom - Atom feed and API implementation
-
-=head1 SYNOPSIS
-
- use XML::Atom;
-
-=head1 DESCRIPTION
-
-Atom is a syndication, API, and archiving format for weblogs and other
-data. I<XML::Atom> implements the feed format as well as a client for the
-API.
-
-=head1 LICENSE
-
-I<XML::Atom> is free software; you may redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=head1 AUTHOR & COPYRIGHT
-
-Except where otherwise noted, I<XML::Atom> is Copyright 2003-2005
-Benjamin Trott, cpan@stupidfool.org. All rights reserved.
-
-=head1 CO-MAINTAINER
-
-Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
-
-=cut
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Client.pm
--- a/cgi-bin/XML/Atom/Client.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,361 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Client.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-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('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);
- $client->{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 {
- if ($] >= 5.008) {
- require Encode;
- Encode::_utf8_off($_[0]);
- }
-}
-
-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
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Content.pm
--- a/cgi-bin/XML/Atom/Content.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,185 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Content.pm 5765 2005-10-19 22:51:22Z mahlon $
-
-package XML::Atom::Content;
-use strict;
-use base qw( XML::Atom::ErrorHandler );
-
-use Encode;
-use XML::Atom;
-use XML::Atom::Util qw( set_ns remove_default_ns hack_unicode_entity );
-use MIME::Base64 qw( encode_base64 decode_base64 );
-
-sub new {
- my $class = shift;
- my $content = bless {}, $class;
- $content->init(@_) or return $class->error($content->errstr);
- $content;
-}
-
-sub init {
- my $content = shift;
- my %param = @_ == 1 ? (Body => $_[0]) : @_;
- $content->set_ns(\%param);
- my $elem;
- unless ($elem = $param{Elem}) {
- if (LIBXML) {
- my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
- $elem = $doc->createElementNS($content->ns, 'content');
- $doc->setDocumentElement($elem);
- } else {
- $elem = XML::XPath::Node::Element->new('content');
- }
- }
- $content->{elem} = $elem;
- if ($param{Body}) {
- $content->body($param{Body});
- }
- if ($param{Type}) {
- $content->type($param{Type});
- }
- $content;
-}
-
-sub ns { $_[0]->{ns} }
-sub elem { $_[0]->{elem} }
-
-sub type {
- my $content = shift;
- if (@_) {
- $content->elem->setAttribute('type', shift);
- }
- $content->elem->getAttribute('type');
-}
-
-sub mode {
- my $content = shift;
- $content->elem->getAttribute('mode');
-}
-
-sub lang { $_[0]->elem->getAttribute('lang') }
-sub base { $_[0]->elem->getAttribute('base') }
-
-sub body {
- my $content = shift;
- my $elem = $content->elem;
- if (@_) {
- my $data = shift;
- if (LIBXML) {
- $elem->removeChildNodes;
- } else {
- $elem->removeChild($_) for $elem->getChildNodes;
- }
- if (!_is_printable($data)) {
- my $raw = Encode::encode("utf-8", $data);
- if (LIBXML) {
- $elem->appendChild(XML::LibXML::Text->new(encode_base64($raw, '')));
- } else {
- $elem->appendChild(XML::XPath::Node::Text->new(encode_base64($raw, '')));
- }
- $elem->setAttribute('mode', 'base64');
- } else {
- my $copy = '<div xmlns="http://www.w3.org/1999/xhtml">' .
- $data .
- '</div>';
- my $node;
- eval {
- if (LIBXML) {
- my $parser = XML::LibXML->new;
- my $tree = $parser->parse_string($copy);
- $node = $tree->getDocumentElement;
- } else {
- my $xp = XML::XPath->new(xml => $copy);
- $node = (($xp->find('/')->get_nodelist)[0]->getChildNodes)[0]
- if $xp;
- }
- };
- if (!$@ && $node) {
- $elem->appendChild($node);
- $elem->setAttribute('mode', 'xml');
- } else {
- if (LIBXML) {
- $elem->appendChild(XML::LibXML::Text->new($data));
- } else {
- $elem->appendChild(XML::XPath::Node::Text->new($data));
- }
- $elem->setAttribute('mode', 'escaped');
- }
- }
- } else {
- unless (exists $content->{__body}) {
- my $mode = $elem->getAttribute('mode') || 'xml';
- if ($mode eq 'xml') {
- my @children = grep ref($_) =~ /Element/,
- LIBXML ? $elem->childNodes : $elem->getChildNodes;
- if (@children) {
- if (@children == 1 && $children[0]->getLocalName eq 'div') {
- @children =
- LIBXML ? $children[0]->childNodes :
- $children[0]->getChildNodes
- }
- $content->{__body} = '';
- for my $n (@children) {
- remove_default_ns($n) if LIBXML;
- $content->{__body} .= $n->toString(LIBXML ? 1 : 0);
- }
- } else {
- $content->{__body} = LIBXML ? $elem->textContent : $elem->string_value;
- }
- if ($] >= 5.008) {
- $content->{__body} = hack_unicode_entity($content->{__body});
- }
- } elsif ($mode eq 'base64') {
- my $raw = decode_base64(LIBXML ? $elem->textContent : $elem->string_value);
-
- # commented out by Mahlon. This was breaking LifeBlog image posting.
- # Raw data wouldn't be character encoded, anyway?
- # $content->{__body} = Encode::decode("utf-8", $raw);
- $content->{__body} = $raw;
-
- } elsif ($mode eq 'escaped') {
- $content->{__body} = LIBXML ? $elem->textContent : $elem->string_value;
- } else {
- $content->{__body} = undef;
- }
- }
- }
- $content->{__body};
-}
-
-sub _is_printable {
- my $data = shift;
-
- # try decoding this $data with UTF-8
- my $decoded =
- ( Encode::is_utf8($data)
- ? $data
- : eval { Encode::decode("utf-8", $data, Encode::FB_CROAK) } );
-
- return ! $@ && $decoded =~ /^\p{IsPrint}*$/;
-}
-
-sub as_xml {
- my $content = shift;
- if (LIBXML) {
- my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
- $doc->setDocumentElement($content->elem);
- return $doc->toString(1);
- } else {
- return $content->elem->toString;
- }
-}
-
-1;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Entry.pm
--- a/cgi-bin/XML/Atom/Entry.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,142 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Entry.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom::Entry;
-use strict;
-
-use XML::Atom;
-use base qw( XML::Atom::Thing );
-use MIME::Base64 qw( encode_base64 decode_base64 );
-use XML::Atom::Person;
-use XML::Atom::Content;
-use XML::Atom::Util qw( first );
-
-sub element_name { 'entry' }
-
-sub content {
- my $entry = shift;
- my @arg = @_;
- if (@arg && ref($arg[0]) ne 'XML::Atom::Content') {
- $arg[0] = XML::Atom::Content->new($arg[0]);
- }
- $entry->_element('XML::Atom::Content', 'content', @arg);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-XML::Atom::Entry - Atom entry
-
-=head1 SYNOPSIS
-
- use XML::Atom::Entry;
- my $entry = XML::Atom::Entry->new;
- $entry->title('My Post');
- $entry->content('The content of my post.');
- my $xml = $entry->as_xml;
- my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/');
- $entry->set($dc, 'subject', 'Food & Drink');
-
-=head1 USAGE
-
-=head2 XML::Atom::Entry->new([ $stream ])
-
-Creates a new entry object, and if I<$stream> is supplied, fills it with the
-data specified by I<$stream>.
-
-Automatically handles autodiscovery if I<$stream> is a URI (see below).
-
-Returns the new I<XML::Atom::Entry> object. On failure, returns C<undef>.
-
-I<$stream> can be any one of the following:
-
-=over 4
-
-=item * Reference to a scalar
-
-This is treated as the XML body of the entry.
-
-=item * Scalar
-
-This is treated as the name of a file containing the entry XML.
-
-=item * Filehandle
-
-This is treated as an open filehandle from which the entry XML can be read.
-
-=back
-
-=head2 $entry->content([ $content ])
-
-Returns the content of the entry. If I<$content> is given, sets the content
-of the entry. Automatically handles all necessary escaping.
-
-=head2 $entry->author([ $author ])
-
-Returns an I<XML::Atom::Person> object representing the author of the entry,
-or C<undef> if there is no author information present.
-
-If I<$author> is supplied, it should be an I<XML::Atom::Person> object
-representing the author. For example:
-
- my $author = XML::Atom::Person->new;
- $author->name('Foo Bar');
- $author->email('foo@bar.com');
- $entry->author($author);
-
-=head2 $entry->link
-
-If called in scalar context, returns an I<XML::Atom::Link> object
-corresponding to the first I<E<lt>linkE<gt>> tag found in the entry.
-
-If called in list context, returns a list of I<XML::Atom::Link> objects
-corresponding to all of the I<E<lt>linkE<gt>> tags found in the entry.
-
-=head2 $entry->add_link($link)
-
-Adds the link I<$link>, which must be an I<XML::Atom::Link> object, to
-the entry as a new I<E<lt>linkE<gt>> tag. For example:
-
- my $link = XML::Atom::Link->new;
- $link->type('text/html');
- $link->rel('alternate');
- $link->href('http://www.example.com/2003/12/post.html');
- $entry->add_link($link);
-
-=head2 $entry->get($ns, $element)
-
-Given an I<XML::Atom::Namespace> element I<$ns> and an element name
-I<$element>, retrieves the value for the element in that namespace.
-
-This is useful for retrieving the value of elements not in the main Atom
-namespace, like categories. For example:
-
- my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/');
- my $subj = $entry->get($dc, 'subject');
-
-=head2 $entry->getlist($ns, $element)
-
-Just like I<$entry-E<gt>get>, but if there are multiple instances of the
-element I<$element> in the namespace I<$ns>, returns all of them. I<get>
-will return only the first.
-
-=head1 AUTHOR & COPYRIGHT
-
-Please see the I<XML::Atom> manpage for author, copyright, and license
-information.
-
-=cut
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/ErrorHandler.pm
--- a/cgi-bin/XML/Atom/ErrorHandler.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,34 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: ErrorHandler.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom::ErrorHandler;
-use strict;
-
-our $ERROR;
-
-sub new { bless {}, shift }
-sub error {
- my $msg = $_[1] || '';
- $msg .= "\n" unless $msg =~ /\n$/;
- if (ref($_[0])) {
- $_[0]->{_errstr} = $msg;
- } else {
- $ERROR = $msg;
- }
- return;
- }
-sub errstr { ref($_[0]) ? $_[0]->{_errstr} : $ERROR }
-
-1;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Feed.pm
--- a/cgi-bin/XML/Atom/Feed.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,267 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Feed.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom::Feed;
-use strict;
-
-use XML::Atom;
-use base qw( XML::Atom::Thing );
-use XML::Atom::Entry;
-BEGIN {
- if (LIBXML) {
- *entries = \&entries_libxml;
- *add_entry = \&add_entry_libxml;
- } else {
- *entries = \&entries_xpath;
- *add_entry = \&add_entry_xpath;
- }
-}
-
-sub init {
- my $atom = shift;
- my %param = @_ == 1 ? (Stream => $_[0]) : @_;
- if (UNIVERSAL::isa($param{Stream}, 'URI')) {
- my @feeds = __PACKAGE__->find_feeds($param{Stream});
- return $atom->error("Can't find Atom file") unless @feeds;
- my $ua = LWP::UserAgent->new;
- my $req = HTTP::Request->new(GET => $feeds[0]);
- my $res = $ua->request($req);
- if ($res->is_success) {
- $param{Stream} = \$res->content;
- }
- }
- $atom->SUPER::init(%param);
-}
-
-sub find_feeds {
- my $class = shift;
- my($uri) = @_;
- my $ua = LWP::UserAgent->new;
- my $req = HTTP::Request->new(GET => $uri);
- my $res = $ua->request($req);
- return unless $res->is_success;
- my @feeds;
- if ($res->content_type eq 'text/html' || $res->content_type eq 'application/xhtml+xml') {
- my $base_uri = $uri;
- my $find_links = sub {
- my($tag, $attr) = @_;
- if ($tag eq 'link') {
- return unless $attr->{rel};
- my %rel = map { $_ => 1 } split /\s+/, lc($attr->{rel});
- (my $type = lc $attr->{type}) =~ s/^\s*//;
- $type =~ s/\s*$//;
- push @feeds, URI->new_abs($attr->{href}, $base_uri)->as_string
- if $rel{alternate} &&
- $type eq 'application/atom+xml';
- } elsif ($tag eq 'base') {
- $base_uri = $attr->{href};
- }
- };
- require HTML::Parser;
- my $p = HTML::Parser->new(api_version => 3,
- start_h => [ $find_links, "tagname, attr" ]);
- $p->parse($res->content);
- } else {
- @feeds = ($uri);
- }
- @feeds;
-}
-
-sub element_name { 'feed' }
-
-sub language {
- my $feed = shift;
- if (LIBXML) {
- my $elem = $feed->{doc}->getDocumentElement;
- if (@_) {
- $elem->setAttributeNS('http://www.w3.org/XML/1998/namespace',
- 'lang', $_[0]);
- }
- return $elem->getAttribute('lang');
- } else {
- if (@_) {
- $feed->{doc}->setAttribute('xml:lang', $_[0]);
- }
- return $feed->{doc}->getAttribute('xml:lang');
- }
-}
-
-sub version {
- my $feed = shift;
- my $elem = LIBXML ? $feed->{doc}->getDocumentElement : $feed->{doc};
- if (@_) {
- $elem->setAttribute('version', $_[0]);
- }
- $elem->getAttribute('version') || $feed->SUPER::version(@_);
-}
-
-sub entries_libxml {
- my $feed = shift;
- my @res = $feed->{doc}->getElementsByTagNameNS($feed->ns, 'entry') or return;
- my @entries;
- for my $res (@res) {
- my $entry = XML::Atom::Entry->new(Elem => $res->cloneNode(1));
- push @entries, $entry;
- }
- @entries;
-}
-
-sub entries_xpath {
- my $feed = shift;
- my $set = $feed->{doc}->find("descendant-or-self::*[local-name()='entry' and namespace-uri()='" . $feed->ns . "']");
- my @entries;
- for my $elem ($set->get_nodelist) {
- ## Delete the link to the parent (feed) element, and append
- ## the default Atom namespace.
- $elem->del_parent_link;
- my $ns = XML::XPath::Node::Namespace->new('#default' => $feed->ns);
- $elem->appendNamespace($ns);
- my $entry = XML::Atom::Entry->new(Elem => $elem);
- push @entries, $entry;
- }
- @entries;
-}
-
-sub add_entry_libxml {
- my $feed = shift;
- my($entry) = @_;
- $feed->{doc}->getDocumentElement->appendChild($entry->{doc}->getDocumentElement);
-}
-
-sub add_entry_xpath {
- my $feed = shift;
- my($entry) = @_;
- $feed->{doc}->appendChild($entry->{doc});
-}
-
-1;
-__END__
-
-=head1 NAME
-
-XML::Atom::Feed - Atom feed
-
-=head1 SYNOPSIS
-
- use XML::Atom::Feed;
- use XML::Atom::Entry;
- my $feed = XML::Atom::Feed->new;
- $feed->title('My Weblog');
- my $entry = XML::Atom::Entry->new;
- $entry->title('First Post');
- $entry->content('Post Body');
- $feed->add_entry($entry);
- my @entries = $feed->entries;
- my $xml = $feed->as_xml;
-
- ## Get a list of the <link rel="..." /> tags in the feed.
- my $links = $feed->link;
-
- ## Find all of the Atom feeds on a given page, using auto-discovery.
- my @uris = XML::Atom::Feed->find_feeds('http://www.example.com/');
-
- ## Use auto-discovery to load the first Atom feed on a given page.
- my $feed = XML::Atom::Feed->new(URI->new('http://www.example.com/'));
-
-=head1 USAGE
-
-=head2 XML::Atom::Feed->new([ $stream ])
-
-Creates a new feed object, and if I<$stream> is supplied, fills it with the
-data specified by I<$stream>.
-
-Automatically handles autodiscovery if I<$stream> is a URI (see below).
-
-Returns the new I<XML::Atom::Feed> object. On failure, returns C<undef>.
-
-I<$stream> can be any one of the following:
-
-=over 4
-
-=item * Reference to a scalar
-
-This is treated as the XML body of the feed.
-
-=item * Scalar
-
-This is treated as the name of a file containing the feed XML.
-
-=item * Filehandle
-
-This is treated as an open filehandle from which the feed XML can be read.
-
-=item * URI object
-
-This is treated as a URI, and the feed XML will be retrieved from the URI.
-
-If the content type returned from fetching the content at URI is
-I<text/html>, this method will automatically try to perform auto-discovery
-by looking for a I<E<lt>linkE<gt>> tag describing the feed URL. If such
-a URL is found, the feed XML will be automatically retrieved.
-
-If the URI is already of a feed, no auto-discovery is necessary, and the
-feed XML will be retrieved and parsed as normal.
-
-=back
-
-=head2 XML::Atom::Feed->find_feeds($uri)
-
-Given a URI I<$uri>, use auto-discovery to find all of the Atom feeds linked
-from that page (using I<E<lt>linkE<gt>> tags).
-
-Returns a list of feed URIs.
-
-=head2 $feed->link
-
-If called in scalar context, returns an I<XML::Atom::Link> object
-corresponding to the first I<E<lt>linkE<gt>> tag found in the feed.
-
-If called in list context, returns a list of I<XML::Atom::Link> objects
-corresponding to all of the I<E<lt>linkE<gt>> tags found in the feed.
-
-=head2 $feed->add_link($link)
-
-Adds the link I<$link>, which must be an I<XML::Atom::Link> object, to
-the feed as a new I<E<lt>linkE<gt>> tag. For example:
-
- my $link = XML::Atom::Link->new;
- $link->type('text/html');
- $link->rel('alternate');
- $link->href('http://www.example.com/');
- $feed->add_link($link);
-
-=head2 $feed->language
-
-Returns the language of the feed, from I<xml:lang>.
-
-=head2 $feed->author([ $author ])
-
-Returns an I<XML::Atom::Person> object representing the author of the entry,
-or C<undef> if there is no author information present.
-
-If I<$author> is supplied, it should be an I<XML::Atom::Person> object
-representing the author. For example:
-
- my $author = XML::Atom::Person->new;
- $author->name('Foo Bar');
- $author->email('foo@bar.com');
- $feed->author($author);
-
-=head1 AUTHOR & COPYRIGHT
-
-Please see the I<XML::Atom> manpage for author, copyright, and license
-information.
-
-=cut
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Link.pm
--- a/cgi-bin/XML/Atom/Link.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,106 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Link.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom::Link;
-use strict;
-
-use XML::Atom;
-use XML::Atom::Util qw( set_ns );
-use base qw( XML::Atom::ErrorHandler );
-
-sub new {
- my $class = shift;
- my $link = bless {}, $class;
- $link->init(@_) or return $class->error($link->errstr);
- $link;
-}
-
-sub init {
- my $link = shift;
- my %param = @_ == 1 ? (Body => $_[0]) : @_;
- $link->set_ns(\%param);
- my $elem;
- unless ($elem = $param{Elem}) {
- if (LIBXML) {
- my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
- $elem = $doc->createElementNS($link->ns, 'link');
- $doc->setDocumentElement($elem);
- } else {
- $elem = XML::XPath::Node::Element->new('link');
- my $ns = XML::XPath::Node::Namespace->new('#default' => $link->ns);
- $elem->appendNamespace($ns);
- }
- }
- $link->{elem} = $elem;
- $link;
-}
-
-sub ns { $_[0]->{ns} }
-sub elem { $_[0]->{elem} }
-
-sub get {
- my $link = shift;
- my($attr) = @_;
- my $val = $link->elem->getAttribute($attr);
- if ($] >= 5.008) {
- require Encode;
- Encode::_utf8_off($val);
- }
- $val;
-}
-
-sub set {
- my $link = shift;
- if (@_ == 2) {
- my($attr, $val) = @_;
- $link->elem->setAttribute($attr, $val);
- } elsif (@_ == 3) {
- my($ns, $attr, $val) = @_;
- my $attribute = "$ns->{prefix}:$attr";
- if (LIBXML) {
- $link->elem->setAttributeNS($ns->{uri}, $attribute, $val);
- } else {
- my $ns = XML::XPath::Node::Namespace->new($ns->{prefix} => $ns->{uri});
- $link->elem->appendNamespace($ns);
- $link->elem->setAttribute($attribute => $val);
- }
- }
-}
-
-sub as_xml {
- my $link = shift;
- if (LIBXML) {
- my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
- $doc->setDocumentElement($link->elem);
- return $doc->toString(1);
- } else {
- return '<?xml version="1.0" encoding="utf-8"?>' . "\n" .
- $link->elem->toString;
- }
-}
-
-sub DESTROY { }
-
-our $AUTOLOAD;
-sub AUTOLOAD {
- (my $var = $AUTOLOAD) =~ s!.+::!!;
- no strict 'refs';
- *$AUTOLOAD = sub {
- @_ > 1 ? $_[0]->set($var, @_[1..$#_]) : $_[0]->get($var)
- };
- goto &$AUTOLOAD;
-}
-
-1;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Person.pm
--- a/cgi-bin/XML/Atom/Person.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,133 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Person.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom::Person;
-use strict;
-
-use XML::Atom;
-use base qw( XML::Atom::ErrorHandler );
-use XML::Atom::Util qw( set_ns first );
-
-sub new {
- my $class = shift;
- my $person = bless {}, $class;
- $person->init(@_) or return $class->error($person->errstr);
- $person;
-}
-
-sub init {
- my $person = shift;
- my %param = @_;
- $person->set_ns(\%param);
- my $elem;
- unless ($elem = $param{Elem}) {
- if (LIBXML) {
- my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
- $elem = $doc->createElementNS($person->ns, 'author'); ## xxx
- $doc->setDocumentElement($elem);
- } else {
- $elem = XML::XPath::Node::Element->new('author'); ## xxx
- my $ns = XML::XPath::Node::Namespace->new('#default' => $person->ns);
- $elem->appendNamespace($ns);
- }
- }
- $person->{elem} = $elem;
- $person;
-}
-
-sub ns { $_[0]->{ns} }
-sub elem { $_[0]->{elem} }
-
-sub get {
- my $person = shift;
- my($name) = @_;
- my $node = first($person->elem, $person->ns, $name) or return;
- my $val = LIBXML ? $node->textContent : $node->string_value;
- if ($] >= 5.008) {
- require Encode;
- Encode::_utf8_off($val);
- }
- $val;
-}
-
-sub set {
- my $person = shift;
- my($name, $val) = @_;
- my $elem;
- unless ($elem = first($person->elem, $person->ns, $name)) {
- if (LIBXML) {
- $elem = XML::LibXML::Element->new($name);
- $elem->setNamespace($person->ns);
- } else {
- $elem = XML::XPath::Node::Element->new($name);
- my $ns = XML::XPath::Node::Namespace->new('#default' => $person->ns);
- $elem->appendNamespace($ns);
- }
- $person->elem->appendChild($elem);
- }
- if (LIBXML) {
- $elem->removeChildNodes;
- $elem->appendChild(XML::LibXML::Text->new($val));
- } else {
- $elem->removeChild($_) for $elem->getChildNodes;
- $elem->appendChild(XML::XPath::Node::Text->new($val));
- }
- $val;
-}
-
-sub as_xml {
- my $person = shift;
- if (LIBXML) {
- my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
- $doc->setDocumentElement($person->elem);
- return $doc->toString(1);
- } else {
- return '<?xml version="1.0" encoding="utf-8"?>' . "\n" .
- $person->elem->toString;
- }
-}
-
-sub DESTROY { }
-
-our $AUTOLOAD;
-sub AUTOLOAD {
- (my $var = $AUTOLOAD) =~ s!.+::!!;
- no strict 'refs';
- *$AUTOLOAD = sub {
- @_ > 1 ? $_[0]->set($var, @_[1..$#_]) : $_[0]->get($var)
- };
- goto &$AUTOLOAD;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-XML::Atom::Person - Author or contributor object
-
-=head1 SYNOPSIS
-
- my $author = XML::Atom::Person->new;
- $author->email('foo@example.com');
- $author->name('Foo Bar');
- $entry->author($author);
-
-=head1 DESCRIPTION
-
-I<XML::Atom::Person> represents an author or contributor element in an
-Atom feed or entry.
-
-=cut
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Server.pm
--- a/cgi-bin/XML/Atom/Server.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,551 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Server.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom::Server;
-use strict;
-
-use XML::Atom;
-use base qw( XML::Atom::ErrorHandler );
-use MIME::Base64 qw( encode_base64 decode_base64 );
-use Digest::SHA1 qw( sha1 );
-use XML::Atom::Util qw( first encode_xml textValue );
-use XML::Atom::Entry;
-
-use constant NS_SOAP => 'http://schemas.xmlsoap.org/soap/envelope/';
-use constant NS_WSSE => 'http://schemas.xmlsoap.org/ws/2002/07/secext';
-use constant NS_WSU => 'http://schemas.xmlsoap.org/ws/2002/07/utility';
-
-sub handler ($$) {
- my $class = shift;
- my($r) = @_;
- require Apache::Constants;
- if (lc($r->dir_config('Filter') || '') eq 'on') {
- $r = $r->filter_register;
- }
- my $server = $class->new or die $class->errstr;
- $server->{apache} = $r;
- $server->run;
- return Apache::Constants::OK();
-}
-
-sub new {
- my $class = shift;
- my $server = bless { }, $class;
- $server->init(@_) or return $class->error($server->errstr);
- $server;
-}
-
-sub init {
- my $server = shift;
- $server->{param} = {};
- unless ($ENV{MOD_PERL}) {
- require CGI;
- $server->{cgi} = CGI->new();
- }
- $server;
-}
-
-sub run {
- my $server = shift;
- (my $pi = $server->path_info) =~ s!^/!!;
- my @args = split /\//, $pi;
- for my $arg (@args) {
- my($k, $v) = split /=/, $arg, 2;
- $server->request_param($k, $v);
- }
- if (my $action = $server->request_header('SOAPAction')) {
- $server->{is_soap} = 1;
- $action =~ s/"//g;
- my($method) = $action =~ m!/([^/]+)$!;
- $server->request_method($method);
- }
- my $out;
- eval {
- defined($out = $server->handle_request) or die $server->errstr;
- if (defined $out && $server->{is_soap}) {
- $out =~ s!^(<\?xml.*?\?>)!!;
- $out = <<SOAP;
-$1
-<soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
- <soap:Body>$out</soap:Body>
-</soap:Envelope>
-SOAP
- }
- };
- if ($@) {
- $out = $server->show_error($@);
- }
- $server->send_http_header;
- $server->print($out);
- 1;
-}
-
-sub handle_request;
-sub password_for_user;
-
-sub uri {
- my $server = shift;
- $ENV{MOD_PERL} ? $server->{apache}->uri : $server->{cgi}->url;
-}
-
-sub path_info {
- my $server = shift;
- return $server->{__path_info} if exists $server->{__path_info};
- my $path_info;
- if ($ENV{MOD_PERL}) {
- ## mod_perl often leaves part of the script name (Location)
- ## in the path info, for some reason. This should remove it.
- $path_info = $server->{apache}->path_info;
- if ($path_info) {
- my($script_last) = $server->{apache}->location =~ m!/([^/]+)$!;
- $path_info =~ s!^/$script_last!!;
- }
- } else {
- $path_info = $server->{cgi}->path_info;
- }
- $server->{__path_info} = $path_info;
-}
-
-sub request_header {
- my $server = shift;
- my($key) = @_;
- if ($ENV{MOD_PERL}) {
- return $server->{apache}->header_in($key);
- } else {
- ($key = uc($key)) =~ tr/-/_/;
- return $ENV{'HTTP_' . $key};
- }
-}
-
-sub request_method {
- my $server = shift;
- if (@_) {
- $server->{request_method} = shift;
- } elsif (!exists $server->{request_method}) {
- $server->{request_method} =
- $ENV{MOD_PERL} ? $server->{apache}->method : $ENV{REQUEST_METHOD};
- }
- $server->{request_method};
-}
-
-sub request_content {
- my $server = shift;
- unless (exists $server->{request_content}) {
- if ($ENV{MOD_PERL}) {
- ## Read from $server->{apache}
- my $r = $server->{apache};
- my $len = $server->request_header('Content-length');
- $r->read($server->{request_content}, $len);
- } else {
- ## Read from STDIN
- my $len = $ENV{CONTENT_LENGTH} || 0;
- read STDIN, $server->{request_content}, $len;
- }
- }
- $server->{request_content};
-}
-
-sub request_param {
- my $server = shift;
- my $k = shift;
- $server->{param}{$k} = shift if @_;
- $server->{param}{$k};
-}
-
-sub response_header {
- my $server = shift;
- my($key, $val) = @_;
- if ($ENV{MOD_PERL}) {
- $server->{apache}->header_out($key, $val);
- } else {
- unless ($key =~ /^-/) {
- ($key = lc($key)) =~ tr/-/_/;
- $key = '-' . $key;
- }
- $server->{cgi_headers}{$key} = $val;
- }
-}
-
-sub response_code {
- my $server = shift;
- $server->{response_code} = shift if @_;
- $server->{response_code};
-}
-
-sub response_content_type {
- my $server = shift;
- $server->{response_content_type} = shift if @_;
- $server->{response_content_type};
-}
-
-sub send_http_header {
- my $server = shift;
- my $type = $server->response_content_type || 'application/x.atom+xml';
- if ($ENV{MOD_PERL}) {
- $server->{apache}->status($server->response_code || 200);
- $server->{apache}->send_http_header($type);
- } else {
- $server->{cgi_headers}{-status} = $server->response_code || 200;
- $server->{cgi_headers}{-type} = $type;
- print $server->{cgi}->header(%{ $server->{cgi_headers} });
- }
-}
-
-sub print {
- my $server = shift;
- if ($ENV{MOD_PERL}) {
- $server->{apache}->print(@_);
- } else {
- CORE::print(@_);
- }
-}
-
-sub error {
- my $server = shift;
- my($code, $msg) = @_;
- $server->response_code($code) if ref($server);
- return $server->SUPER::error($msg);
-}
-
-sub show_error {
- my $server = shift;
- my($err) = @_;
- chomp($err = encode_xml($err));
- if ($server->{is_soap}) {
- my $code = $server->response_code;
- if ($code >= 400) {
- $server->response_code(500);
- }
- return <<FAULT;
-<soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
- <soap:Body>
- <soap:Fault>
- <faultcode>$code</faultcode>
- <faultstring>$err</faultstring>
- </soap:Fault>
- </soap:Body>
-</soap:Envelope>
-FAULT
- } else {
- return <<ERR;
-<?xml version="1.0" encoding="utf-8"?>
-<error>$err</error>
-ERR
- }
-}
-
-sub get_auth_info {
- my $server = shift;
- my %param;
- if ($server->{is_soap}) {
- my $xml = $server->xml_body;
- my $auth = first($xml, NS_WSSE, 'UsernameToken');
- $param{Username} = textValue($auth, NS_WSSE, 'Username');
- $param{PasswordDigest} = textValue($auth, NS_WSSE, 'Password');
- $param{Nonce} = textValue($auth, NS_WSSE, 'Nonce');
- $param{Created} = textValue($auth, NS_WSSE, 'Created');
- } else {
- my $req = $server->request_header('X-WSSE')
- or return $server->auth_failure(401, 'X-WSSE authentication required');
- $req =~ s/^(?:WSSE|UsernameToken) //;
- for my $i (split /,\s*/, $req) {
- my($k, $v) = split /=/, $i, 2;
- $v =~ s/^"//;
- $v =~ s/"$//;
- $param{$k} = $v;
- }
- }
- \%param;
-}
-
-sub authenticate {
- my $server = shift;
- my $auth = $server->get_auth_info or return;
- for my $f (qw( Username PasswordDigest Nonce Created )) {
- return $server->auth_failure(400, "X-WSSE requires $f")
- unless $auth->{$f};
- }
- my $password = $server->password_for_user($auth->{Username});
- defined($password) or return $server->auth_failure(403, 'Invalid login');
- my $expected = encode_base64(sha1(
- decode_base64($auth->{Nonce}) . $auth->{Created} . $password
- ), '');
- return $server->auth_failure(403, 'Invalid login')
- unless $expected eq $auth->{PasswordDigest};
- return 1;
-}
-
-sub auth_failure {
- my $server = shift;
- $server->response_header('WWW-Authenticate', 'WSSE profile="UsernameToken"');
- return $server->error(@_);
-}
-
-sub xml_body {
- my $server = shift;
- unless (exists $server->{xml_body}) {
- if (LIBXML) {
- my $parser = XML::LibXML->new;
- $server->{xml_body} =
- $parser->parse_string($server->request_content);
- } else {
- $server->{xml_body} =
- XML::XPath->new(xml => $server->request_content);
- }
- }
- $server->{xml_body};
-}
-
-sub atom_body {
- my $server = shift;
- my $atom;
- if ($server->{is_soap}) {
- my $xml = $server->xml_body;
- $atom = XML::Atom::Entry->new(Doc => first($xml, NS_SOAP, 'Body'))
- or return $server->error(500, XML::Atom::Entry->errstr);
- } else {
- $atom = XML::Atom::Entry->new(Stream => \$server->request_content)
- or return $server->error(500, XML::Atom::Entry->errstr);
- }
- $atom;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-XML::Atom::Server - A server for the Atom API
-
-=head1 SYNOPSIS
-
- package My::Server;
- use base qw( XML::Atom::Server );
- sub handle_request {
- my $server = shift;
- $server->authenticate or return;
- my $method = $server->request_method;
- if ($method eq 'POST') {
- return $server->new_post;
- }
- ...
- }
-
- my %Passwords;
- sub password_for_user {
- my $server = shift;
- my($username) = @_;
- $Passwords{$username};
- }
-
- sub new_post {
- my $server = shift;
- my $entry = $server->atom_body or return;
- ## $entry is an XML::Atom::Entry object.
- ## ... Save the new entry ...
- }
-
- package main;
- my $server = My::Server->new;
- $server->run;
-
-=head1 DESCRIPTION
-
-I<XML::Atom::Server> provides a base class for Atom API servers. It handles
-all core server processing, both the SOAP and REST formats of the protocol,
-and WSSE authentication. It can also run as either a mod_perl handler or as
-part of a CGI program.
-
-It does not provide functions specific to any particular implementation,
-such as posting an entry, retrieving a list of entries, deleting an entry, etc.
-Implementations should subclass I<XML::Atom::Server>, overriding the
-I<handle_request> method, and handle all functions such as this themselves.
-
-=head1 SUBCLASSING
-
-=head2 Request Handling
-
-Subclasses of I<XML::Atom::Server> must override the I<handle_request>
-method to perform all request processing. The implementation must set all
-response headers, including the response code and any relevant HTTP headers,
-and should return a scalar representing the response body to be sent back
-to the client.
-
-For example:
-
- sub handle_request {
- my $server = shift;
- my $method = $server->request_method;
- if ($method eq 'POST') {
- return $server->new_post;
- }
- ## ... handle GET, PUT, etc
- }
-
- sub new_post {
- my $server = shift;
- my $entry = $server->atom_body or return;
- my $id = save_this_entry($entry); ## Implementation-specific
- $server->response_header(Location => $server->uri . '/entry_id=' . $id);
- $server->response_code(201);
- $server->response_content_type('application/x.atom+xml');
- return serialize_entry($entry); ## Implementation-specific
- }
-
-=head2 Authentication
-
-Servers that require authentication for posting or retrieving entries or
-feeds should override the I<password_for_user> method. Given a username
-(from the WSSE header), I<password_for_user> should return that user's
-password in plaintext. This will then be combined with the nonce and the
-creation time to generate the digest, which will be compared with the
-digest sent in the WSSE header. If the supplied username doesn't exist in
-your user database or alike, just return C<undef>.
-
-For example:
-
- my %Passwords = ( foo => 'bar' ); ## The password for "foo" is "bar".
- sub password_for_user {
- my $server = shift;
- my($username) = @_;
- $Passwords{$username};
- }
-
-=head1 METHODS
-
-I<XML::Atom::Server> provides a variety of methods to be used by subclasses
-for retrieving headers, content, and other request information, and for
-setting the same on the response.
-
-=head2 Client Request Parameters
-
-=over 4
-
-=item * $server->uri
-
-Returns the URI of the Atom server implementation.
-
-=item * $server->request_method
-
-Returns the name of the request method sent to the server from the client
-(for example, C<GET>, C<POST>, etc). Note that if the client sent the
-request in a SOAP envelope, the method is obtained from the I<SOAPAction>
-HTTP header.
-
-=item * $server->request_header($header)
-
-Retrieves the value of the HTTP request header I<$header>.
-
-=item * $server->request_content
-
-Returns a scalar containing the contents of a POST or PUT request from the
-client.
-
-=item * $server->request_param($param)
-
-I<XML::Atom::Server> automatically parses the PATH_INFO sent in the request
-and breaks it up into key-value pairs. This can be used to pass parameters.
-For example, in the URI
-
- http://localhost/atom-server/entry_id=1
-
-the I<entry_id> parameter would be set to C<1>.
-
-I<request_param> returns the value of the value of the parameter I<$param>.
-
-=back
-
-=head2 Setting up the Response
-
-=over 4
-
-=item * $server->response_header($header, $value)
-
-Sets the value of the HTTP response header I<$header> to I<$value>.
-
-=item * $server->response_code([ $code ])
-
-Returns the current response code to be sent back to the client, and if
-I<$code> is given, sets the response code.
-
-=item * $server->response_content_type([ $type ])
-
-Returns the current I<Content-Type> header to be sent back to the client, and
-I<$type> is given, sets the value for that header.
-
-=back
-
-=head2 Processing the Request
-
-=over 4
-
-=item * $server->authenticate
-
-Attempts to authenticate the request based on the authentication
-information present in the request (currently just WSSE). This will call
-the I<password_for_user> method in the subclass to obtain the cleartext
-password for the username given in the request.
-
-=item * $server->atom_body
-
-Returns an I<XML::Atom::Entry> object containing the entry sent in the
-request.
-
-=back
-
-=head1 USAGE
-
-Once you have defined your server subclass, you can set it up either as a
-CGI program or as a mod_perl handler.
-
-A simple CGI program would look something like this:
-
- #!/usr/bin/perl -w
- use strict;
-
- use My::Server;
- my $server = My::Server->new;
- $server->run;
-
-A simple mod_perl handler configuration would look something like this:
-
- PerlModule My::Server
- <Location /atom-server>
- SetHandler perl-script
- PerlHandler My::Server
- </Location>
-
-=head1 ERROR HANDLING
-
-If you wish to return an error from I<handle_request>, you can use the
-built-in I<error> method:
-
- sub handle_request {
- my $server = shift;
- ...
- return $server->error(500, "Something went wrong");
- }
-
-This will be returned to the client with a response code of 500 and an
-error string of C<Something went wrong>. Errors are automatically
-serialized into SOAP faults if the incoming request is enclosed in a SOAP
-envelope.
-
-=head1 AUTHOR & COPYRIGHT
-
-Please see the I<XML::Atom> manpage for author, copyright, and license
-information.
-
-=cut
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Thing.pm
--- a/cgi-bin/XML/Atom/Thing.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,353 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Thing.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom::Thing;
-use strict;
-
-use XML::Atom;
-use base qw( XML::Atom::ErrorHandler );
-use XML::Atom::Util qw( set_ns first nodelist remove_default_ns );
-use XML::Atom::Link;
-use LWP::UserAgent;
-BEGIN {
- if (LIBXML) {
- *init = \&init_libxml;
- *set = \&set_libxml;
- *link = \&link_libxml;
- } else {
- *init = \&init_xpath;
- *set = \&set_xpath;
- *link = \&link_xpath;
- }
-}
-
-sub new {
- my $class = shift;
- my $atom = bless {}, $class;
- $atom->init(@_) or return $class->error($atom->errstr);
- $atom;
-}
-
-sub ns { $_[0]->{ns} }
-
-sub init_libxml {
- my $atom = shift;
- my %param = @_ == 1 ? (Stream => $_[0]) : @_;
- $atom->set_ns(\%param);
- if (%param) {
- if (my $stream = $param{Stream}) {
- my $parser = XML::LibXML->new;
- if (ref($stream) eq 'SCALAR') {
- $atom->{doc} = $parser->parse_string($$stream);
- } elsif (ref($stream)) {
- $atom->{doc} = $parser->parse_fh($stream);
- } else {
- $atom->{doc} = $parser->parse_file($stream);
- }
- } elsif (my $doc = $param{Doc}) {
- $atom->{doc} = $doc;
- } elsif (my $elem = $param{Elem}) {
- $atom->{doc} = XML::LibXML::Document->createDocument('1.0', 'utf-8');
- $atom->{doc}->setDocumentElement($elem);
- }
- if ($atom->{doc}) {
- $atom->fixup_ns;
- }
- } else {
- my $doc = $atom->{doc} = XML::LibXML::Document->createDocument('1.0', 'utf-8');
- my $root = $doc->createElementNS($atom->ns, $atom->element_name);
- $doc->setDocumentElement($root);
- }
- $atom;
-}
-
-sub fixup_ns {
- my $atom = shift;
- $atom->{ns} = $atom->{doc}->getDocumentElement->namespaceURI;
-}
-
-sub version {
- my $atom = shift;
- XML::Atom::Util::ns_to_version($atom->ns);
-}
-
-sub init_xpath {
- my $atom = shift;
- my %param = @_ == 1 ? (Stream => $_[0]) : @_;
- my $elem_name = $atom->element_name;
- if (%param) {
- if (my $stream = $param{Stream}) {
- my $xp;
- if (ref($stream) eq 'SCALAR') {
- $xp = XML::XPath->new(xml => $$stream);
- } elsif (ref($stream)) {
- $xp = XML::XPath->new(ioref => $stream);
- } else {
- $xp = XML::XPath->new(filename => $stream);
- }
- my $set = $xp->find('/' . $elem_name);
- unless ($set && $set->size) {
- $set = $xp->find('/');
- }
- $atom->{doc} = ($set->get_nodelist)[0];
- } elsif (my $doc = $param{Doc}) {
- $atom->{doc} = $doc;
- } elsif (my $elem = $param{Elem}) {
- my $xp = XML::XPath->new(context => $elem);
- my $set = $xp->find('/' . $elem_name);
- unless ($set && $set->size) {
- $set = $xp->find('/');
- }
- $atom->{doc} = ($set->get_nodelist)[0];
- }
- } else {
- my $xp = XML::XPath->new;
- $xp->set_namespace(atom => $atom->ns);
- $atom->{doc} = XML::XPath::Node::Element->new($atom->element_name);
- my $ns = XML::XPath::Node::Namespace->new('#default' => $atom->ns);
- $atom->{doc}->appendNamespace($ns);
- }
- $atom;
-}
-
-sub get {
- my $atom = shift;
- my($ns, $name) = @_;
- my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
- my $node = first($atom->{doc}, $ns_uri, $name);
- return unless $node;
- my $val = LIBXML ? $node->textContent : $node->string_value;
- if ($] >= 5.008) {
- require Encode;
- Encode::_utf8_off($val);
- }
- $val;
-}
-
-sub getlist {
- my $atom = shift;
- my($ns, $name) = @_;
- my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
- my @node = nodelist($atom->{doc}, $ns_uri, $name);
- map {
- my $val = LIBXML ? $_->textContent : $_->string_value;
- if ($] >= 5.008) {
- require Encode;
- Encode::_utf8_off($val);
- }
- $val;
- } @node;
-}
-
-sub add {
- my $atom = shift;
- my($ns, $name, $val, $attr) = @_;
- $atom->set($ns, $name, $val, $attr, 1);
-}
-
-sub set_libxml {
- my $atom = shift;
- my($ns, $name, $val, $attr, $add) = @_;
- my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
- my @elem = nodelist($atom->{doc}, $ns_uri, $name);
- if (!$add && @elem) {
- my $doc = $atom->{doc}->getDocumentElement;
- $doc->removeChild($_) for @elem;
- }
- my $elem = $atom->{doc}->createElementNS($ns_uri, $name);
- $atom->{doc}->getDocumentElement->appendChild($elem);
- if ($ns ne $atom->ns) {
- $atom->{doc}->getDocumentElement->setNamespace($ns->{uri}, $ns->{prefix}, 0);
- }
- if (ref($val) =~ /Element$/) {
- $elem->appendChild($val);
- } elsif (defined $val) {
- $elem->removeChildNodes;
- my $text = XML::LibXML::Text->new($val);
- $elem->appendChild($text);
- }
- if ($attr) {
- while (my($k, $v) = each %$attr) {
- $elem->setAttribute($k, $v);
- }
- }
- $val;
-}
-
-sub set_xpath {
- my $atom = shift;
- my($ns, $name, $val, $attr, $add) = @_;
- my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
- my @elem = nodelist($atom->{doc}, $ns_uri, $name);
- if (!$add && @elem) {
- $atom->{doc}->removeChild($_) for @elem;
- }
- my $elem = XML::XPath::Node::Element->new($name);
- if ($ns ne $atom->ns) {
- my $ns = XML::XPath::Node::Namespace->new($ns->{prefix} => $ns->{uri});
- $elem->appendNamespace($ns);
- }
- $atom->{doc}->appendChild($elem);
- if (ref($val) =~ /Element$/) {
- $elem->appendChild($val);
- } elsif (defined $val) {
- $elem->removeChild($_) for $elem->getChildNodes;
- my $text = XML::XPath::Node::Text->new($val);
- $elem->appendChild($text);
- }
- if ($attr) {
- while (my($k, $v) = each %$attr) {
- $elem->setAttribute($k, $v);
- }
- }
- $val;
-}
-
-sub add_link {
- my $thing = shift;
- my($link) = @_;
- my $elem;
- if (ref($link) eq 'XML::Atom::Link') {
- if (LIBXML) {
- $thing->{doc}->getDocumentElement->appendChild($link->elem);
- } else {
- $thing->{doc}->appendChild($link->elem);
- }
- } else {
- if (LIBXML) {
- $elem = $thing->{doc}->createElementNS($thing->ns, 'link');
- $thing->{doc}->getDocumentElement->appendChild($elem);
- } else {
- $elem = XML::XPath::Node::Element->new('link');
- my $ns = XML::XPath::Node::Namespace->new('#default' => $thing->ns);
- $elem->appendNamespace($ns);
- $thing->{doc}->appendChild($elem);
- }
- }
- if (ref($link) eq 'HASH') {
- for my $k (qw( type rel href title )) {
- my $v = $link->{$k} or next;
- $elem->setAttribute($k, $v);
- }
- }
-}
-
-sub link_libxml {
- my $thing = shift;
- if (wantarray) {
- my @res = $thing->{doc}->getDocumentElement->getChildrenByTagNameNS($thing->ns, 'link');
- my @links;
- for my $elem (@res) {
- push @links, XML::Atom::Link->new(Elem => $elem);
- }
- return @links;
- } else {
- my $elem = first($thing->{doc}, $thing->ns, 'link') or return;
- return XML::Atom::Link->new(Elem => $elem);
- }
-}
-
-sub link_xpath {
- my $thing = shift;
- if (wantarray) {
- my $set = $thing->{doc}->find("*[local-name()='link' and namespace-uri()='" . $thing->ns . "']");
- my @links;
- for my $elem ($set->get_nodelist) {
- push @links, XML::Atom::Link->new(Elem => $elem);
- }
- return @links;
- } else {
- my $elem = first($thing->{doc}, $thing->ns, 'link') or return;
- return XML::Atom::Link->new(Elem => $elem);
- }
-}
-
-sub author {
- my $thing = shift;
- $thing->_element('XML::Atom::Person', 'author', @_);
-}
-
-sub contributor {
- my $thing = shift;
- $thing->_element('XML::Atom::Person', 'contributor', @_);
-}
-
-sub as_xml {
- my $doc = $_[0]->{doc};
- remove_default_ns($doc->getDocumentElement);
- my $xml = $doc->toString(LIBXML ? 1 : 0);
- if ($] > 5.008) {
- require Encode;
- Encode::_utf8_off($xml);
- }
- $xml;
-}
-
-sub _element {
- my $thing = shift;
- my($class, $name) = (shift, shift);
- my $root = LIBXML ? $thing->{doc}->getDocumentElement : $thing->{doc};
- if (@_) {
- for my $node (nodelist($thing->{doc}, $thing->ns, $name)) {
- $root->removeChild($node);
- }
- my @obj = @_;
- for my $obj (@_) {
- my $elem = LIBXML ?
- $thing->{doc}->createElementNS($thing->ns, $name) :
- XML::XPath::Node::Element->new($name);
- $root->appendChild($elem);
- if (LIBXML) {
- for my $child ($obj->elem->childNodes) {
- $elem->appendChild($child->cloneNode(1));
- }
- for my $attr ($obj->elem->attributes) {
- next unless ref($attr) eq 'XML::LibXML::Attr';
- $elem->setAttribute($attr->getName, $attr->getValue);
- }
- } else {
- for my $child ($obj->elem->getChildNodes) {
- $elem->appendChild($child);
- }
- for my $attr ($obj->elem->getAttributes) {
- $elem->appendAttribute($attr);
- }
- }
- $obj->{elem} = $elem;
- }
- $thing->{'__' . $name} = \@obj;
- } else {
- unless (exists $thing->{'__' . $name}) {
- my @elem = nodelist($thing->{doc}, $thing->ns, $name);
- return unless @elem;
- $thing->{'__' . $name} = [ map $class->new(Elem => $_, Namespace => $thing->ns), @elem ];
- }
- }
- wantarray ? @{$thing->{'__' . $name}} : $thing->{'__' . $name}->[0];
-}
-
-sub DESTROY { }
-
-our $AUTOLOAD;
-sub AUTOLOAD {
- (my $var = $AUTOLOAD) =~ s!.+::!!;
- no strict 'refs';
- *$AUTOLOAD = sub {
- @_ > 1 ? $_[0]->set($_[0]->ns, $var, @_[1..$#_]) : $_[0]->get($_[0]->ns, $var)
- };
- goto &$AUTOLOAD;
-}
-
-1;
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/Atom/Util.pm
--- a/cgi-bin/XML/Atom/Util.pm Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,155 +0,0 @@
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-# $Id: Util.pm 5542 2005-09-22 20:28:00Z mahlon $
-
-package XML::Atom::Util;
-use strict;
-
-use XML::Atom;
-use Encode;
-use Exporter;
-
-our @EXPORT_OK = qw( set_ns hack_unicode_entity first nodelist textValue iso2dt encode_xml remove_default_ns );
-our @ISA = qw( Exporter );
-
-our %NS_MAP = (
- '0.3' => 'http://purl.org/atom/ns#',
- '1.0' => 'http://www.w3.org/2005/Atom',
-);
-
-our %NS_VERSION = reverse %NS_MAP;
-
-sub set_ns {
- my $thing = shift;
- my($param) = @_;
- if (my $ns = delete $param->{Namespace}) {
- $thing->{ns} = $ns;
- $thing->{version} = $NS_VERSION{$ns};
- } else {
- my $version = delete $param->{Version} || '0.3';
- $version = '1.0' if $version == 1;
- my $ns = $NS_MAP{$version} or $thing->error("Unknown version: $version");
- $thing->{ns} = $ns;
- $thing->{version} = $version;
- }
-}
-
-sub ns_to_version {
- my $ns = shift;
- $NS_VERSION{$ns};
-}
-
-sub hack_unicode_entity {
- my $data = shift;
- Encode::_utf8_on($data);
- $data =~ s/&#x(\w{4});/chr(hex($1))/eg;
- Encode::_utf8_off($data);
- $data;
-}
-
-sub first {
- my @nodes = nodelist(@_);
- return unless @nodes;
- return $nodes[0];
-}
-
-sub nodelist {
- if (LIBXML) {
- return $_[1] ? $_[0]->getElementsByTagNameNS($_[1], $_[2]) :
- $_[0]->getElementsByTagName($_[2]);
- } else {
- my $set = $_[1] ?
- $_[0]->find("descendant::*[local-name()='$_[2]' and namespace-uri()='$_[1]']") :
- $_[0]->find("descendant::$_[2]");
- return unless $set && $set->isa('XML::XPath::NodeSet');
- return $set->get_nodelist;
- }
-}
-
-sub textValue {
- my $node = first(@_) or return;
- LIBXML ? $node->textContent : $node->string_value;
-}
-
-sub iso2dt {
- my($iso) = @_;
- return unless $iso =~ /^(\d{4})(?:-?(\d{2})(?:-?(\d\d?)(?:T(\d{2}):(\d{2}):(\d{2})(?:\.\d+)?(?:Z|([+-]\d{2}:\d{2}))?)?)?)?/;
- my($y, $mo, $d, $h, $m, $s, $zone) =
- ($1, $2 || 1, $3 || 1, $4 || 0, $5 || 0, $6 || 0, $7);
- require DateTime;
- my $dt = DateTime->new(
- year => $y,
- month => $mo,
- day => $d,
- hour => $h,
- minute => $m,
- second => $s,
- time_zone => 'UTC',
- );
- if ($zone && $zone ne 'Z') {
- my $seconds = DateTime::TimeZone::offset_as_seconds($zone);
- $dt->subtract(seconds => $seconds);
- }
- $dt;
-}
-
-my %Map = ('&' => '&', '"' => '"', '<' => '<', '>' => '>',
- '\'' => ''');
-my $RE = join '|', keys %Map;
-
-sub encode_xml {
- my($str) = @_;
- $str =~ s!($RE)!$Map{$1}!g;
- $str;
-}
-
-sub remove_default_ns {
- my($node) = @_;
- $node->setNamespace('http://www.w3.org/1999/xhtml', '')
- if $node->nodeName =~ /^default:/ && ref($node) =~ /Element$/;
- for my $n ($node->childNodes) {
- remove_default_ns($n);
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-XML::Atom::Util - Utility functions
-
-=head1 SYNOPSIS
-
- use XML::Atom::Util qw( iso2dt );
- my $dt = iso2dt($entry->issued);
-
-=head1 USAGE
-
-=head2 iso2dt($iso)
-
-Transforms the ISO-8601 date I<$iso> into a I<DateTime> object and returns
-the I<DateTime> object.
-
-=head2 encode_xml($str)
-
-Encodes characters with special meaning in XML into entities and returns
-the encoded string.
-
-=head1 AUTHOR & COPYRIGHT
-
-Please see the I<XML::Atom> manpage for author, copyright, and license
-information.
-
-=cut
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/XML/README.txt
--- a/cgi-bin/XML/README.txt Fri Feb 04 14:53:34 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,4 +0,0 @@
-XML::Atom is not part of the LiveJournal codebase. It's being
-sucked in here to avoid library incompatibilities. Long story.
-
-
diff -r d9e05e2ed2ea -r c03034073124 cgi-bin/ljfeed.pl
--- a/cgi-bin/ljfeed.pl Fri Feb 04 14:53:34 2011 +0800
+++ b/cgi-bin/ljfeed.pl Mon Feb 07 12:52:01 2011 +0800
@@ -398,16 +398,6 @@ sub create_view_rss {
# single_entry - only output an <entry>..</entry> block. off by default
# apilinks - output AtomAPI links for posting a new entry or
# getting/editing/deleting an existing one. off by default
-# TODO: define and use an 'lj:' namespace
-#
-# TODO: Remove lines marked with 'COMPAT' - they are only present
-# to allow backwards compatibility with atom parsers that are pre 0.6-draft.
-# We create tags valid for 1.1-draft, but we want to be nice during
-# atom's (and atom users) continuing transition. 1.0 parsers, according
-# to spec, should NOT barf on unknown tags.
-# * Where we can't be compatible, we use Atom 1.0. *
-# http://www.ietf.org/internet-drafts/draft-ietf-atompub-format-11.txt
-#
sub create_view_atom
{
my ( $j, $u, $opts, $cleanitems, $entrylist ) = @_;
@@ -416,8 +406,7 @@ sub create_view_atom
$ns = "http://www.w3.org/2005/Atom";
# Strip namespace from child tags. Set default namespace, let
- # child tags inherit from it. So ghetto that we even have to do this
- # and LibXML can't on its own.
+ # child tags inherit from it. Do it manually; LibXML can't on its own.
my $normalize_ns = sub {
my $str = shift;
$str =~ s/(<\w+)\s+xmlns="\Q$ns\E"/$1/og;
@@ -427,7 +416,7 @@ sub create_view_atom
};
# AtomAPI interface path
- my $api = $opts->{'apilinks'} ? "$LJ::SITEROOT/interface/atom" :
+ my $api = $opts->{'apilinks'} ? $u->atom_service_document :
$u->journal_base . "/data/atom";
my $make_link = sub {
@@ -448,7 +437,7 @@ sub create_view_atom
# feed information
unless ($opts->{'single_entry'}) {
$feed = XML::Atom::Feed->new( Version => 1 );
- $xml = $feed->{doc};
+ $xml = $feed->elem->ownerDocument;
if ($u->should_block_robots) {
$xml->getDocumentElement->setAttribute( "xmlns:idx", "urn:atom-extension:indexing" );
@@ -470,7 +459,7 @@ sub create_view_atom
$make_link->(
'self',
$opts->{'apilinks'}
- ? ( 'application/x.atom+xml', "$api/feed" )
+ ? ( 'application/atom+xml', "$api/entries" )
: ( 'text/xml', $api )
)
);
@@ -481,25 +470,6 @@ sub create_view_atom
$ljinfo->setAttribute( 'type', LJ::exml($u->journaltype_readable) );
$xml->getDocumentElement->appendChild( $ljinfo );
- # link to the AtomAPI version of this feed
- $feed->add_link(
- $make_link->(
- 'service.feed',
- 'application/x.atom+xml',
- ( $opts->{'apilinks'} ? "$api/feed" : $api ),
- $j->{'title'}
- )
- );
-
- $feed->add_link(
- $make_link->(
- 'service.post',
- 'application/x.atom+xml',
- "$api/post",
- 'Create a new entry'
- )
- ) if $opts->{'apilinks'};
-
if ( LJ::is_enabled( 'hubbub' ) ) {
foreach my $hub (@LJ::HUBBUB_HUBS) {
$feed->add_link($make_link->('hub', undef, $hub));
@@ -509,6 +479,7 @@ sub create_view_atom
my $posteru = LJ::load_userids( map { $_->{posterid} } @$cleanitems);
# output individual item blocks
+ # FIXME: use LJ::Entry->atom_entry?
foreach my $it (@$cleanitems)
{
my $itemid = $it->{itemid};
@@ -516,7 +487,7 @@ sub create_view_atom
my $poster = $posteru->{$it->{posterid}};
my $entry = XML::Atom::Entry->new( Version => 1 );
- my $entry_xml = $entry->{doc};
+ my $entry_xml = $entry->elem->ownerDocument;
$entry->id( $u->atomid . ":$ditemid" );
@@ -544,14 +515,10 @@ sub create_view_atom
$entry->add_link(
$make_link->(
- 'service.edit', 'application/x.atom+xml',
- "$api/edit/$itemid", 'Edit this post'
+ 'edit', 'application/atom+xml',
+ "$api/entries/$itemid", 'Edit this post'
)
) if $opts->{'apilinks'};
-
- # NOTE: Atom 0.3 allowed for "issued", where we put the time the
- # user says it was. There's no equivalent in later versions of
- # Atom, though. And Atom 0.3 is deprecated. Oh well.
my ($year, $mon, $mday, $hour, $min, $sec) = split(/ /, $it->{eventtime});
my $event_date = sprintf("%04d-%02d-%02dT%02d:%02d:%02d",
@@ -567,13 +534,10 @@ sub create_view_atom
$entry->published( LJ::time_to_w3c($it->{createtime}, "Z") );
$entry->updated( LJ::time_to_w3c($it->{modtime}, "Z") );
- # XML::Atom 0.13 doesn't support categories. Maybe later?
foreach my $tag ( @{$it->{tags} || []} ) {
- $tag = LJ::exml( $tag );
- my $category = $entry_xml->createElement( 'category' );
- $category->setAttribute( 'term', $tag );
- $category->setNamespace( $ns );
- $entry_xml->getDocumentElement->appendChild( $category );
+ my $category = XML::Atom::Category->new;
+ $category->term( $tag );
+ $entry->add_category( $category );
}
my @currents = ( [ 'music' => $it->{music} ],
diff -r d9e05e2ed2ea -r c03034073124 t/atom-post.t
--- a/t/atom-post.t Fri Feb 04 14:53:34 2011 +0800
+++ b/t/atom-post.t Mon Feb 07 12:52:01 2011 +0800
@@ -9,39 +9,642 @@ use LJ::Test;
use XML::Atom::Client;
use XML::Atom::Entry;
+use XML::Atom::Category;
+use XML::Atom::Feed;
+use DW::Routing;
use LWP::Simple;
-if ( get( "$LJ::SITEROOT/admin/healthy" ) =~ /^status=/ ) {
- plan tests => 5;
-} else {
- plan skip_all => "Webserver not running.";
- exit 0;
-}
+my $webserver_running = get( "$LJ::SITEROOT/admin/healthy" ) =~ /^status=/;
+
+# workaround for non-implented read() sub in DW::Request::Standard
+$LJ::T_PASS_INPUT_THROUGH_REQUEST = 1;
+
+# so that entries can be posted to community journals
+$LJ::EVERYONE_VALID = 1;
my $u = temp_user();
my $pass = "foopass";
-$u->set_password($pass);
+$u->set_password( $pass );
-my $api = XML::Atom::Client->new;
-$api->username($u->user);
-$api->password($u->password);
+my $api = XML::Atom::Client->new( Version => 1 );
-my $entry = XML::Atom::Entry->new;
-$entry->title('New Post');
-my $content = "Content of my post at " . rand();
-$entry->content($content);
+my $r;
+sub do_request {
+ my ( %opts ) = @_;
-my $EditURI = $api->createEntry("$LJ::SITEROOT/interface/atom/post", $entry);
+ my $authenticate = delete $opts{authenticate};
+ my $data = delete $opts{data} || {};
+ my $remote = delete $opts{remote} || $u;
+ my $password = delete $opts{password} || $remote->password;
-ok($EditURI, "got an edit URI back, presumably posted");
-like($EditURI, qr!/atom/edit/1$!, "got the right URI back");
+ my $req = HTTP::Request->new( %opts );
-{
- my $entry = LJ::Entry->new($u, jitemid => 1);
- ok($entry, "got entry");
- ok($entry->valid, "entry is valid")
- or die "rest will fail";
+ $req->uri =~ m!http://([^.]+)!;
+ my $user_subdomain = $1 eq "www" ? "" : $1;
- is($entry->event_raw, $content, "item has right content");
+ # caution: may be fragile
+ # relies upon knowing details of the client's implementation
+ # which are not in the client's public documented API
+ if ( $authenticate ) {
+ $api->username( $remote->username );
+ $api->password( $password );
+ $api->munge_request( $req );
+ }
+
+ # clear request caches
+ DW::Request->reset;
+ $r = $DW::Request::cur_req = DW::Request::Standard->new( $req );
+ $DW::Request::determined = 1;
+
+ LJ::Entry->reset_singletons;
+ %LJ::REQ_CACHE_REL = ();
+
+ # set any additional information
+ $r->pnote( $_ => $data->{$_} ) foreach %$data;
+
+ my %routing_data = ();
+ $routing_data{username} = $user_subdomain if $user_subdomain;
+
+ DW::Routing->call( %routing_data );
}
+# check subject, etc
+# items that are not defined in the hash to be checked against are ignored
+sub check_entry {
+ my ( $atom_entry, $entry_info, $journal ) = @_;
+
+ ok( $atom_entry, "Got an atom entry back from the server" );
+ is( $atom_entry->title, $entry_info->{title}, "atom entry has right title" )
+ if defined $entry_info->{title};
+
+ # having the content body be of type HTML
+ # causes newlines to appear for some reason when we try to extract the content as a string
+ # so let's just work around it; it should be harmless (as_xml doesn't contain the extra newlines)
+ my $event_raw = $entry_info->{content};
+ like( $atom_entry->content->body, qr/\s*$event_raw\s*/, "atom entry has right content" )
+ if defined $entry_info->{content};
+
+ is( $atom_entry->id, $entry_info->{atom_id}, "atom id" )
+ if defined $entry_info->{atom_id};
+
+ is( $atom_entry->author->name, $entry_info->{author}, "atom entry author" )
+ if defined $entry_info->{author};
+
+ if ( defined $entry_info->{url} ) {
+ my @links = $atom_entry->link;
+ is( scalar @links, 2, "got back two links" );
+ foreach my $link( @links ) {
+ if ( $link->rel eq "edit" ) {
+ is( $link->href, $journal->atom_base . "/entries/$entry_info->{id}", "edit link" );
+ } else { # alternate
+ is( $link->href, $entry_info->{url}, "entry link" );
+ }
+ }
+ }
+
+ if ( defined $entry_info->{categories} ) {
+ my %tags = map { $_ => 1 } @{ $entry_info->{categories} || [] };
+ my %categories = map { $_->term => 1 } $atom_entry->category;
+ is( scalar keys %categories, 2, "got back multiple categories" );
+ is_deeply( { %categories }, { %tags }, "got back the categories we sent in" );
+ }
+}
+
+
+note( "Authentication" );
+do_request( GET => $u->atom_service_document );
+is( $r->status, $r->HTTP_UNAUTHORIZED, "Did not pass any authorization information." );
+is( $r->header_in( "Content-Type" ), "text/plain", "Error content type" );
+
+# intentionally break authorization
+do_request( GET => $u->atom_service_document, authenticate => 1, password => $u->password x 3 );
+is( $r->status, $r->HTTP_UNAUTHORIZED, "Passed wrong authorization information." );
+
+do_request( GET => $u->atom_service_document, authenticate => 1 );
+is( $r->status, $r->OK, "Successful authentication." );
+
+
+note( "Service document introspection." );
+do_request( POST => $u->atom_service_document );
+is( $r->status, $r->HTTP_UNAUTHORIZED, "Service document protected by authorization." );
+
+do_request( POST => $u->atom_service_document, authenticate => 1 );
+is( $r->status, $r->NOT_FOUND, "Service document needs GET." );
+is( $r->header_in( "Content-Type" ), "text/plain", "Error content type" );
+
+do_request( GET => $u->atom_service_document, authenticate => 1 );
+is( $r->status, $r->OK, "Got service document." );
+like( $r->header_in( "Content-Type" ), qr#^\Qapplication/atomsvc+xml\E#, "Service content type" );
+my $service_document_xml = $r->response_content;
+
+note( "Categories document." );
+# populate journal with some tags
+my @journal_tags = qw( a b c );
+LJ::Tags::create_usertag( $u, join( ", ", @journal_tags ), { display => 1 } );
+
+do_request( GET => $u->atom_base . "/entries/tags" );
+is( $r->status, $r->HTTP_UNAUTHORIZED, "Categories document protected by authorization." );
+
+do_request( POST => $u->atom_base . "/entries/tags", authenticate => 1 );
+is( $r->status, $r->NOT_FOUND, "Categories document needs GET." );
+is( $r->header_in( "Content-Type" ), "text/plain", "Error content type" );
+
+do_request( GET => $u->atom_base . "/entries/tags", authenticate => 1 );
+is( $r->status, $r->OK, "Got categories document." );
+like( $r->header_in( "Content-Type" ), qr#^\Qapplication/atomcat+xml\E#, "Categories document type" );
+my $categories_document_xml = $r->response_content;
+
+SKIP: {
+ skip "No XML::Atom::Service/XML::Atom::Categories module installed.", 10
+ unless eval "use XML::Atom::Service; use XML::Atom::Categories; 1;";
+
+ my $service = XML::Atom::Service->new( \ $service_document_xml );
+ ok( $service, "Got service document." );
+
+ my @workspaces = $service->workspace;
+ is( scalar @workspaces, 1, "One workspace" );
+ is( $workspaces[0]->title, $u->user, "Workspace title" );
+
+ my @collections = $workspaces[0]->collections;
+ is( scalar @collections, 1, "One collection" );
+ is( $collections[0]->title, "Entries", "Entries collection title" );
+ is( $collections[0]->href, $u->atom_base . "/entries", "Entries collection uri" );
+
+ my @categories = $collections[0]->categories;
+ is( scalar @categories, 1, "One categories link" );
+ is( $categories[0]->href, $u->atom_base . "/entries/tags", "Categories collection uri" );
+
+
+ my $categories = XML::Atom::Categories->new( \$ categories_document_xml );
+ @categories = $categories->category;
+ is( scalar @categories, 3, "three existing categories" );
+ is_deeply( { map { $_->term => 1 } @categories }, { map { $_ => 1 } @journal_tags }, "Journal tags match fetched categories" );
+}
+
+my $atom_entry; # an XML::Atom::Entry object
+my $entry_obj; # an LJ::Entry object
+my $atom_entry_server; # an XML::Atom::Entry object retrieved from the server
+
+$atom_entry = XML::Atom::Entry->new( Version => 1 );
+my $title = "New Post";
+my $content = "Content of my post at " . rand();
+my @tags = qw( foo bar );
+$atom_entry->title( $title );
+$atom_entry->content( $content );
+foreach my $tag ( @tags ) {
+ my $category = XML::Atom::Category->new( Version => 1 );
+ $category->term( $tag );
+ $atom_entry->add_category( $category );
+}
+
+note( "Create an entry." );
+do_request( POST => $u->atom_base . "/entries", data => { input => $atom_entry->as_xml } );
+is( $r->status, $r->HTTP_UNAUTHORIZED, "Entry creation protected by authorization." );
+
+do_request( POST => $u->atom_base . "/entries", authenticate => 1, data => { input => $atom_entry->as_xml } );
+is( $r->status, $r->HTTP_CREATED, "POSTed new entry" );
+is( $r->header_in( "Content-Type" ), "application/atom+xml", "AtomAPI entry content type" );
+
+note( "Double-check posted entry." );
+$entry_obj = LJ::Entry->new( $u, jitemid => 1 );
+ok( $entry_obj, "got entry" );
+ok( $entry_obj->valid, "entry is valid" );
+is( $entry_obj->subject_raw, $title, "item has right title" );
+is( $entry_obj->event_raw, $content, "item has right content" );
+
+$atom_entry_server = XML::Atom::Entry->new( \ $r->response_content );
+check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $atom_entry_server->title,
+ content => $atom_entry_server->content->body,
+ url => $entry_obj->url,
+ author => $u->name_orig,
+ categories => \@tags,
+ },
+ $u );
+
+ok( $atom_entry_server->published eq $atom_entry_server->updated, "same publish and edit date" );
+ok( ! $atom_entry_server->summary, "no summary; we have the content." );
+
+note( "List entries" );
+do_request( GET => $u->atom_base . "/entries" );
+is( $r->status, $r->HTTP_UNAUTHORIZED, "Entries feed needs authorization." );
+
+do_request( GET => $u->atom_base . "/entries", authenticate => 1 );
+is( $r->status, $r->OK, "Retrieved entry list" );
+is( $r->header_in( "Content-Type" ), "application/atom+xml", "AtomAPI entry content type" );
+
+my $feed = XML::Atom::Feed->new( \ $r->response_content );
+my @entries = $feed->entries;
+is( scalar @entries, 1, "Got entry from feed." );
+
+note( "Retrieve entry" );
+do_request( GET => $u->atom_base . "/entries/1" );
+is( $r->status, $r->HTTP_UNAUTHORIZED, "Retrieving entry needs authorization." );
+
+do_request( GET => $u->atom_base . "/entries/12345", authenticate => 1 );
+is( $r->status, $r->NOT_FOUND, "No such entry" );
+is( $r->content_type, "text/plain", "AtomAPI entry content type" );
+
+do_request( POST => $u->atom_base . "/entries/1", authenticate => 1 );
+is( $r->status, $r->NOT_FOUND, $u->atom_base . "/entries/1 does not support POST." );
+
+do_request( GET => $u->atom_base . "/entries/1", authenticate => 1 );
+is( $r->status, $r->OK, "Retrieved entry" );
+is( $r->content_type, "application/atom+xml", "AtomAPI entry content type" );
+
+$atom_entry_server = XML::Atom::Entry->new( \ $r->response_content );
+check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $entry_obj->subject_raw,
+ content => $entry_obj->event_raw,
+ atom_id => $entry_obj->atom_id,
+ url => $entry_obj->url,
+ author => $u->name_orig,
+ categories => \@tags
+ },
+ $u );
+ok( $atom_entry_server->published eq $atom_entry_server->updated, "same publish and edit date" );
+ok( ! $atom_entry_server->summary, "no summary; we have the content." );
+
+
+note( "Edit entry" );
+do_request( PUT => $u->atom_base . "/entries/1" );
+is( $r->status, $r->HTTP_UNAUTHORIZED, "Retrieving entry needs authorization." );
+
+do_request( PUT => $u->atom_base . "/entries/12345", authenticate => 1 );
+is( $r->status, $r->NOT_FOUND, "No such entry" );
+is( $r->content_type, "text/plain", "AtomAPI entry content type" );
+
+
+$atom_entry = XML::Atom::Entry->new( Version => 1 );
+$title = "Edited Post";
+$content = "Content of my post at " . rand();
+@tags = qw( foo2 bar2 );
+$atom_entry->id( $atom_entry_server->id );
+$atom_entry->title( $title );
+$atom_entry->content( $content );
+foreach my $tag ( @tags ) {
+ my $category = XML::Atom::Category->new( Version => 1 );
+ $category->term( $tag );
+ $atom_entry->add_category( $category );
+}
+
+# put a little bit of time between publish and update
+sleep( 1 );
+do_request( PUT => $u->atom_base . "/entries/1", authenticate => 1, data => { input => $atom_entry->as_xml } );
+is( $r->status, $r->OK, "Edited entry" );
+is( $r->content_type, "application/atom+xml", "AtomAPI entry content type" );
+
+do_request( GET => $u->atom_base . "/entries/1", authenticate => 1 );
+$atom_entry_server = XML::Atom::Entry->new( \ $r->response_content );
+check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $title,
+ content => $content,
+ atom_id => $entry_obj->atom_id,
+ url => $entry_obj->url,
+ author => $u->name_orig,
+ categories => \@tags
+ },
+ $u );
+ok( $atom_entry_server->published ne $atom_entry_server->updated, "different publish and edit date" );
+
+
+$atom_entry_server->id( "123" );
+do_request( PUT => $u->atom_base . "/entries/1", authenticate => 1, data => { input => $atom_entry_server->as_xml } );
+is( $r->status, $r->HTTP_BAD_REQUEST, "Mismatched ids" );
+
+
+do_request( DELETE => $u->atom_base . "/entries/1", authenticate => 1 );
+is( $r->status, $r->OK, "Deleted entry" );
+$entry_obj = LJ::Entry->new( $u, jitemid => 1 );
+isnt( $entry_obj->valid, "Entry confirmed deleted" );
+
+
+do_request( PUT => $u->atom_base . "/entries/1", authenticate => 1 );
+is( $r->status, $r->NOT_FOUND, "Trying to edit deleted entry" );
+
+
+note( "Checking community functionality." );
+{
+ my $memberof_cu = temp_comm();
+ my $nonmemberof_cu = temp_comm();
+ $u->join_community( $memberof_cu, 1, 1 );
+
+ my $another_u = temp_user(); # another member of the community
+ $another_u->set_password( $pass );
+ $another_u->join_community( $memberof_cu, 1, 1 );
+
+ my $admin_u = temp_user(); # an administrator of the community
+ $admin_u->set_password( $pass );
+ $admin_u->join_community( $memberof_cu, 1, 1 );
+ LJ::set_rel( $memberof_cu->userid, $admin_u->userid, "A" );
+
+
+ note( "Service document introspection (community)." );
+ # unauthenticated to community
+ do_request( GET => $memberof_cu->atom_service_document );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "Service document protected by authorization." );
+
+ # community you aren't a member of
+ do_request( GET => $nonmemberof_cu->atom_service_document, authenticate => 1 );
+ is( $r->status, $r->OK, "Not a member of the community, but we still get the service document for the user (which doesn't contain the community)." );
+
+ SKIP: {
+ skip "No XML::Atom::Service/XML::Atom::Categories module installed.", 3
+ unless eval "use XML::Atom::Service; use XML::Atom::Categories; 1;";
+
+ my $service_document_xml = $r->response_content;
+
+ my $service = XML::Atom::Service->new( \ $service_document_xml );
+ ok( $service, "Got service document." );
+
+ my @workspaces = $service->workspace;
+ is( scalar @workspaces, 2, "One workspace" );
+ isnt( $_->title, $nonmemberof_cu->user, "Community you're not a member of doesn't appear in the service document." ) foreach @workspaces;
+ }
+
+
+ # community you are a member of
+ do_request( GET => $memberof_cu->atom_service_document, authenticate => 1 );
+ is( $r->status, $r->OK, "Got service document." );
+ like( $r->header_in( "Content-Type" ), qr#^\Qapplication/atomsvc+xml\E#, "Service content type" );
+
+ SKIP: {
+ skip "No XML::Atom::Service/XML::Atom::Categories module installed.", 8
+ unless eval "use XML::Atom::Service; use XML::Atom::Categories; 1;";
+
+ my $service_document_xml = $r->response_content;
+
+ my $service = XML::Atom::Service->new( \ $service_document_xml );
+ ok( $service, "Got service document." );
+
+ my @workspaces = $service->workspace;
+ is( scalar @workspaces, 2, "Personal journal and community as separate workspaces" );
+
+ # making assumptions that the second workspace is our community
+ my $memberof_cu_workspace = $workspaces[1];
+ is( $memberof_cu_workspace->title, $memberof_cu->user, "Workspace title" );
+
+ my @collections = $memberof_cu_workspace->collections;
+ is( scalar @collections, 1, "One collection" );
+ is( $collections[0]->title, "Entries", "Entries collection title" );
+ is( $collections[0]->href, $memberof_cu->atom_base . "/entries", "Entries collection uri" );
+
+ my @categories = $collections[0]->categories;
+ is( scalar @categories, 1, "One categories link" );
+ is( $categories[0]->href, $memberof_cu->atom_base . "/entries/tags", "Categories collection uri" );
+ }
+
+
+ note( "Create an entry (community)." );
+ my $title = "Community entry";
+ my $content = "Community entry content " . rand();
+ my $atom_entry = XML::Atom::Entry->new( Version => 1 );
+ $atom_entry->title( $title );
+ $atom_entry->content( $content );
+
+ # unauthenticated to community
+ do_request( POST => $memberof_cu->atom_base . "/entries", data => { input => $atom_entry->as_xml } );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "Trying to post to community while unauthenticated." );
+
+ # community you don't have posting access to
+ do_request( POST => $nonmemberof_cu->atom_base . "/entries", authenticate => 1, data => { input => $atom_entry->as_xml } );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "Trying to post to community, but don't have posting access." );
+
+ # community you have posting access to
+ do_request( POST => $memberof_cu->atom_base . "/entries", authenticate => 1, data => { input => $atom_entry->as_xml } );
+ is( $r->status, $r->HTTP_CREATED, "POSTed new entry" );
+ is( $r->header_in( "Content-Type" ), "application/atom+xml", "AtomAPI entry content type" );
+
+ note( "Double-check posted entry (community)." );
+ $entry_obj = LJ::Entry->new( $memberof_cu, jitemid => 1 );
+ ok( $entry_obj, "got entry" );
+ ok( $entry_obj->valid, "entry is valid" );
+ is( $entry_obj->subject_raw, $title, "item has right title" );
+ is( $entry_obj->event_raw, $content, "item has right content" );
+
+ $atom_entry_server = XML::Atom::Entry->new( \ $r->response_content );
+ check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $atom_entry_server->title,
+ content => $atom_entry_server->content->body,
+ url => $entry_obj->url,
+ author => $u->name_orig,
+ },
+ $memberof_cu );
+
+
+ note( "List entries (community)." );
+ # unauthenticated to community
+ do_request( GET => $memberof_cu->atom_base . "/entries" );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "Entries feed needs authorization." );
+
+ # community you don't have posting access to
+ do_request( GET => $nonmemberof_cu->atom_base . "/entries", authenticate => 1 );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "Entries feed needs authorization." );
+
+ # community you have posting access to
+ do_request( GET => $memberof_cu->atom_base . "/entries", authenticate => 1 );
+ is( $r->status, $r->OK, "Retrieved entry list" );
+ is( $r->header_in( "Content-Type" ), "application/atom+xml", "AtomAPI entry content type" );
+
+ my $feed = XML::Atom::Feed->new( \ $r->response_content );
+ my @entries = $feed->entries;
+ is( scalar @entries, 1, "Got entry from feed." );
+
+
+ note( "Retrieve entry (community)" );
+ # unauthenticated to community
+ do_request( GET => $memberof_cu->atom_base . "/entries/1" );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "Retrieving entry needs authorization." );
+
+ # community you don't have posting access to
+ do_request( GET => $nonmemberof_cu->atom_base . "/entries/1", authenticate => 1 );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "Retrieving entry needs authorization." );
+
+
+ # community you have posting access to
+ # retrieve (should succeed)
+ # edit (should succeed)
+ # delete (should succeed)
+ do_request( GET => $memberof_cu->atom_base . "/entries/1", authenticate => 1 );
+ is( $r->status, $r->OK, "Retrieved entry" );
+ is( $r->content_type, "application/atom+xml", "AtomAPI entry content type" );
+
+ $atom_entry_server = XML::Atom::Entry->new( \ $r->response_content );
+ check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $entry_obj->subject_raw,
+ content => $entry_obj->event_raw,
+ atom_id => $entry_obj->atom_id,
+ url => $entry_obj->url,
+ author => $u->name_orig
+ },
+ $memberof_cu );
+
+ $atom_entry = XML::Atom::Entry->new( Version => 1 );
+ $title = "Edited Post";
+ $content = "Content of my post at " . rand();
+ $atom_entry->id( $atom_entry_server->id );
+ $atom_entry->title( $title );
+ $atom_entry->content( $content );
+
+ do_request( PUT => $memberof_cu->atom_base . "/entries/1", authenticate => 1, data => { input => $atom_entry->as_xml } );
+
+ is( $r->status, $r->OK, "Edited entry" );
+ is( $r->content_type, "application/atom+xml", "AtomAPI entry content type" );
+
+ do_request( GET => $memberof_cu->atom_base . "/entries/1", authenticate => 1 );
+ $atom_entry_server = XML::Atom::Entry->new( \ $r->response_content );
+ check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $title,
+ content => $content,
+ atom_id => $entry_obj->atom_id,
+ url => $entry_obj->url,
+ author => $u->name_orig,
+ },
+ $memberof_cu );
+
+
+ do_request( DELETE => $memberof_cu->atom_base . "/entries/1", authenticate => 1 );
+ is( $r->status, $r->OK, "Deleted entry" );
+ $entry_obj = LJ::Entry->new( $memberof_cu, jitemid => 1 );
+ isnt( $entry_obj->valid, "Entry confirmed deleted" );
+
+
+ note( "Check what other people can do." );
+ # make another entry that other people can view/manipulate
+ do_request( POST => $memberof_cu->atom_base . "/entries", authenticate => 1, data => { input => $atom_entry->as_xml } );
+ $atom_entry_server = XML::Atom::Entry->new( \ $r->response_content );
+ $atom_entry = XML::Atom::Entry->new( Version => 1 );
+ $title = "Edited Post";
+ $content = "Content of my post at " . rand();
+ $atom_entry->id( $atom_entry_server->id );
+ $atom_entry->title( $title );
+ $atom_entry->content( $content );
+
+ # another community member
+ # retrieve (should fail)
+ # edit (should fail)
+ # delete (should fail)
+ do_request( GET => $memberof_cu->atom_base . "/entries/2", authenticate => 1, remote => $another_u );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "You don't own this entry (another_u, get)" );
+
+ do_request( PUT => $memberof_cu->atom_base . "/entries/2", authenticate => 1, remote => $another_u, data => { input => $atom_entry->as_xml } );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "You don't own this entry (another_u, edit)" );
+
+ do_request( DELETE => $memberof_cu->atom_base . "/entries/2", authenticate => 1, remote => $another_u );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "You don't own this entry (another_u, delete)" );
+
+
+ # community admin
+ # retrieve (should succeed)
+ # edit (should fail)
+ # delete (should succeed)
+ do_request( GET => $memberof_cu->atom_base . "/entries/2", authenticate => 1, remote => $admin_u );
+ is( $r->status, $r->OK, "Retrieved entry" );
+ is( $r->content_type, "application/atom+xml", "AtomAPI entry content type" );
+
+ do_request( PUT => $memberof_cu->atom_base . "/entries/2", authenticate => 1, remote => $admin_u, data => { input => $atom_entry->as_xml } );
+ is( $r->status, $r->HTTP_UNAUTHORIZED, "You don't own this entry (admin_u, edit)" );
+
+ do_request( DELETE => $memberof_cu->atom_base . "/entries/2", authenticate => 1, remote => $admin_u );
+ is( $r->status, $r->OK, "Deleted entry (admin_u, delete)" );
+ $entry_obj = LJ::Entry->new( $memberof_cu, jitemid => 2 );
+ isnt( $entry_obj->valid, "Entry confirmed deleted" );
+}
+
+
+# a few quick tests just to double-check using XML::Atom::Client, to make sure we're up to standard
+my $EditURI = "";
+note( "Use the API interface from an external client, rather than testing the methods directly." );
+SKIP: {
+ skip "Webserver not running.", 21 unless $webserver_running;
+
+ $api->username( $u->username );
+ $api->password( $u->password );
+
+ my $atombaseurl = $u->atom_base;
+ my $feed = $api->getFeed( "$atombaseurl/entries" );
+ is( scalar $feed->entries, undef, "No entries right now." );
+
+ note( "Create an entry" );
+ my $title = "New Post";
+ my $content = "Content of my post at " . rand();
+ my @tags = qw( fooz ball );
+
+ $atom_entry = XML::Atom::Entry->new( Version => 1 );
+ $atom_entry->title( $title );
+ $atom_entry->content( $content );
+ foreach my $tag ( @tags ) {
+ my $category = XML::Atom::Category->new( Version => 1 );
+ $category->term( $tag );
+ $atom_entry->add_category( $category );
+ }
+
+ $EditURI = $api->createEntry( "$atombaseurl/entries", $atom_entry );
+ ok( $EditURI, "got an edit URI back, presumably posted" );
+ like( $EditURI, qr!^$atombaseurl/entries/2$!, "got the right URI back" );
+
+ $entry_obj = LJ::Entry->new( $u, jitemid => 2 );
+ ok( $entry_obj, "got entry" );
+ ok( $entry_obj->valid, "entry is valid" );
+ is( $entry_obj->subject_raw, $title, "item has right title" );
+ is( $entry_obj->event_raw, $content, "item has right content" );
+
+ my $feed = $api->getFeed( "$atombaseurl/entries" );
+ is( scalar $feed->entries, 1, "One entry in the feed." );
+
+
+ note( "Retrieve entry" );
+ $atom_entry_server = $api->getEntry( $EditURI );
+ check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $title,
+ content => $content,
+ url => $entry_obj->url,
+ author => $u->name_orig,
+ categories => \@tags,
+ },
+ $u );
+ ok( $atom_entry_server->published eq $atom_entry_server->updated, "same publish and edit date" );
+ ok( ! $atom_entry_server->summary, "no summary; we have the content." );
+
+ $atom_entry->id( $atom_entry_server->id );
+
+
+ note( "Edit entry" );
+ my $edited;
+ $content = "New content of my post at " . rand();
+ $atom_entry->content( $content );
+ $edited = $api->updateEntry( $EditURI, $atom_entry );
+ ok( $edited, "Edit content successful" );
+ $atom_entry_server = $api->getEntry( $EditURI );
+ check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $title,
+ content => $content,
+ }, $u );
+
+ $title = "Edited Post";
+ $atom_entry->title( $title );
+ my $edited = $api->updateEntry( $EditURI, $atom_entry );
+ ok( $edited, "Edit title successful" );
+ $atom_entry_server = $api->getEntry( $EditURI );
+ check_entry( $atom_entry_server, {
+ id => $entry_obj->jitemid,
+ title => $title,
+ content => $content,
+ }, $u );
+
+ note( "All done. Delete!" );
+ $api->deleteEntry( $EditURI );
+
+ $feed = $api->getFeed( "$atombaseurl/entries" );
+ is( scalar $feed->entries, undef, "Feed is empty of entries." );
+}
+
+done_testing();
--------------------------------------------------------------------------------