helm/http_getter/http_getter.pl

   1 #!/usr/bin/perl
   2
   3 # First of all, let's load HELM configuration
   4 use Env;
   5 my $HELM_CONFIGURATION_PREFIX = $ENV{"HELM_CONFIGURATION_PREFIX"};
   6 my $HELM_CONFIGURATION_PATH =
   7  $HELM_CONFIGURATION_PREFIX."/local/lib/helm/configuration.pl";
   8 # next require defines: $helm_dir, $html_link, $dtd_dir, $uris_dbm
   9 require $HELM_CONFIGURATION_PATH;
  10
  11
  12
  13 use HTTP::Daemon;
  14 use HTTP::Status;
  15 use HTTP::Request;
  16 use LWP::UserAgent;
  17 use DB_File;
  18
  19 #CSC: mancano i controlli sulle condizioni di errore di molte funzioni
  20 #CSC: ==> non e' robusto
  21 #CSC: altra roba da sistemare segnata con CSC
  22
  23 my $d = new HTTP::Daemon LocalPort => 8081;
  24 tie(%map, 'DB_File', $uris_dbm.".db", O_RDONLY, 0664);
  25 print "Please contact me at: <URL:", $d->url, ">\n";
  26 print "helm_dir: $helm_dir\n";
  27 print "dtd_dir: $dtd_dir\n";
  28 print "urls_of_uris.db: $uris_dbm.db\n";
  29 $SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes
  30 $SIG{USR1} = \&update; # sent by the child to make the parent update
  31 while (my $c = $d->accept) {
  32  if (fork() == 0) {
  33     while (my $r = $c->get_request) {
  34         #CSC: mancano i controlli di sicurezza
  35
  36         my $inputuri = $r->url;
  37         $inputuri =~ s/^[^?]*\?uri=(.*)/$1/;
  38         print "\nRequest: ".$r->url."\n\n";
  39         my $http_method = $r->method;
  40         my $http_path = $r->url->path;
  41
  42         if ($http_method eq 'GET' and $http_path eq "/getciconly") {
  43             # finds the uri, url and filename
  44             my $cicuri = $inputuri;
  45
  46             my $cicfilename = $cicuri;
  47             $cicfilename =~ s/cic:(.*)/$1/;
  48             $cicfilename =~ s/theory:(.*)/$1/;
  49             $cicfilename = $helm_dir.$cicfilename.".xml";
  50
  51             my $cicurl   = $map{$cicuri};
  52             if (!defined($cicurl)) {
  53              print "\nNOT FOUND!!!!!\n";
  54              $c->send_error(RC_NOT_FOUND)
  55             } else {
  56                print_request("cic",$cicuri,$cicurl,$cicfilename);
  57
  58                # Retrieves the file
  59                my $ciccontent = download(0,"cic",$cicurl,$cicfilename);
  60
  61                # Answering the client
  62                answer($c,$ciccontent);
  63             }
  64         } elsif ($http_method eq 'GET' and $http_path eq "/get") {
  65             # finds the uris, urls and filenames
  66             my $cicuri = $inputuri,
  67                $typesuri = $inputuri,
  68                $annuri = $inputuri;
  69             my $annsuffix;
  70             if ($inputuri =~ /\.types$/) {
  71                $cicuri    =~ s/(.*)\.types$/$1/;
  72                undef($annuri);
  73             } elsif ($inputuri =~ /\.types\.ann$/) {
  74                $cicuri    =~ s/(.*)\.types\.ann$/$1/;
  75                $typesuri  =~ s/(.*)\.ann$/$1/;
  76                $annsuffix = ".types.ann";
  77             } elsif ($inputuri =~ /\.ann$/) {
  78                $cicuri  =~ s/(.*)\.ann$/$1/;
  79                undef($typesuri);
  80                $annsuffix = ".ann";
  81             } else {
  82                undef($typesuri);
  83                undef($annuri);
  84             }
  85
  86             my $cicfilename = $cicuri;
  87             $cicfilename =~ s/cic:(.*)/$1/;
  88             $cicfilename =~ s/theory:(.*)/$1/;
  89             $cicfilename = $helm_dir.$cicfilename;
  90
  91             my $typesfilename = $cicfilename.".types.xml"     if $typesuri;
  92             my $annfilename  = $cicfilename.$annsuffix.".xml" if $annuri;
  93             $cicfilename .= ".xml";
  94
  95             my $cicurl   = $map{$cicuri};
  96             my $typesurl = $map{$typesuri} if $typesuri;
  97             my $annurl   = $map{$annuri}  if $annuri;
  98
  99             if (!defined($cicurl) ||
 100                (!defined($typesurl) && $typesuri) ||
 101                (!defined($annuri) && $annuri))
 102             {
 103              print "\nNOT FOUND!!!!!\n";
 104              $c->send_error(RC_NOT_FOUND)
 105             } else {
 106                print_request("cic",$cicuri,$cicurl,$cicfilename);
 107                print_request("types",$typesuri,$typesurl,$typesfilename)
 108                 if ($typesuri);
 109                print_request("ann",$annuri,$annurl,$annfilename)
 110                 if ($annuri);
 111
 112                # Retrieves the files
 113
 114                my $ciccontent = download(1,"cic",$cicurl,$cicfilename);
 115                my $typescontent =
 116                 download(1,"types",$typesurl,$typesfilename) if ($typesuri);
 117                my $anncontent =
 118                 download(1,"ann",$annurl,$annfilename) if ($annuri);
 119
 120                # Merging the files together
 121
 122                my $merged = <<EOT;
 123 <?xml version="1.0" encoding="UTF-8"?>
 124 <cicxml uri="$cicuri">
 125 $ciccontent
 126 $typescontent
 127 $anncontent
 128 </cicxml>
 129 EOT
 130
 131                # Answering the client
 132                answer($c,$merged);
 133             }
 134          } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") {
 135             my $filename = $inputuri;
 136             $filename = $dtd_dir."/".$filename;
 137             print "DTD: $inputuri ==> ($filename)\n";
 138             if (stat($filename)) {
 139                print "Using local copy\n";
 140                open(FD, $filename);
 141                $cont = "";
 142                while(<FD>) { $cont .= $_; }
 143                close(FD);
 144                answer($c,$cont);
 145             } else {
 146                die "Could not find DTD!";
 147             }
 148         } elsif ($http_method eq 'GET' and $http_path eq "/conf") {
 149             my $quoted_html_link = $html_link;
 150             $quoted_html_link =~ s/&/&amp;/g;
 151             $quoted_html_link =~ s/</&lt;/g;
 152             $quoted_html_link =~ s/>/&gt;/g;
 153             $quoted_html_link =~ s/'/&apos;/g;
 154             $quoted_html_link =~ s/"/&quot;/g;
 155             print "\nConfiguration requested, returned #$quoted_html_link#\n";
 156             $cont = "<?xml version=\"1.0\"?><html_link>$quoted_html_link</html_link>";
 157             answer($c,$cont);
 158         } elsif ($http_method eq 'GET' and $http_path eq "/update") {
 159            print "Update requested...";
 160            update();
 161            kill(USR1,getppid());
 162            print " done\n";
 163            answer($c,"<html><body><h1>Update done</h1></body></html>");
 164         } else {
 165             print "\nINVALID REQUEST!!!!!\n";
 166             $c->send_error(RC_FORBIDDEN)
 167         }
 168         print "\nRequest solved: ".$r->url."\n\n";
 169     }
 170     $c->close;
 171     undef($c);
 172     print "\nCONNECTION CLOSED\n\n";
 173     exit;
 174   } # fork
 175 }
 176
 177 #================================
 178
 179
 180 #CSC: Too much powerful: creates even /home, /home/users/, ...
 181 #CSC: Does not raise errors if could not create dirs/files
 182 sub mkdirs
 183 {
 184  my ($pathname) = @_;
 185  my @dirs = split /\//,$pathname;
 186  my $tmp;
 187  foreach $dir (@dirs) {
 188   $tmp = ((defined($tmp)) ?  $tmp."\/".$dir : "");
 189   mkdir($tmp,0777);
 190  }
 191  rmdir($tmp);
 192 }
 193
 194 sub print_request
 195 {
 196  my ($str,$uri,$url,$filename) = @_;
 197  print $str."uri: $uri\n";
 198  print $str."url: $url\n";
 199  print $str."filename: $filename\n\n";
 200 }
 201
 202 sub callback
 203 {
 204  my ($data) = @_;
 205  $cont .= $data;
 206 }
 207
 208 sub download
 209 {
 210  my ($remove_headers,$str,$url,$filename) = @_;
 211  $cont = ""; # modified by side-effect by the callback function
 212  if (stat($filename)) {
 213     print "Using local copy for the $str file\n";
 214     open(FD, $filename);
 215     while(<FD>) { $cont .= $_; }
 216     close(FD);
 217  } else {
 218     print "Downloading the $str file\n";
 219     $ua = LWP::UserAgent->new;
 220     $request = HTTP::Request->new(GET => "$url");
 221     $response = $ua->request($request, \&callback);
 222
 223     print "Storing the $str file\n";
 224     mkdirs($filename);
 225     open(FD, ">".$filename);
 226     print FD $cont;
 227     close(FD);
 228  }
 229  if ($remove_headers) {
 230     $cont =~ s/<\?xml [^?]*\?>//sg;
 231     $cont =~ s/<!DOCTYPE [^>]*>//sg;
 232  }
 233  return $cont;
 234 }
 235
 236 sub answer
 237 {
 238  my ($c,$cont) = @_;
 239  my $res = new HTTP::Response;
 240  $res->content($cont);
 241  $c->send_response($res);
 242 }
 243
 244 sub update {
 245  untie %map;
 246  tie(%map, 'DB_File', $uris_dbm.".db", O_RDONLY, 0664);
 247 }