request.pl

OpenCDN内容分发系统

#!/usr/bin/perl -I ../../
#
# request.pl   a cgi Perl script to be used for testing of the OpenCDN
#              Depending on the value of $req = <SetUp|TearDown>
#              it will invoke the SetUp or TearDown XML-RPC method
#              to be executed on the RRDM entity
#
# The oCDN package is released under the terms of the Perl Artistic Licence
# (see http://www.perl.com/pub/a/language/misc/Artistic.html) by their
# Copyright Holders, hosted at the University of Roma "La Sapienza",
# at http://labtel.ing.uniroma1.it/opencdn

use RPC::XML;
use RPC::XML::Client;
use CGI;
use LWP::UserAgent;
use etc::CommConf qw($rrdm_addr $rrdm_port $log_to);
require 'etc/RRDMconfig.pm';

my ($parms, $req, $r, $q, $ip_client, $origin_URI, $cli, $risposta);
my ($tag, $transport, $desc, $odesc, $duration, $audio, $video);
my ($seethis, $res, $prereq_res, $postreq_res) = (undef, undef, undef, undef);

#
# start to build the output page
#
$q = new CGI;
print $q->header(-expires=>'-10y');
print $q->start_html('OpenCDN Response Page');
print $q->h1('OpenCDN Response Page');

#
# receives input parameters
#
$req        = $q->param('req');
$origin_URI = $q->param('program');
$clip       = $q->param('clip');
$ip_client  = $ENV{REMOTE_ADDR};
$cheatip    = $q->param('cheatip');
if ($cheatip eq 'on') {
  $ip_client  = $clip;
}

#
# retrieves metadata for $origin_URI from RRDM
#
my $cli2 = RPC::XML::Client->new("http://$rrdm_addr:$rrdm_port",
                                 'useragent', ['timeout', 8]);
my $risp = $cli2 -> simple_request('Status', 'origin');
if ((keys %{$risp})) {
  $tag       = ${$risp}{$origin_URI}{'tag'};
  $transport = ${$risp}{$origin_URI}{'transport'};
  $desc      = ${$risp}{$origin_URI}{'desc'};
  $odesc     = ${$risp}{$origin_URI}{'odesc'};
  $duration  = ${$risp}{$origin_URI}{'duration'};
  $audio     = ${$risp}{$origin_URI}{'audio'};
  $video     = ${$risp}{$origin_URI}{'video'};
} else {
  print "<br><br>The Request Routing and Distribution Management (RRDM) entity seems to be down.\n";
  print "<br>Error is: $RPC::XML::ERROR\n";
  print "<br>Please enform developers and retry later\n";
  goto END;
}

#
# if a forked RRDM is in use, the second port is for SetUp and TearDown
#
$rrdm_port2 = $rrdm_port;
$rrdm_port2++ if ($RRDMconfig::forked_addr);
# and the second address too
$rrdm_addr2 = $rrdm_addr;
$rrdm_addr2 = $RRDMconfig::forked_addr if ($RRDMconfig::forked_addr);

#
# execute the request
#
if ($req eq 'SetUp') {
  $cli = RPC::XML::Client->new("http://$rrdm_addr2:$rrdm_port2/RPCSERV");
  $parms = { Client    => $ip_client,
             Program   => $origin_URI };
  $risposta = $cli->send_request("Setup", $parms);
}
elsif ($req eq 'TearDown') {
  $cli = RPC::XML::Client->new("http://$rrdm_addr2:$rrdm_port2/RPCSERV");
  my $parms = { Program   => $origin_URI,
                Requester => $ip_client};
  $risposta = $cli->send_request("Teardown", $parms);
}
else {
  print "<br><br>Request \"$req\" is not allowed. Use <b>SetUp</b> or <b>TearDown</b> either.\n";
  goto END;
}

#
# build the RRDM response to show
#
if (ref ($risposta) eq "RPC::XML::string") {
  $seethis = "Dereferenced response:              <B>$$risposta</B><br>\n";
}
elsif (ref ($risposta) eq "RPC::XML::fault" || ref ($risposta) eq "RPC::XML::struct" ) {
  my @pippo = keys (%$risposta);
  if (${$$risposta{'faultCode'}}) {
    $seethis = "faultString: ${$$risposta{'faultString'}}<br>faultCode:   ${$$risposta{'faultCode'}}";
  }
  if(${$$risposta{'ret_code'}}) {
    $seethis = "ret_code: ${$$risposta{'ret_code'}}<br>ret_val:  ${$$risposta{'ret_val'}}";
  }
}
else{
  $seethis = "<B>$risposta</B><br>\n";
}

#
# give the response for the requested service
#
if (${$$risposta{'ret_code'}} eq '200' && $req eq 'SetUp') {
  print 'Please receive the requested content at<br><b>',
        $q->a({href=>${$$risposta{'ret_val'}}}, ${$$risposta{'ret_val'}}),
        '</b><br>';
  print 'by using a ';
  if ($transport eq 'd') {
    print $q->a({href=>'http://www.apple.com/quicktime/download/'},
                       'QuickTime');
    print ' player, or if you are a Linux user, try ';
    print $q->a({href=>'http://mpeg4ip.sourceforge.net/downloads/index.php'},
                       'Mpeg4IP'), ' or ',
          $q->a({href=>'http://www.mplayerhq.hu/homepage/design7/dload.html'},
                       'MPlayer'), ' (with <i>Live!</i> libraries)<br><br>';
  } elsif ($transport eq 'r') {
    print $q->a({href=>'http://forms.real.com/real/player/blackjack.html'},
                       'RealPlayer');
    print ' player, or if you are a Linux user, try ';
    print $q->a({href=>'https://player.helixcommunity.org/'},
                       'HelixPlayer'), ' or ',
          $q->a({href=>'http://www.mplayerhq.hu/homepage/design7/dload.html'},
                       'MPlayer'), ' (with <i>Live!</i> libraries)<br><br>';
  }
  print 'Note: at the first SetUp, you may need to wait some seconds before',
        ' you start to receive media packets, because of buffering at',
        ' each intermediate hop relay involved';
#  print "<EMBED SRC=\"${$$risposta{'ret_val'}}\", WIDTH=150, HEIGHT=250 autoplay=\"true\" CONTROLLER=\"false\">";
} elsif ($req eq 'TearDown') {
  print "Teardown of $origin_URI";
} else {
  print 'Something went wrong :-( You may find some more information below';
}
print '<br><br><hr>';

#
# Report about input values, RRDM response, pre-/post-requisite response if any
#
print $q->b('Input values:'), '<pre>';
print "Received request    <B>$req</B><br>",
      "Your IP address     <B>$ip_client</B><br>",
      "Content Origin      <a href=\"$origin_URI\">$origin_URI</a></B><br>",
      "Content Description <B>$desc</B><br>",
      "Provided by         <B>$odesc</B><br>",
      "Transport           <B>$transport</B><br>",
      "Duration            <B>$duration</B><br>",
      "Audio               <B>$audio</B><br>",
      "Video               <B>$video</B><br>";
print '</pre><hr>';

print $q->b('Response from RRDM:'), '<pre>';
print $seethis;
print '</pre><hr>';

$prereq_res = ${$$risposta{'Prereq_Res'}};
if ($prereq_res) {
    print $q->b('Prerequisite invocation response page:'), '<pre>';
    print $prereq_res;
    print '</pre><hr>';
}

$postreq_res = ${$$risposta{'Postreq_Res'}};
if ($postreq_res) {
    print $q->b('Postrequisite invocation response page:'), '<pre>';
    print $postreq_res;
    print '</pre><hr>';
}

END {
  print $q->end_html;
}