/pingback/client.pl

#!/usr/bin/perl -wT
# -*- Mode: perl; tab-width: 4; indent-tabs-mode: nil; -*-
#
# Pingback Client: HTML to Pingback
#
# 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

use strict;
use diagnostics;
use lib '/home/ianh/lib/perl';
use CGI;
use LWP::UserAgent;
use RPC::XML::Client;
use HTML::Entities;

print STDERR "\npingback client invoked\n";

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

# get permalink
my $permalink = $query->param('permalink');
if (not defined($permalink)) {
    result('400 Bad Request', 'Client Error',
           'You must provide a permalink.');
}
print STDERR "permalink: $permalink\n";

# get source content
my $content = $query->param('content');
if (not defined($content) or $content eq '') {
    my $request = HTTP::Request->new('GET', $permalink);
    $request->referer('http://point-defiance.rhcloud.com/ping/client.pl');
    $content = $ua->request($request)->content;
}
#print STDERR "content:\n$content\n";

# scan $content for links
my $links = {};
while ($content =~ s/href=\"([^\"]+)\"//os) {
   next if ( $1 =~ /^https:\/\/bitbucket/ );		       # Static Link on Page Template
   next if ( $1 =~ /^http:\/\/www\.livefyre\.com/ );           # Static Link on Page Template
   next if ( $1 =~ /^http:\/\/www\.openshift\.com/ );          # Static Link on Page Template
   next if ( $1 =~ /^http:\/\/ikiwiki\.info/ );                # Static Link on Page Template
   next if ( $1 =~ /^http:\/\/www\.gnu\.org/ );                # Document Licensing
   next if ( $1 =~ /^http:\/\/software\.hixie\.ch/ );          # Just because

   next if ( $1 =~ /^http:\/\/point-defiance\.rhcloud\.com/ ); # Prevent Selfpings
   next if ( $1 =~ /^\.\./ );                                  # Prevent Self Relative Path Links
   next if ( $1 =~ /^\// );                                    # Prevent Self Absolute Path Links
   next if ( $1 =~ /^#/ );                                     # Prevent Self Anchors
   next if ( $1 =~ /ikiwiki\.cgi/ );                           # Prevent Self CGI Links

    $links->{decode_entities($1)}++;
    # using a hash instead of an array avoids duplicates
}

# send pingbacks
my $result = '';
foreach my $link (keys(%$links)) {
    # fetch the page
    my $request = HTTP::Request->new('GET', $link);
    $request->referer($permalink);
    my $headers = $ua->request($request);
    my $page = $headers->content;
    # scan for a pingback link
    my $pingbackServer;
    if (my @pingbackServers = $headers->header('X-Pingback')) {
        # XXX check that there is only one?
        $pingbackServer = $pingbackServers[0];
    } elsif ($page =~ m/<link\s+rel=\"pingback\"\s+href=\"([^\"]+)\"\s*\/?>/os) {
        $pingbackServer = decode_entities($1);
    } else {
        $result .= "No pingback server at $link\n";
        next;
    }
    # send pingback
    my $client = RPC::XML::Client->new($pingbackServer);
    my $response = $client->send_request('pingback.ping', $permalink, $link);
    if (not ref $response) {
        $result .= "Failed to ping back '$pingbackServer': $response\n";
    } else {
        $result .= "Got a response from '$pingbackServer': \n" . $response->as_string . "\n";
    }
}

result('200 Done', 'Done', $result);


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$data\n\n";
    exit;
}