#!/usr/bin/perl -wT
# -*- Mode: perl; tab-width: 4; indent-tabs-mode: nil; -*-
#
# Pingback Proxy: XML-RPC POST to HTTP GET with parameters
#
# 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

# test: http://software.hixie.ch/utilities/cgi/pingback-proxy/server-to-get-proxy/http://software.hixie.ch/utilities/cgi/test-tools/echo

use strict;
use diagnostics;
use lib '/home/ianh/lib/perl';
use LWP::UserAgent;
use RPC::XML;
use RPC::XML::Parser;
use URI::Escape;

if ($ENV{'REQUEST_METHOD'} ne 'POST') {
    result('405 Method Not Allowed', -32300, 'Only XML-RPC POST requests recognised.', 'Allow: POST');
}

if ($ENV{'CONTENT_TYPE'} ne 'text/xml') {
    result('415 Unsupported Media Type', -32300, 'Only XML-RPC POST requests recognised.');
}

if (not defined($ENV{'PATH_INFO'})) {
    result('400 Bad Request', -32300, 'Missing server URI (see README).');
}

# get the data
my $server = $ENV{'PATH_INFO'};
$server =~ s/^\///o;
local $/ = undef;
my $input = <STDIN>;

# parse it
my $parser = RPC::XML::Parser->new();
my $request = $parser->parse($input);
if (not ref($request)) {
    result('400 Bad Request', -32700, $request);
}

# handle it
my $name = $request->name;
my $arguments = $request->args;
if ($name ne 'pingback.ping') {
    result('501 Not Implemented', -32601, "Method $name not supported");
}
if (@$arguments != 2) {
    result('400 Bad Request', -32602, "Wrong number of arguments (arguments must be in the form 'from', 'to')");
}
my $source = uri_escape($arguments->[0]->value, '^a-zA-Z0-9');
my $target = uri_escape($arguments->[1]->value, '^a-zA-Z0-9');

# pass it on to the real server
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 $page = HTTP::Request->new('GET', "$server?source=$source&target=$target");
my $response = $ua->request($page);
if ($response->is_error) {
    if ($response->code == 404) {
        result('200 OK', 0x0032, $response->status_line);
    } else {
        result('200 OK', 0x0032, $response->status_line);
    }
}
my $content = $response->content;
result('200 OK', 0, $content);

sub result {
    my($status, $error, $data, $extra) = @_;
    my $response;
    if ($error) {
        $response = RPC::XML::response->new(RPC::XML::fault->new($error, $data));
    } else {
        $response = RPC::XML::response->new(RPC::XML::string->new($data));
    }
    print "Status: $status\n";
    if (defined($extra)) {
        print "$extra\n";
    }
    print "Content-Type: text/xml\n\n";
    print $response->as_string;
    exit;
}