#!/usr/bin/perl -wT
# -*- Mode: perl; tab-width: 4; indent-tabs-mode: nil; -*-
#
# Pingback Proxy: HTTP GET to XML-RPC POST
#
# Copyright (c) 2002 by Ian Hickson
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
# This actually also supports POST. But if someone can do POST then
# they should just contact the XML-RPC server.
# test: http://software.hixie.ch/utilities/cgi/pingback-proxy/client-proxy?source=http%3A%2F%2Fwww%2Edummy%2Dblog%2Eorg%2F%3Fstart%3D1031598216%26count%3D1&target=http%3A%2F%2Fwww%2Edummy%2Dblog%2Eorg%2F%3Fstart%3D31438739%26count%3D1
use strict;
use diagnostics;
use lib '/home/ianh/lib/perl';
use CGI;
use LWP::UserAgent;
use RPC::XML;
use RPC::XML::Client;
use HTML::Entities;
print STDERR "\npingback client proxy invoked\n";
# get arguments
my $query = CGI->new();
my $source = $query->param('source');
my $target = $query->param('target');
if (not defined($source) or not defined($target)) {
result('400 Bad Request', 'Client Error',
'You must pass both source and client parameters.');
}
print STDERR "source=$source\ntarget=$target\n";
# get source content
my $ua = LWP::UserAgent->new();
$ua->agent($ua->agent . ' (Hixie\'s pingback proxy)');
$ua->timeout(5);
$ua->env_proxy();
$ua->protocols_allowed(['http', 'https']);
my $request = HTTP::Request->new('GET', $target);
my $page = $ua->request($request);
if ($page->is_error) {
if ($page->code == 404) {
result('404 Not Found', 'Client Error', $page->status_line);
} else {
result('502 Error', 'Client Error', $page->status_line);
}
}
my $content = $page->content;
# find a pingback server
my $server;
if (my @servers = $page->header('X-Pingback')) {
# XXX complain about there being more than 1, if appropriate
$server = $servers[0];
} elsif ($content =~ m//os or
$content =~ m//os) {
$server = HTML::Entities::decode($1);
} else {
result('501 Not Implemented', 'Server Error', 'Target has no pingback server');
}
print STDERR "server=$server\n";
# ok, try to contact the server
my $response = RPC::XML::Client->new($server)->send_request('pingback.ping', $source, $target);
if (not ref($response)) {
result('502 Bad Gateway (not a valid XML-RPC response)', 'Server Error', $response);
}
print STDERR "response=\n" . ($response->as_string) . "\n";
if ($response->is_fault) {
result('502 Fault', 'Server Error', $response->string);
}
result('202 Accepted', 'Done', $response->value);
sub result {
my($status, $line1, $data) = @_;
my $length = length("$line1\n$data");
print <