added pingback capabilities

git-svn-id: http://yolanda.mister-muffin.de/svn@314 7eef14d0-6ed0-489d-bf55-20463b2d70db

trunk/apache.conf

@@ -15,8 +15,8 @@ NameVirtualHost *
 	AllowEncodedSlashes On
 
 	RewriteEngine On
-        RewriteRule  ^/video/(.*)/([0-9]*)/(.*)$ /video.pl?title=$1&id=$2&$3
+        RewriteRule  ^/video/(.*)/([0-9]+)/(.*)$ /video.pl?title=$1&id=$2&$3
-        RewriteRule  ^/embedded/(.*)/([0-9]*)/(.*)$ /video.pl?title=$1&id=$2&embed=true&$3
+        RewriteRule  ^/embedded/(.*)/([0-9]+)/(.*)$ /video.pl?title=$1&id=$2&embed=true&$3
 	RewriteRule  ^/download/([0-9]+)/(.*)$ /download.pl?id=$1&$2
 
 	ErrorLog /var/log/apache2/error.log

trunk/functions.pl

@@ -235,9 +235,6 @@ sub urlencode
 
 sub output_page
 {
-    use XML::LibXSLT;
-    use XML::LibXML;
-
     my $parser = XML::LibXML->new();
     my $xslt = XML::LibXSLT->new();
 
@@ -303,6 +300,7 @@ sub output_page
             return $session->header(
                 -type=>$stylesheet->media_type,
                 -charset=>$stylesheet->output_encoding,
+                "x-pingback"=>$config->{"url_root"}."/pingback.pl"
             ),
             $output->toString;
             #$stylesheet->output_as_bytes($output); <= for future use with XML::LibXSLT (>= 1.62)

trunk/include.pl

@@ -7,8 +7,12 @@ use XML::Simple qw(:strict);
 use Digest::SHA qw(sha256_hex);
 use LWPx::ParanoidAgent;
 use Net::OpenID::Consumer;
-use CGI::Carp qw(fatalsToBrowser set_message);
 use File::Copy;
+use XML::LibXSLT;
+use XML::LibXML;
+use LWP::UserAgent;
+use HTTP::Request;
+use CGI::Carp qw(fatalsToBrowser set_message);
 
 set_message("It's not a bug, it's a feature!!<br />(include this error message in your bugreport here: <a href=\"http://yolanda.mister-muffin.de/newticket\">Yolanda bugtracker</a>)");
 

trunk/init_sql.pl

@@ -117,7 +117,19 @@ $dbh->do(qq{create table
         id              int auto_increment  not null,
         userid          int                 not null,
         videoid         int                 not null,
-        text            varchar(255)        not null,
+        text            text                not null,
+        timestamp       bigint              not null,
+        primary key     (id)
+    )
+}) or die $dbh->errstr;
+
+$dbh->do(qq{create table
+    pingbacks
+    (
+        id              int auto_increment  not null,
+        source          varchar(255)        not null,
+        videoid         int                 not null,
+        text            text                not null,
         timestamp       bigint              not null,
         primary key     (id)
     )

trunk/pingback.pl

@@ -0,0 +1,137 @@
+require "functions.pl";
+
+#initialize session data
+CGI::Session->name($config->{"page_cookie_name"});
+$query = new CGI;
+$session = new CGI::Session;
+
+if ($query->param("POSTDATA"))
+{
+    my $xmlpost = XMLin($query->param("POSTDATA"), ForceArray => 0, KeyAttr => 0);
+    
+    if (!$@)
+    {
+        my $method = $xmlpost->{"methodName"};
+        my $source = $xmlpost->{"params"}->{"param"}[0]->{"value"}->{"string"};
+        my $target = $xmlpost->{"params"}->{"param"}[1]->{"value"}->{"string"};
+        
+        if ($method eq "pingback.ping")
+        {
+            if ($source =~ /^http:\/\// and $target =~ /^http:\/\//)
+            {
+                #fetch the source URI to verify that the source does indeed link to the target.
+                my $request = HTTP::Request->new(GET => $source);
+                my $ua = LWP::UserAgent->new;
+                my $response = $ua->request($request);
+                
+                if ($response->is_success)
+                {
+                    #TODO: sanitize regex to grep site content
+                    if (my ($text) = $response->content =~ m/(\S*.{0,17}$target.{0,17}\S*)/)
+                    {
+                        #check data to ensure that the target exists and is a valid entry.
+                        my ($vid) = $target =~ /^$config->{'url_root'}\/video\/.*\/(\d+)\/.*/;
+                        
+                        my $sth = $dbh->prepare("select id from videos where id = ? limit 1");
+                        my $rowcount = $sth->execute($vid) or die $dbh->errstr;
+                        
+                        $sth->finish() or die $dbh->errstr;
+                        
+                        if ($rowcount)
+                        {
+                            #check that the pingback has not already been registered.
+                            $sth = $dbh->prepare("select id from pingbacks where videoid = ? limit 1");
+                            $rowcount = $sth->execute($vid) or die $dbh->errstr;
+                            $sth->finish() or die $dbh->errstr;
+                            
+                            if ($rowcount eq "0E0")
+                            {
+                                #record the pingback.
+                                $dbh->do(qq{insert into pingbacks (source, videoid, text, timestamp) values (?, ?, ?, unix_timestamp())}, undef,
+                                        $source, $vid, $text) or die $dbh->errstr;
+                                
+                                my $xml = ();
+                                $xml->{'params'}->{'param'}->{'value'}->{'string'} = ["Pingback from $source to $target registered. Keep the web talking! :-)"];
+                                
+                                print $session->header(
+                                            -type=>'application/xml',
+                                            -charset=>'UTF-8',
+                                        );
+
+                                print XMLout(
+                                        $xml,
+                                        XMLDecl => 1,
+                                        KeyAttr => {},
+                                        RootName => 'methodResponse'
+                                    );
+                            }
+                            else
+                            {
+                                send_error(48, "The pingback has already been registered.");
+                            }
+                        }
+                        else
+                        {
+                            send_error(33, "The specified target URI cannot be used as a target.");
+                        }
+                    }
+                    else
+                    {
+                        send_error(17, "The source URI does not contain a link to the target URI, and so cannot be used as a source.");
+                    }
+                }
+                else
+                {
+                    send_error(16, "The source URI does not exist.");
+                }
+            }
+            else
+            {
+                send_error(-32602, "server error. invalid method parameters");
+            }
+        }
+        else
+        {
+            send_error(-32601, "server error. requested method not found");
+        }
+    }
+    else
+    {
+        send_error(-32700,"parse error. not well formed");
+    }
+}
+else
+{
+    print $session->header;
+    print "XML-RPC server only accepts POST requests with http content-type defined.";
+}
+
+sub send_error
+{
+    my ($faultCode, $faultString) = @_;
+
+    my $xml = ();
+    push @{$xml->{'fault'}->{'value'}->{'struct'}->{'member'}},
+    {
+        "name" => ["faultCode"],
+        "value" => [$faultCode]
+    };
+    push @{$xml->{'fault'}->{'value'}->{'struct'}->{'member'}},
+    {
+        "name" => ["faultString"],
+        "value" => [$faultString]
+    };
+    
+    print $session->header(
+                -type=>'application/xml',
+                -charset=>'UTF-8',
+            );
+
+    print XMLout(
+            $xml,
+            XMLDecl => 1,
+            KeyAttr => {},
+            RootName => 'methodResponse'
+        );
+}
+

trunk/video.pl

@@ -76,10 +76,75 @@ if($query->url_param('id'))
                 #output infobox
                 $page->{'message'}->{'type'} = "information";
                 $page->{'message'}->{'text'} = "information_comment_created";
-            
+                
                 #add to database
                 $dbh->do(qq{insert into comments (userid, videoid, text, timestamp) values (?, ?, ?, unix_timestamp())}, undef,
                         $userinfo->{'id'}, $id, $query->param('comment')) or die $dbh->errstr;
+                
+                #send pingbacks to every url in the comment
+                my (@matches) = $query->param('comment') =~ /(http:\/\/\S+)/gi;
+                foreach $match (@matches)
+                {
+                    #ask for http header only - if pingbacks are implemented right, then we wont need the full site
+                    my $request = HTTP::Request->new(HEAD => $match);
+                    my $ua = LWP::UserAgent->new;
+                    
+                    my $response = $ua->request($request);
+                    
+                    if ($response->is_success)
+                    {
+                        my $pingbackurl = $response->header("x-pingback");
+                        
+                        #if there was no x-pingback header, fetch the website and search for link element
+                        if (!$pingbackurl)
+                        {
+                            $request = HTTP::Request->new(GET => $match);
+                            $response = $ua->request($request);
+                            
+                            if ($response->is_success)
+                            {
+                                ($pingbackurl) = $response->content =~ /<link rel="pingback" href="([^"]+)" ?\/?>/;
+                            }
+                        }
+                        
+                        #if requests were successful, send the pingbacks
+                        if ($pingbackurl)
+                        {
+                            #TODO: expand xml entities &lt; &gt; &amp; &quot; in $pingbackurl
+                            
+                            #contruct the xml-rpc request
+                            my $xmlpost->{"methodName"} = ["pingback.ping"];
+                            push @{$xmlpost->{'params'}->{'param'} },
+                            {
+                                "value" =>
+                                {
+                                    "string" => [$config->{"url_root"}."/video/".urlencode($title)."/$id/"]
+                                }
+                            };
+                            push @{$xmlpost->{'params'}->{'param'} },
+                            {
+                                "value" =>
+                                {
+                                    "string" => [$match]
+                                }
+                            };
+                            
+                            #post a xml-rpc request
+                            $request = HTTP::Request->new(POST => $pingbackurl);
+                            $request->header('Content-Type' => "application/xml");
+                            $request->content(XMLout(
+                                                    $xmlpost,
+                                                    XMLDecl => 1,
+                                                    KeyAttr => {},
+                                                    RootName => 'methodCall'
+                                                ));
+                            $ua = LWP::UserAgent->new;
+                            $response = $ua->request($request);
+                            print $response->content;
+                            #TODO: maybe do something on success?
+                        }
+                    }
+                }
             }
         }
         

trunk/xsl/xhtml/xhtml-head.xsl

@@ -39,6 +39,9 @@
                 <xsl:value-of select="$site_strings[@id='site_name']" />
             </xsl:attribute>
         </link>
+        
+        <!-- TODO: get server root from config file-->
+        <link rel="pingback" href="http://localhost/pingback.pl" />
 
         <xsl:choose>
             <xsl:when test="//frontpage">