helm/interface/http_getter/http_getter.pl2

   1 #!/usr/bin/perl
   2
   3 # next require defines: $helm_dir, $html_link
   4 require "/usr/lib/helm/configuration.pl";
   5 use HTTP::Daemon;
   6 use HTTP::Status;
   7 use HTTP::Request;
   8 use LWP::UserAgent;
   9 use DB_File;
  10
  11 my $cont = "";
  12 my $d = new HTTP::Daemon LocalPort => 8081;
  13 tie(%map, 'DB_File', 'urls_of_uris.db', O_RDONLY, 0664);
  14 print "Please contact me at: <URL:", $d->url, ">\n";
  15 print "helm_dir: $helm_dir\n";
  16 $SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes
  17 while (my $c = $d->accept) {
  18  if (fork() == 0) {
  19     while (my $r = $c->get_request) {
  20         #CSC: mancano i controlli di sicurezza
  21
  22         $cont = "";
  23         my $cicuri = $r->url;
  24         $cicuri =~ s/^[^?]*\?url=(.*)/$1/;
  25         print "*".$r->url."\n";
  26         my $http_method = $r->method;
  27         my $http_path = $r->url->path;
  28         if ($http_method eq 'GET' and $http_path eq "/get") {
  29             my $filename = $cicuri;
  30             $filename =~ s/cic:(.*)/$1/;
  31             $filename =~ s/theory:(.*)/$1/;
  32             $filename = $helm_dir.$filename.".xml";
  33             my $resolved = $map{$cicuri};
  34             print "$cicuri ==> $resolved ($filename)\n";
  35             if (stat($filename)) {
  36                print "Using local copy\n";
  37                open(FD, $filename);
  38                while(<FD>) { $cont .= $_; }
  39                close(FD);
  40                my $res = new HTTP::Response;
  41                $res->content($cont);
  42                $c->send_response($res);
  43             } else {
  44                print "Downloading\n";
  45                $ua = LWP::UserAgent->new;
  46                $request = HTTP::Request->new(GET => "$resolved");
  47                $response = $ua->request($request, \&callback);
  48
  49                print "Storing file\n";
  50                open(FD, $filename);
  51                print FD $cont;
  52                close(FD);
  53
  54                my $res = new HTTP::Response;
  55                $res->content($cont);
  56                $c->send_response($res);
  57             }
  58         } elsif ($http_method eq 'GET' and $http_path eq "/annotate") {
  59             my $do_annotate = ($cicuri =~ /\.ann$/);
  60             my $target_to_annotate = $cicuri;
  61             $target_to_annotate =~ s/(.*)\.ann$/$1/ if $do_annotate;
  62             my $filename = $cicuri;
  63             $filename =~ s/cic:(.*)/$1/;
  64             $filename =~ s/theory:(.*)/$1/;
  65             my $filename_target = $helm_dir.$filename if $do_annotate;
  66             $filename = $helm_dir.$filename.".xml";
  67             $filename_target =~ s/(.*)\.ann$/$1.xml/ if $do_annotate;
  68             my $resolved = $map{$cicuri};
  69             my $resolved_target = $map{$target_to_annotate} if $do_annotate;
  70             if ($do_annotate) {
  71                print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n";
  72         } elsif ($http_method eq 'GET' and $http_path eq "/getwithtypes") {
  73             my $do_annotate = ($cicuri =~ /\.types$/);
  74             my $target_to_annotate = $cicuri;
  75             $target_to_annotate =~ s/(.*)\.types$/$1/ if $do_annotate;
  76             my $filename = $cicuri;
  77             $filename =~ s/cic:(.*)/$1/;
  78             $filename =~ s/theory:(.*)/$1/;
  79             my $filename_target = $helm_dir.$filename if $do_annotate;
  80             $filename = $helm_dir.$filename.".xml";
  81             $filename_target =~ s/(.*)\.types$/$1.xml/ if $do_annotate;
  82             my $resolved = $map{$cicuri};
  83             my $resolved_target = $map{$target_to_annotate} if $do_annotate;
  84             if ($do_annotate) {
  85                print "($cicuri, $target_to_annotate) ==> ($resolved + $resolved_target) ($filename)\n";
  86              } else {
  87                print "$cicuri ==> $resolved ($filename)\n";
  88             }
  89
  90             # Retrieves the annotation
  91
  92             if (stat($filename)) {
  93                print "Using local copy for the types\n";
  94                open(FD, $filename);
  95                while(<FD>) { $cont .= $_; }
  96                close(FD);
  97             } else {
  98                print "Downloading the types\n";
  99                $ua = LWP::UserAgent->new;
 100                $request = HTTP::Request->new(GET => "$resolved");
 101                $response = $ua->request($request, \&callback);
 102
 103                print "Storing file for the types\n";
 104                open(FD, $filename);
 105                print FD $cont;
 106                close(FD);
 107             }
 108             my $annotation = $cont;
 109
 110             # Retrieves the target to annotate
 111
 112             $cont = "";
 113             if ($do_annotate) {
 114                if (stat($filename_target)) {
 115                   print "Using local copy for the file to type\n";
 116                   open(FD, $filename_target);
 117                   while(<FD>) { $cont .= $_; }
 118                   close(FD);
 119                } else {
 120                   print "Downloading the file to type\n";
 121                   $ua = LWP::UserAgent->new;
 122                   $request = HTTP::Request->new(GET => "$resolved_target");
 123                   $response = $ua->request($request, \&callback);
 124
 125                   print "Storing file for the file to type\n";
 126                   open(FD, $filename_target);
 127                   print FD $cont;
 128                   close(FD);
 129                }
 130             }
 131             my $target = $cont;
 132
 133             # Merging the annotation and the target
 134
 135             $target =~ s/<\?xml [^?]*\?>//sg;
 136             $target =~ s/<!DOCTYPE [^>]*>//sg;
 137             $annotation =~ s/<\?xml [^?]*\?>//sg;
 138             $annotation =~ s/<!DOCTYPE [^>]*>//sg;
 139             my $merged = <<EOT;
 140 <?xml version="1.0" encoding="UTF-8"?>
 141 <cicxml uri="$target_to_annotate">
 142 $target
 143 <ALLTYPES>
 144 $annotation
 145 </ALLTYPES>
 146 </cicxml>
 147 EOT
 148
 149             # Answering the client
 150
 151             my $res = new HTTP::Response;
 152             $res->content($merged);
 153             $c->send_response($res);
 154         } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") {
 155             my $filename = $cicuri;
 156             $filename = $helm_dir."/dtd/".$filename;
 157             print "DTD: $cicuri ==> ($filename)\n";
 158             if (stat($filename)) {
 159                print "Using local copy\n";
 160                open(FD, $filename);
 161                while(<FD>) { $cont .= $_; }
 162                close(FD);
 163                my $res = new HTTP::Response;
 164                $res->content($cont);
 165                $c->send_response($res);
 166             } else {
 167                die "Could not find DTD!";
 168             }
 169         } elsif ($http_method eq 'GET' and $http_path eq "/conf") {
 170             my $quoted_html_link = $html_link;
 171             $quoted_html_link =~ s/&/&amp;/g;
 172             $quoted_html_link =~ s/</&lt;/g;
 173             $quoted_html_link =~ s/>/&gt;/g;
 174             $quoted_html_link =~ s/'/&apos;/g;
 175             $quoted_html_link =~ s/"/&quot;/g;
 176             print "Configuration requested, returned #$quoted_html_link#\n";
 177             $cont = "<?xml version=\"1.0\"?><html_link>$quoted_html_link</html_link>";
 178             my $res = new HTTP::Response;
 179             $res->content($cont);
 180             $c->send_response($res);
 181         } else {
 182             print "INVALID REQUEST!!!!!\n";
 183             $c->send_error(RC_FORBIDDEN)
 184         }
 185     }
 186     $c->close;
 187     undef($c);
 188     print "\nCONNECTION CLOSED\n\n";
 189     exit;
 190   } # fork
 191 }
 192
 193 #================================
 194
 195 sub callback
 196 {
 197  my ($data) = @_;
 198  $cont .= $data;
 199 }