modules/pingback-server.pl

   1 # Copyright (C) 2004  Brock Wilcox <awwaiid@thelackthereof.org>
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program; if not, write to the
  15 #    Free Software Foundation, Inc.
  16 #    59 Temple Place, Suite 330
  17 #    Boston, MA 02111-1307 USA
  18 #
  19 # History / Notes
  20 #   2004.03.19
  21 #     - Created
  22 #     - Works!
  23 #     - Tried to get rid of LWP but failed :(
  24 #     - We have to capture the script before CGI.pm starts to get STDIN
  25
  26 $ModulesDescription .= '<p>pingback-server.pl (v0.1) - PingbackServers get noted on the comment page.</p>';
  27
  28 use LWP::UserAgent; # This one will one day be eliminated! Hopefully!
  29
  30 # Need these to do pingback
  31 use RPC::XML;
  32 use RPC::XML::Parser;
  33
  34 use vars qw( $CommentsPrefix );
  35
  36 *OldPingbackServerGetHtmlHeader = *GetHtmlHeader;
  37 *GetHtmlHeader = *NewPingbackServerGetHtmlHeader;
  38
  39 # Add the <link ...> to the header
  40 sub NewPingbackServerGetHtmlHeader {
  41   my ($title, $id) = @_;
  42   my $header = OldPingbackServerGetHtmlHeader($title,$id);
  43   my $pingbackLink =
  44     '<link rel="pingback" '
  45     . 'href="http://thelackthereof.org/wiki.pl?action=pingback;id='
  46     . $id . '">';
  47   $header =~ s/<head>/<head>$pingbackLink/;
  48   return $header;
  49 }
  50
  51 *OldPingbackServerInitRequest = *InitRequest;
  52 *InitRequest = *NewPingbackServerInitRequest;
  53
  54 sub NewPingbackServerInitRequest {
  55   if($ENV{'QUERY_STRING'} =~ /action=pingback;id=(.*)/) {
  56     my $id = $1;
  57     DoPingbackServer($id);
  58     exit 0;
  59   } else {
  60     return OldPingbackServerInitRequest(@_);
  61   }
  62 }
  63
  64 sub DoPingbackServer {
  65   my $id = FreeToNormal(shift);
  66
  67
  68   if ($ENV{'REQUEST_METHOD'} ne 'POST') {
  69       result('405 Method Not Allowed', -32300,
  70         'Only XML-RPC POST requests recognised.', 'Allow: POST');
  71   }
  72
  73   if ($ENV{'CONTENT_TYPE'} ne 'text/xml') {
  74       result('415 Unsupported Media Type', -32300,
  75         'Only XML-RPC POST requests recognised.');
  76   }
  77
  78   local $/ = undef;
  79   my $input = <STDIN>;
  80
  81   # parse it
  82   my $parser = RPC::XML::Parser->new();
  83   my $request = $parser->parse($input);
  84   if (not ref($request)) {
  85       result('400 Bad Request', -32700, $request);
  86   }
  87
  88   # handle it
  89   my $name = $request->name;
  90   my $arguments = $request->args;
  91   if ($name ne 'pingback.ping') {
  92       result('501 Not Implemented', -32601, "Method $name not supported");
  93   }
  94   if (@$arguments != 2) {
  95       result('400 Bad Request', -32602,
  96       "Wrong number of arguments (arguments must be in the form 'from', 'to')");
  97   }
  98   my $source = $arguments->[0]->value;
  99   my $target = $arguments->[1]->value;
 100
 101
 102   # TODO: Since we are _inside_ the wiki seems like we shouldn't have to use LWP
 103   # So comment out all the LWP stuff once the DoPost thingie works
 104   # DoPost($id);
 105
 106   my $ua = LWP::UserAgent->new;
 107   $ua->agent("OddmusePingbackServer/0.1 ");
 108
 109   # Create a request
 110   my $req = HTTP::Request->new(POST => 'http://thelackthereof.org/wiki.pl');
 111   $req->content_type('application/x-www-form-urlencoded');
 112   $req->content("title=$CommentsPrefix$id"
 113     . "&summary=new%20comment"
 114     . "&aftertext=Pingback:%20$source"
 115     . "&save=save"
 116     . "&username=pingback");
 117   my $res = $ua->request($req);
 118
 119   my $out = '';
 120   # Check the outcome of the response
 121   if ($res->is_success) {
 122     $out =  $res->content;
 123   } else {
 124     $out = $res->status_line, "\n";
 125   }
 126
 127   result('200 OK', 0, "Oddmuse PingbackServer! $id OK");
 128
 129   sub result {
 130       my($status, $error, $data, $extra) = @_;
 131       my $response;
 132       if ($error) {
 133           $response = RPC::XML::response->new(
 134             RPC::XML::fault->new($error, $data));
 135       } else {
 136           $response = RPC::XML::response->new(RPC::XML::string->new($data));
 137       }
 138       print "Status: $status\n";
 139       if (defined($extra)) {
 140           print "$extra\n";
 141       }
 142       print "Content-Type: text/xml\n\n";
 143       print $response->as_string;
 144       exit;
 145   }
 146
 147 =pod
 148
 149   # This doesn't work... but might be a basis for an in-wiki update system
 150
 151   sub DoPost {
 152     my $id = FreeToNormal(shift);
 153     my $source = shift;
 154     ValidIdOrDie($id);
 155     # Lock before getting old page to prevent races
 156     RequestLockOrError(); # fatal
 157     OpenPage($id);
 158     my $string = $Page{text};
 159     my $comment = "Pingback: $source";
 160     $comment =~ s/\r//g;        # Remove "\r"-s (0x0d) from the string
 161     $comment =~ s/\s+$//g;    # Remove whitespace at the end
 162     $string .= "----\n" if $string and $string ne "\n";
 163     $string .= $comment . "\n\n-- Pingback"
 164       . ' ' . TimeToText(time) . "\n\n";
 165     my $summary = "new pingback"
 166     $Page{summary} = $summary;
 167     $Page{username} = $user;
 168     $Page{text} = $string;
 169     SavePage();
 170     ReleaseLock();
 171   }
 172
 173 =cut
 174
 175 }
 176