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



package e;

sub child {
    my $self = shift;
    my $child = shift;
    foreach (@{$self->{'Kids'}}) {
        if ($_->isa("e::$child")) {
            return $_;
        }
    }
    return undef;
}

sub text {
    my $self = shift;
    my $result = '';
    foreach (@{$self->{'Kids'}}) {
        if ($_->isa('e::Characters')) {
            $result .= $_->{'Text'};
        }
    }
    return $result;
}

package e::response; use vars '@ISA'; @ISA = ('e');
package e::error; use vars '@ISA'; @ISA = ('e');
package e::message; use vars '@ISA'; @ISA = ('e');

package main;
use strict;
use diagnostics;
use lib '/home/ianh/lib/perl';
use LWP::UserAgent;
use RPC::XML;
use RPC::XML::Parser;
use 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'}) or $ENV{'PATH_INFO'} !~ m|^/[^/]+/.+|os) {
    result('400 Bad Request', -32300, 'Missing trackback ID or 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 = $arguments->[0]->value;
# target is dropped

# set up UA
my $ua = LWP::UserAgent->new();
$ua->agent($ua->agent . ' (Hixie\'s pingback proxy)');
$ua->timeout(5);
$ua->env_proxy();
$ua->protocols_allowed(['http', 'https']);

# get data about the source
my $title = '';
my $blog = '';
my $sourcePage = HTTP::Request->new('GET', $source);
my $sourceResponse = $ua->request($sourcePage);
if ($sourceResponse->is_error) {
    if ($sourceResponse->code == 404) {
        result('400 Bad Request', 0x0010, $sourceResponse->status_line);
    } else {
        result('400 Bad Request', 0x0032, $sourceResponse->status_line);
    }
}
my $sourceContent = $sourceResponse->content;
if ($sourceContent =~ m|<title>([^<]*)</title>|os) {
    my $rawTitle = $1;
    if ($rawTitle =~ m/(.*): (.*)/os or
        $rawTitle =~ m/(.*) - (.*)/os) {
        $title = uri_escape($1, '^a-zA-Z0-9');
        $blog = uri_escape($2, '^a-zA-Z0-9');
    } else {
        $title = uri_escape($rawTitle, '^a-zA-Z0-9');
    }
}
$source = uri_escape($source, '^a-zA-Z0-9');

# pass it on to the real server
my $page = HTTP::Request->new('POST', $server);
$page->header('Content-Type', 'application/x-www-form-urlencoded');
$page->content("url=$source&title=$title&blog_name=$blog");
my $response = $ua->request($page);
if ($response->is_error) {
    result('200 OK', 0x0032, 'Error in higher level protocol: '.$response->status_line);
}
eval {
    my $content = XML::Parser->new('Style' => 'Objects', 'Pkg' => 'e')->parse($response->content);
    if (not ref($content) eq 'ARRAY' or @$content != 1) {
        result('200 OK', 0x0032, 'Unexpected response: ' . $response->content);
    }
    $content = $content->[0];
    if ($content->isa('e::response') and
        $content->child('error')->text eq '0') {
        result('200 OK', 0, 'Done.');
    } elsif ($content->isa('e::response') and
        $content->child('error')->text eq '1') {
        result('200 OK', 0x0032, $content->child('message')->text);
    }
};
if ($@) {
    result('200 OK', 0x0032, "Error: $@");
}

sub result {
    my($status, $error, $data, $extra) = @_;
    print STDERR "p2t: status=$status; error=$error; data=$data\n";
    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;
}