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 while (my $c = $d->accept) {
  31  if (fork() == 0) {
  32     while (my $r = $c->get_request) {
  33         #CSC: mancano i controlli di sicurezza
  34
  35         my $inputuri = $r->url;
  36         $inputuri =~ s/^[^?]*\?uri=(.*)/$1/;
  37         print "\nRequest: ".$r->url."\n\n";
  38         my $http_method = $r->method;
  39         my $http_path = $r->url->path;
  40
  41         if ($http_method eq 'GET' and $http_path eq "/getciconly") {
  42             # finds the uri, url and filename
  43             my $cicuri = $inputuri;
  44
  45             my $cicfilename = $cicuri;
  46             $cicfilename =~ s/cic:(.*)/$1/;
  47             $cicfilename =~ s/theory:(.*)/$1/;
  48             $cicfilename = $helm_dir.$cicfilename.".xml";
  49
  50             my $cicurl   = $map{$cicuri};
  51
  52             print_request("cic",$cicuri,$cicurl,$cicfilename);
  53
  54             # Retrieves the file
  55             my $ciccontent = download(0,"cic",$cicurl,$cicfilename);
  56
  57             # Answering the client
  58             answer($c,$ciccontent);
  59         } elsif ($http_method eq 'GET' and $http_path eq "/get") {
  60             # finds the uris, urls and filenames
  61             my $cicuri = $inputuri,
  62                $typesuri = $inputuri,
  63                $annuri = $inputuri;
  64             my $annsuffix;
  65             if ($inputuri =~ /\.types$/) {
  66                $cicuri    =~ s/(.*)\.types$/$1/;
  67                undef($annuri);
  68             } elsif ($inputuri =~ /\.types\.ann$/) {
  69                $cicuri    =~ s/(.*)\.types\.ann$/$1/;
  70                $typesuri  =~ s/(.*)\.ann$/$1/;
  71                $annsuffix = ".types.ann";
  72             } elsif ($inputuri =~ /\.ann$/) {
  73                $cicuri  =~ s/(.*)\.ann$/$1/;
  74                undef($typesuri);
  75                $annsuffix = ".ann";
  76             } else {
  77                undef($typesuri);
  78                undef($annuri);
  79             }
  80
  81             my $cicfilename = $cicuri;
  82             $cicfilename =~ s/cic:(.*)/$1/;
  83             $cicfilename =~ s/theory:(.*)/$1/;
  84             $cicfilename = $helm_dir.$cicfilename;
  85
  86             my $typesfilename = $cicfilename.".types.xml"     if $typesuri;
  87             my $annfilename  = $cicfilename.$annsuffix.".xml" if $annuri;
  88             $cicfilename .= ".xml";
  89
  90             my $cicurl   = $map{$cicuri};
  91             my $typesurl = $map{$typesuri} if $typesuri;
  92             my $annurl   = $map{$annuri}  if $annuri;
  93
  94             print_request("cic",$cicuri,$cicurl,$cicfilename);
  95             print_request("types",$typesuri,$typesurl,$typesfilename)
  96              if ($typesuri);
  97             print_request("ann",$annuri,$annurl,$annfilename)
  98              if ($annuri);
  99
 100             # Retrieves the files
 101
 102             my $ciccontent = download(1,"cic",$cicurl,$cicfilename);
 103             my $typescontent =
 104              download(1,"types",$typesurl,$typesfilename) if ($typesuri);
 105             my $anncontent =
 106              download(1,"ann",$annurl,$annfilename) if ($annuri);
 107
 108             # Merging the files together
 109
 110             my $merged = <<EOT;
 111 <?xml version="1.0" encoding="UTF-8"?>
 112 <cicxml uri="$cicuri">
 113 $ciccontent
 114 $typescontent
 115 $anncontent
 116 </cicxml>
 117 EOT
 118
 119             # Answering the client
 120             answer($c,$merged);
 121          } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") {
 122             my $filename = $inputuri;
 123             $filename = $dtd_dir."/".$filename;
 124             print "DTD: $inputuri ==> ($filename)\n";
 125             if (stat($filename)) {
 126                print "Using local copy\n";
 127                open(FD, $filename);
 128                $cont = "";
 129                while(<FD>) { $cont .= $_; }
 130                close(FD);
 131                answer($c,$cont);
 132             } else {
 133                die "Could not find DTD!";
 134             }
 135         } elsif ($http_method eq 'GET' and $http_path eq "/conf") {
 136             my $quoted_html_link = $html_link;
 137             $quoted_html_link =~ s/&/&amp;/g;
 138             $quoted_html_link =~ s/</&lt;/g;
 139             $quoted_html_link =~ s/>/&gt;/g;
 140             $quoted_html_link =~ s/'/&apos;/g;
 141             $quoted_html_link =~ s/"/&quot;/g;
 142             print "\nConfiguration requested, returned #$quoted_html_link#\n";
 143             $cont = "<?xml version=\"1.0\"?><html_link>$quoted_html_link</html_link>";
 144             answer($c,$cont);
 145         } else {
 146             print "\nINVALID REQUEST!!!!!\n";
 147             $c->send_error(RC_FORBIDDEN)
 148         }
 149         print "\nRequest solved: ".$r->url."\n\n";
 150     }
 151     $c->close;
 152     undef($c);
 153     print "\nCONNECTION CLOSED\n\n";
 154     exit;
 155   } # fork
 156 }
 157
 158 #================================
 159
 160
 161 #CSC: Too much powerful: creates even /home, /home/users/, ...
 162 #CSC: Does not raise errors if could not create dirs/files
 163 sub mkdirs
 164 {
 165  my ($pathname) = @_;
 166  my @dirs = split /\//,$pathname;
 167  my $tmp;
 168  foreach $dir (@dirs) {
 169   $tmp = ((defined($tmp)) ?  $tmp."\/".$dir : "");
 170   mkdir($tmp,0777);
 171  }
 172  rmdir($tmp);
 173 }
 174
 175 sub print_request
 176 {
 177  my ($str,$uri,$url,$filename) = @_;
 178  print $str."uri: $uri\n";
 179  print $str."url: $url\n";
 180  print $str."filename: $filename\n\n";
 181 }
 182
 183 sub callback
 184 {
 185  my ($data) = @_;
 186  $cont .= $data;
 187 }
 188
 189 sub download
 190 {
 191  my ($remove_headers,$str,$url,$filename) = @_;
 192  $cont = ""; # modified by side-effect by the callback function
 193  if (stat($filename)) {
 194     print "Using local copy for the $str file\n";
 195     open(FD, $filename);
 196     while(<FD>) { $cont .= $_; }
 197     close(FD);
 198  } else {
 199     print "Downloading the $str file\n";
 200     $ua = LWP::UserAgent->new;
 201     $request = HTTP::Request->new(GET => "$url");
 202     $response = $ua->request($request, \&callback);
 203
 204     print "Storing the $str file\n";
 205     mkdirs($filename);
 206     open(FD, ">".$filename);
 207     print FD $cont;
 208     close(FD);
 209  }
 210  if ($remove_headers) {
 211     $cont =~ s/<\?xml [^?]*\?>//sg;
 212     $cont =~ s/<!DOCTYPE [^>]*>//sg;
 213  }
 214  return $cont;
 215 }
 216
 217 sub answer
 218 {
 219  my ($c,$cont) = @_;
 220  my $res = new HTTP::Response;
 221  $res->content($cont);
 222  $c->send_response($res);
 223 }