#!/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/<link\s+rel=\"pingback\"\s+href=\"([^\"]+)\"\s*\/?>/os or
         $content =~ m/<link\s+href=\"([^\"]+)\"\s+rel=\"pingback\"\s*\/?>/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 <<EOF;
Status: $status
Content-Type: text/plain
Content-Length: $length

$line1
$data
EOF
    print STDERR "result=$status ($line1)\n\n";
    exit;
}