X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhttp_getter%2Fhttp_getter.pl.in;h=e06a3a5e2fbd43e6d3f8cc93bfed0131164d3062;hb=faf311442f59ccbc652c7965d23ed2945fd40906;hp=483b71b1dba642540fe86d0296ecbab2ad56c98f;hpb=3370bb5149deef15ba35b913c5641cd3bf9aea01;p=helm.git

diff --git a/helm/http_getter/http_getter.pl.in b/helm/http_getter/http_getter.pl.in
index 483b71b1d..e06a3a5e2 100755
--- a/helm/http_getter/http_getter.pl.in
+++ b/helm/http_getter/http_getter.pl.in
@@ -29,6 +29,7 @@ my $VERSION = "@VERSION@";
 
 # various variables
 my ($HELM_LIB_PATH);
+my $cgi_dir = "@HELM_CGI_DIR@";
 my (%map);
 
 # First of all, let's load HELM configuration
@@ -82,7 +83,7 @@ $myownurl  =~ s/http:\/\/(.*):(.*)/$1/;
 ($myownurl) = gethostbyname($myownurl);
 $myownurl = "http://".$myownurl.":".$myownport;
 
-tie(%map, 'DB_File', $uris_dbm.".db", O_RDONLY, 0664);
+tie(%map, 'DB_File', $uris_dbm.".db", O_RDWR, 0664);
 print "Please contact me at: <URL:", $myownurl."/", ">\n";
 print "helm_dir: $helm_dir\n";
 print "style_dir: $style_dir\n";
@@ -106,7 +107,7 @@ while (my $c = $d->accept) {
 
 	print "\nUnescaped query: ".$http_query."\n";
 
-        if ($http_method eq 'GET' and $http_path eq "/getciconly") {
+        if ($http_method eq 'GET' and $http_path eq "/getxml") {
             # finds the uri, url and filename
             my $cicuri = $inputuri;
             my $answerformat = $cgi->param('format');
@@ -128,6 +129,9 @@ while (my $c = $d->accept) {
             $cicfilename =~ s/theory:(.*)/$1/;
 
             my $cicurl   = $map{$cicuri};
+            if (not defined($cicurl)) {
+             die "uri \"$cicuri\" can't be resolved\n";
+            }
             my $extension;
             if ($cicurl =~ /\.xml$/) { # non gzipped file
               $extension = ".xml";
@@ -149,8 +153,40 @@ while (my $c = $d->accept) {
                my $ciccontent = download($patch_dtd,"cic",$cicurl,$cicfilename,$answerformat);
 
                # Answering the client
-                answer($c,$ciccontent,$answerformat);
+	       if ($answerformat eq "normal") {
+                answer($c,$ciccontent,"text/xml","");
+               } else {
+                answer($c,$ciccontent,"text/xml","x-gzip");
+               }
             }
+        } elsif ($http_method eq 'GET' and $http_path eq "/register") {
+          my $inputurl = $cgi->param('url');
+          print "Register requested...\n";
+          $map{$inputuri}=$inputurl;
+
+          # Now let's clean the cache
+          my $cicfilename = $inputuri;
+          $cicfilename =~ s/cic:(.*)/$1/;
+          $cicfilename =~ s/theory:(.*)/$1/;
+
+          print "Unlinking ".$helm_dir.$cicfilename.".xml[.gz]\n";
+          unlink ($helm_dir.$cicfilename.".xml");
+          unlink ($helm_dir.$cicfilename.".xml.gz");
+
+          kill(USR1,getppid()); # signal changes to parent
+          untie %map;
+          print "done\n";
+          html_nice_answer($c,"Register done");
+        } elsif ($http_method eq 'GET' and $http_path eq "/resolve") {
+          my $outputurl = $map{$inputuri};
+          $outputurl = "" if (not defined($outputurl));
+          $cont = "<?xml version=\"1.0\" ?>\n\n";
+          if ($outputurl eq "") {
+           $cont .= "<unresolved />\n";
+          } else {
+           $cont .= "<url value=\"$outputurl\" />\n";
+          }
+          answer($c,$cont,"text/xml","");
         } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") {
             my $filename = $inputuri;
             $filename = $dtd_dir."/".$filename;
@@ -166,7 +202,7 @@ while (my $c = $d->accept) {
 	        $cont .= $_;
 	       }
                close(FD);
-               answer($c,$cont,"normal");
+               answer($c,$cont,"text/xml","");
             } else {
                die "Could not find DTD!";
             }
@@ -181,7 +217,7 @@ while (my $c = $d->accept) {
 	        $cont .= $_;
 	       }
                close(FD);
-               answer($c,$cont,"normal");
+               answer($c,$cont,"text/plain","");
             } else {
                die "Could not find Style Configuration File!";
             }
@@ -201,7 +237,7 @@ while (my $c = $d->accept) {
                 $cont .= $_;
                }
                close(FD);
-               answer($c,$cont,"normal");
+               answer($c,$cont,"text/xml","");
             } else {
                die "Could not find XSLT!";
             }
@@ -211,7 +247,7 @@ while (my $c = $d->accept) {
            mk_urls_of_uris();
            kill(USR1,getppid()); # signal changes to parent
            print " done\n";
-           answer($c,"<html><body><h1>Update done</h1></body></html>","normal");
+           html_nice_answer($c,"Update done");
         } elsif ($http_method eq 'GET' and $http_path eq "/ls") {
             # send back keys that begin with a given uri
            my ($uritype,$uripattern,$uriprefix);
@@ -230,23 +266,49 @@ while (my $c = $d->accept) {
            if ($uritype ne "invalid") { # uri is valid
             if (($outype ne 'txt') and ($outype ne 'xml')) { # invalid out type
              print "Invalid output type specified: $outype\n";
-             answer($c,"<html><body><h1>Invalid output type, may be ".
-              "\"txt\" or \"xml\"</h1></body></html>","normal");
+             html_nice_answer($c,"Invalid output type, must be ".
+              "'txt' or 'xml'");
             } else { # valid output
              print "BASEURI $baseuri, FORMAT $outype\n";
              $cont = finduris($uritype,$uripattern,$outype);
-             answer($c,$cont,"normal");
+             if ($outype eq 'txt') {
+              answer($c,$cont,"text/plain","");
+             } elsif ($outype eq 'xml') {
+              answer($c,$cont,"text/xml","");
+             } else {
+              die "Internal error, exiting!";
+             }
             }
            } else { # invalid uri
             print "Invalid uri: $baseuri, may begin with 'cic:', ".
              "'theory:' or '*:'\n";
-            answer($c,"<html><body><h1>Invalid uri , may begin with ".
-             "\"cic:\", \"theory:\" or \"*:\"</h1></body></html>","normal");
+            html_nice_answer($c,"Invalid uri , must begin with ".
+             "'cic:' or 'theory:'");
            }
         } elsif ($http_method eq 'GET' and $http_path eq "/help") {
-           print "Help requested!";
-           answer($c,"<html><body><h1>HTTP Getter Version ".
-            $VERSION."</h1></body></html>","normal");
+           print "Help requested!\n";
+           html_nice_answer($c,"HTTP Getter Version: $VERSION");
+        } elsif ($http_method eq 'GET' and $http_path =~ /\.cgi$/) {
+           print "CGI requested!\n";
+           if ($http_path !~ /^\/[^\/]*\.cgi$/) {
+            html_nice_answer($c,"Invalid CGI name: $http_path, ".
+            "you can't request CGI that contain a slash in the name\n");
+           } elsif (stat "$cgi_dir"."$http_path") {
+            if (not -x "$cgi_dir/$http_path") {
+             html_nice_answer($c,"CGI $http_path found but not ".
+              "executable\n");
+            } else { # exec CGI and anser back its output
+             my %old_ENV = %ENV;
+             %ENV = ();
+             $ENV{'QUERY_STRING'} = $http_query;
+             my $cgi_output = `$cgi_dir/$http_path`;
+             answer($c,$cgi_output,"","");
+             %ENV = %old_ENV;
+            }
+           } else {
+            html_nice_answer($c,"CGI '$http_path' not found ".
+             "in CGI dir '$cgi_dir'");
+           }
         } else {
             print "\n";
             print "INVALID REQUEST!!!!!\n";
@@ -271,21 +333,32 @@ sub finduris { # find uris for cic and theory trees generation
  my ($uri,$localpart,$basepart,$dirname,$suffix,$flags,$key);
  my (@itemz,@already_pushed_dir);
  my (%objects,%dirs); # map uris to suffixes' flags
+ #my $debug=1; # for debug
 
  print "FINDURIS, uritype: $uritype, uripattern: $uripattern, ".
-  "format: $format\n\n";
+  "format: $format\n\n" if defined($debug);
  
  if (($uritype eq "cic") or ($uritype eq "theory")) {
    # get info only of one type: cic or theory
   foreach (keys(%map)) { # select matching uris
    $uri = $_;
-   if ($uri =~ /^$uritype:$uripattern\//) {
-    $localpart = $uri;
-    $localpart =~ s/^$uritype:$uripattern\/(.*)/$1/;
+   if ($uri =~ /^$uritype:$uripattern(\/|$|\.)/) {
+    if ($uri =~ /^$uritype:$uripattern\//) { # directory match
+     $localpart = $uri;
+     $localpart =~ s/^$uritype:$uripattern\/(.*)/$1/;
+    } elsif ($uri =~ /^$uritype:$uripattern($|\.)/) { # file match
+     $localpart = $uri;
+     $localpart =~ s/^.*\/([^\/]*)/$1/;
+    } else {
+     die "Internal error, seems that requested match is none of ".
+      "directory match or file match";
+    }
+    print "LOCALPART: $localpart\n" if defined($debug);
 
     if ($localpart =~ /^[^\/]*$/) { # no slash, an OBJECT
      $basepart = $localpart;
-     $basepart =~ s/^([^.]*\.[^.]*)(\.types)?(\.ann)?/$1/; # remove exts .types or
+     $basepart =~ s/^([^.]*\.[^.]*)(\.types)?(\.ann)?/$1/;
+                                              # remove exts .types or
                                               # .types.ann
      $flags = $objects{$basepart}; # get old flags
      if ($localpart =~ /\.ann$/) {
@@ -321,8 +394,8 @@ sub finduris { # find uris for cic and theory trees generation
   }
  } elsif ($format eq "xml") { # XML output
   $content .= '<?xml version="1.0" encoding="ISO-8859-1"?>' . "\n";
-  $content .= '<!DOCTYPE ls SYSTEM ';
-  $content .= "$myownurl/getdtd?uri=ls.dtd>" . "\n\n";
+  $content .= "<!DOCTYPE ls SYSTEM ";
+  $content .= "\"$myownurl/getdtd?uri=ls.dtd\">" . "\n\n";
   $content .= "<ls>\n";
   foreach $key (sort(keys %dirs)) {
    $content .= "\t<section>$key</section>\n";
@@ -543,16 +616,28 @@ sub download {
 }
 
 sub answer {
- my ($c,$cont,$contype) = @_; # $contype must be "normal" or "gz"
+# answer the client setting content, Content-Type and Content-Enconding
+# of the answer
+ my ($c,$cont,$contype,$contenc) = @_;
  my $res = new HTTP::Response;
  $res->content($cont);
- $res->push_header("Content-Type" => "text/xml");
- if ($contype eq "gz") {
-  $res->push_header("Content-Encoding" => "x-gzip");
- }
+ $res->push_header("Content-Type" => $contype)
+   unless ($contype eq "");
+ $res->push_header("Content-Encoding" => $contenc)
+   unless ($contenc eq "");
+ $res->push_header("Cache-Control" => "no-cache");
+ $res->push_header("Pragma" => "no-cache");
+ $res->push_header("Expires" => "0");
  $c->send_response($res);
 }
 
+sub html_nice_answer {
+# answer the client whith a nice html document
+ my ($c,$content) = @_;
+ $content = "<html><body><h1>$content</h1></body></html>";
+ answer($c,$content,"text/html","");
+}
+
 sub helm_wget {
 #retrieve a file from an url and write it to a temp dir
 #used for retrieve resource index from servers
@@ -570,7 +655,7 @@ sub helm_wget {
 
 sub update {
  untie %map;
- tie(%map, 'DB_File', $uris_dbm.".db", O_RDONLY, 0664);
+ tie(%map, 'DB_File', $uris_dbm.".db", O_RDWR, 0664);
 }
 
 sub mk_urls_of_uris {
@@ -618,6 +703,6 @@ sub mk_urls_of_uris {
  }
 
  untie(%urls_of_uris);
- tie(%map, 'DB_File', $uris_dbm.".db", O_RDONLY, 0664);
+ tie(%map, 'DB_File', $uris_dbm.".db", O_RDWR, 0664);
 }