]> matita.cs.unibo.it Git - helm.git/blob - helm/http_getter/http_getter.pl.in
* Abst removed from the DTD
[helm.git] / helm / http_getter / http_getter.pl.in
1 #!@PERL_BINARY@
2
3 # Copyright (C) 2000, HELM Team.
4
5 # This file is part of HELM, an Hypertextual, Electronic
6 # Library of Mathematics, developed at the Computer Science
7 # Department, University of Bologna, Italy.
8
9 # HELM is free software; you can redistribute it and/or
10 # modify it under the terms of the GNU General Public License
11 # as published by the Free Software Foundation; either version 2
12 # of the License, or (at your option) any later version.
13
14 # HELM is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 # GNU General Public License for more details.
18
19 # You should have received a copy of the GNU General Public License
20 # along with HELM; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
22
23 # For details, see the HELM World-Wide-Web page,
24 # http://cs.unibo.it/helm/.
25
26 #use strict;
27
28 my $VERSION = "@VERSION@";
29
30 # various variables
31 my ($HELM_LIB_PATH);
32 my $cgi_dir = "@HELM_CGI_DIR@";
33 my (%xml_map, %rdf_map, %xslt_map);
34
35 # First of all, let's load HELM configuration
36 use Env;
37 my $HELM_LIB_DIR = $ENV{"HELM_LIB_DIR"};
38 # this should be the only fixed constant
39 my $DEFAULT_HELM_LIB_DIR = "@HELM_LIB_DIR@";
40 if (defined ($HELM_LIB_DIR)) {
41    $HELM_LIB_PATH = $HELM_LIB_DIR."/configuration.pl";
42 } else {
43    $HELM_LIB_PATH = $DEFAULT_HELM_LIB_DIR."/configuration.pl";
44 }
45
46 # next require defines: $helm_dir, $html_link, $dtd_dir, $uris_dbm, $indexname
47 require $HELM_LIB_PATH;
48
49 # TEMP: TODO put these vars in configuration file configuration.xml
50 # <move_to_conf_file>
51 my $cachemode = $ENV{'HTTP_GETTER_CACHE_MODE'} ||
52     'gzipped';
53 if (($cachemode ne 'gzipped') and ($cachemode ne 'normal')) {
54  die "Invalid HTTP_GETTER_CACHE_MODE environment variable, must be".
55  "'normal' or 'gzipped'\n";
56 }
57
58 my $helm_rdf_dir = $ENV{'HTTP_GETTER_RDF_DIR'} ||
59   "/usr/local/helm/rdf_library";
60 my $rdf_dbm = $ENV{'HTTP_GETTER_RDF_DBM'} ||
61   "/usr/local/helm/rdf_urls_of_uris.db";
62 my $xslt_dbm = $ENV{'HTTP_GETTER_XSLT_DBM'} ||
63   "/usr/local/helm/xslt_urls_of_uris.db";
64 my $rdf_indexname = $ENV{'HTTP_GETTER_RDF_INDEXNAME'} ||
65   "rdf_index.txt";
66 my $xslt_indexname = $ENV{'HTTP_GETTER_XSLT_INDEXNAME'} ||
67   "xslt_index.txt";
68 $servers_file = $ENV{'HTTP_GETTER_SERVERS_FILE'} || $servers_file;
69 $uris_dbm = $ENV{'HTTP_GETTER_URIS_DBM'} || $uris_dbm;
70   
71 # </move_to_conf_file>
72
73 # Let's override the configuration file
74 $style_dir = $ENV{"HELM_STYLE_DIR"} if (defined ($ENV{"HELM_STYLE_DIR"}));
75 $dtd_dir = $ENV{"HELM_DTD_DIR"} if (defined ($ENV{"HELM_DTD_DIR"}));
76
77 use HTTP::Daemon;
78 use HTTP::Status;
79 use HTTP::Request;
80 use LWP::UserAgent;
81 use DB_File;
82 use Compress::Zlib;
83 use CGI;
84 use URI;
85 use URI::Escape;
86
87 #CSC: mancano i controlli sulle condizioni di errore di molte funzioni
88 #CSC: ==> non e' robusto
89 #CSC: altra roba da sistemare segnata con CSC
90
91 my $d = new HTTP::Daemon LocalPort => 8081
92  or die "Error: port 8081 not available.";
93 my $myownurl = $d->url;
94
95 # Let's patch the returned URL
96 $myownurl =~ s/\/$//; # chop the final slash
97 my $myownport = $myownurl;
98 $myownport =~ s/http:\/\/(.*):(.*)/$2/;
99 $myownurl  =~ s/http:\/\/(.*):(.*)/$1/;
100 ($myownurl) = gethostbyname($myownurl);
101 $myownurl = "http://".$myownurl.":".$myownport;
102
103 tie(%xml_map, 'DB_File', $uris_dbm, O_RDWR, 0664); # open dbs
104 tie(%rdf_map, 'DB_File', $rdf_dbm, O_RDWR, 0664);
105 tie(%xslt_map, 'DB_File', $xslt_dbm, O_RDWR, 0664);
106
107 print "\n";
108 print "HTTP Getter $VERSION\n"; # print hello information
109 print "Please contact me at: <URL:", $myownurl."/", ">\n";
110 print "\n";
111 print "servers_file: $servers_file\n";
112 print "helm_dir: $helm_dir\n";
113 print "helm_rdf_dir: $helm_rdf_dir\n";
114 print "style_dir: $style_dir\n";
115 print "dtd_dir: $dtd_dir\n";
116 print "urls_of_uris db: $uris_dbm\n";
117 print "rdf db: $rdf_dbm\n";
118 print "xslt db: $xslt_dbm\n";
119 print "cache mode: $cachemode\n";
120 print "indexname: $indexname\n";
121 print "rdf_indexname: $rdf_indexname\n";
122 print "xslt_indexname: $xslt_indexname\n";
123 print "\n";
124
125 $SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes
126 $SIG{USR1} = \&update; # sent by the child to make the parent update
127
128 while (my $c = $d->accept) {
129  if (fork() == 0) {
130     while (my $r = $c->get_request) {
131         #CSC: mancano i controlli di sicurezza
132         
133         my $http_method = $r->method;
134         my $http_path = $r->url->path;
135         my $http_query = uri_unescape($r->url->query);
136         my $cgi = new CGI("$http_query");
137         my $inputuri = $cgi->param('uri');
138         print "\nRequest: ".$r->url."\n\n";
139
140         print "\nUnescaped query: ".$http_query."\n";
141
142          # "getxml" works with rdf uris
143         if ($http_method eq 'GET' and $http_path eq "/getxml") {
144             # finds the uri, url and filename
145
146             my $answerformat = $cgi->param('format');
147             my $patch_dtd = $cgi->param('patch_dtd');
148             $answerformat = "" if (not defined($answerformat));
149             $patch_dtd = "yes" if (not defined($patch_dtd));
150             if (($answerformat ne "gz") and ($answerformat ne "normal")
151                and ($answerformat ne "")) {
152              die "Wrong output format: $answerformat, must be 'normal' ".
153                  "or 'gz'\n";
154             }
155             if (($patch_dtd ne "yes") and ($patch_dtd ne "no")
156                and ($patch_dtd ne "")) {
157              die "Wrong param, patch_dtd must be 'yes' or 'no'\n";
158             }
159
160             my $filename = $inputuri;
161             my $prefix;
162             if (not isRdfUri($inputuri)) { # standad cic: or theory: uri
163              $filename =~ s/^cic:(.*)/$1/;
164              $filename =~ s/^theory:(.*)/$1/;
165             } else { # rdf uri
166              # The "helm:rdf/<<...>>//cic:" prefix is kept, but quoted
167              # (so that a "helm:rdf/<<...>>//cic:" dir is created
168              $prefix = $filename;
169              $filename =~ s/^(.*)\/\/cic:(.*)/$2/;
170              $filename =~ s/^(.*)\/\/theory:(.*)/$2/;
171              $prefix =~ s/\Q$filename\E//;
172              $prefix =~ s/_/__/g;
173              $prefix =~ s/\//_/g;
174              $filename = $prefix.$filename;
175             }
176
177             my $url = resolve ($inputuri); # resolve uri in url
178             if (not defined($url)) { # uri not found in uri2url map
179              die "NOT FOUND: uri \"$inputuri\" can't be resolved\n";
180              $c->send_error(RC_NOT_FOUND)
181             } else { # uri found and mapped to url
182               my $extension; # file extension
183               if ($url =~ /\.xml$/) { # non gzipped file
184                 $extension = ".xml";
185               } elsif ($url =~ /\.xml\.gz$/) { # gzipped file
186                 $extension = ".xml.gz";
187               } else { # error: unknown extension
188                die "unexpected extension in url: $url, might be '.xml'".
189                 "or '.xml.gz'";
190               }
191
192               if (not isRdfUri ($inputuri)) { # save in uri std cache dir
193                $filename = $helm_dir.$filename.$extension;
194               } else { # save in rdf metadata cache dir
195                $filename = $helm_rdf_dir."/".$filename.$extension;
196               }
197
198               print_request($inputuri,$url,$filename);
199
200               # Retrieves the file
201               my $ciccontent = download($patch_dtd,$url,$filename,$answerformat);
202
203               if ($answerformat eq "normal") { # answer the client in text/xml
204                answer($c,$ciccontent,"text/xml","");
205               } else { # answer the client in text/xml, gzip encoding
206                answer($c,$ciccontent,"text/xml","x-gzip");
207               }
208             }
209             
210                            # "/register" does not work with rdf uris
211         } elsif ($http_method eq 'GET' and $http_path eq "/register") {
212           my $inputurl = $cgi->param('url');
213           print "Register requested...\n";
214           $xml_map{$inputuri}=$inputurl;
215
216           # Now let's clean the cache
217           my $cicfilename = $inputuri;
218           $cicfilename =~ s/cic:(.*)/$1/;
219           $cicfilename =~ s/theory:(.*)/$1/;
220
221           print "Unlinking ".$helm_dir.$cicfilename.".xml[.gz]\n";
222           unlink ($helm_dir.$cicfilename.".xml");
223           unlink ($helm_dir.$cicfilename.".xml.gz");
224
225           kill(USR1,getppid()); # signal changes to parent
226           untie %xml_map;
227           print "done.\n";
228           html_nice_answer($c,"Register done");
229
230                                   # "/resolve" works with rdf uri
231         } elsif ($http_method eq 'GET' and $http_path eq "/resolve") {
232           #my $outputurl = $xml_map{$inputuri};
233           my $outputurl = resolve($inputuri);
234           $outputurl = "" if (not defined($outputurl));
235           $cont = "<?xml version=\"1.0\" ?>\n\n";
236           if ($outputurl eq "") {
237            $cont .= "<unresolved />\n";
238           } else {
239            $cont .= "<url value=\"$outputurl\" />\n";
240           }
241           answer($c,$cont,"text/xml","");
242
243         } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") {
244
245             my $filename = $inputuri;
246             $filename = $dtd_dir."/".$filename;
247             print "DTD: $inputuri ==> ($filename)\n";
248             if (stat($filename)) {
249                print "Using local copy\n";
250                open(FD, $filename) or die "Cannot open $filename\n";
251                $cont = "";
252                while(<FD>) {
253                 # Vary bad heuristic for substituion of absolute URLs
254                 # for relative ones
255                 s/ENTITY (.*) SYSTEM\s+"/ENTITY $1 SYSTEM "$myownurl\/getdtd?uri=/g;
256                 $cont .= $_;
257                }
258                close(FD);
259                answer($c,$cont,"text/xml","");
260             } else {
261                die "Could not find DTD!";
262             }
263
264         } elsif ($http_method eq 'GET' and $http_path eq "/getxslt") {
265
266           $url = $xslt_map{$inputuri};
267           print "Downloading XSLT ...\n";
268           helm_wget($tmp_dir, $url);
269           print "XSLT downloaded!\n";
270           $inputuri =~ s/.*\///;
271           my $filename = $tmp_dir . "/" . $inputuri;
272           my $cont;
273           die "Could not find XSLT!\n" unless stat($filename);
274           open(FD, $filename) or die "Can't open xslt local copy: '$filename'\n";
275           while(<FD>) {
276             s/xsl:import\s+href="/xsl:import href="$myownurl\/getxslt?uri=/g;
277             s/xsl:include\s+href="/xsl:include href="$myownurl\/getxslt?uri=/g;
278             $cont .= $_;
279           }
280           close(FD);
281           answer($c, $cont, "text/xml", "");
282           unlink $filename or
283             print "Can't unlink XSLT temp file '$filename'";
284
285 # <old_version>
286 #             my $filename = $inputuri;
287 #             $filename = $style_dir."/".$filename;
288 #             print "XSLT: $inputuri ==> ($filename)\n";
289 #             if (stat($filename)) {
290 #                print "Using local copy\n";
291 #                open(FD, $filename) or die "Cannot open $filename\n";
292 #                $cont = "";
293 #                while(<FD>) {
294 #                 # Vary bad heuristic for substituion of absolute URLs
295 #                 # for relative ones
296 #                 s/xsl:import\s+href="/xsl:import href="$myownurl\/getxslt?uri=/g ;
297 #                 s/xsl:include\s+href="/xsl:include href="$myownurl\/getxslt?uri=/g ;
298 #                 $cont .= $_;
299 #                }
300 #                close(FD);
301 #                answer($c,$cont,"text/xml","");
302 #             } else {
303 #                die "Could not find XSLT!";
304 #             }
305 # </old_version>
306
307                                     # "/update" works with rdf uri
308         } elsif ($http_method eq 'GET' and $http_path eq "/update") {
309             # rebuild urls_of_uris db and rdf uris db
310            print "Update requested...\n";
311            update_dbs();
312            kill(USR1,getppid()); # signal changes to parent
313            print " done\n";
314            html_nice_answer($c,"Update done");
315
316                                  # "/getalluris" does not work with rdf uris
317         } elsif ($http_method eq 'GET' and $http_path eq "/getalluris") {
318             # send back all the keys in xml
319             print "BASEURI $baseuri, FORMAT $outype\n";
320             $cont = getalluris();
321             answer($c,$cont,"text/xml","");
322
323                                  # "/getallrdfuris"
324         } elsif ($http_method eq 'GET' and $http_path eq "/getallrdfuris") {
325             # send back all the keys in xml
326             print "BASEURI $baseuri, FORMAT $outype\n";
327             $cont = getallrdfuris();
328             answer($c,$cont,"text/xml","");
329
330         } elsif ($http_method eq 'GET' and $http_path eq "/ls") {
331             # send back keys that begin with a given uri
332            my ($uritype,$uripattern,$uriprefix);
333            my $baseuri = $cgi->param('baseuri');
334            chop $baseuri if ($baseuri =~ /.*\/$/); # remove trailing "/"
335                          # output type, might be 'txt' or 'xml':
336            my $outype = $cgi->param('format');
337            $uripattern = $baseuri;
338            $uripattern =~ s/^.*:(.*)/$1/;
339            if ($baseuri =~ /^cic:/) {
340             $uritype = "cic";
341            } elsif ($baseuri =~ /^theory:/) {
342             $uritype = "theory";
343            } else {
344             $uritype = "invalid";
345            }
346            if ($uritype ne "invalid") { # uri is valid
347             if (($outype ne 'txt') and ($outype ne 'xml')) { # invalid out type
348              print "Invalid output type specified: $outype\n";
349              html_nice_answer($c,"Invalid output type, must be ".
350               "'txt' or 'xml'");
351             } else { # valid output
352              print "BASEURI $baseuri, FORMAT $outype\n";
353              $cont = finduris($uritype,$uripattern,$outype);
354              if ($outype eq 'txt') {
355               answer($c,$cont,"text/plain","");
356              } elsif ($outype eq 'xml') {
357               answer($c,$cont,"text/xml","");
358              } else {
359               die "Internal error, exiting!";
360              }
361             }
362            } else { # invalid uri
363             print "Invalid uri: $baseuri, may begin with 'cic:', ".
364              "'theory:' or '*:'\n";
365             html_nice_answer($c,"Invalid uri , must begin with ".
366              "'cic:' or 'theory:'");
367            }
368
369         } elsif ($http_method eq 'GET' and $http_path eq "/help") {
370           # help request
371            print "Help requested!\n";
372            html_nice_answer($c,"HTTP Getter Version: $VERSION");
373
374         } elsif ($http_method eq 'GET' and $http_path eq "/getempty") {
375           # return an empty, but valid, xml document
376           my $emptyxml = <<EOXML;
377 <?xml version="1.0"?>
378 <!DOCTYPE empty [
379   <!ELEMENT empty EMPTY>
380 ]>
381 <empty />
382 EOXML
383           answer($c, $emptyxml, "", "");
384
385         } elsif ($http_method eq 'GET' and $http_path =~ /\.cgi$/) {
386           # cgi handling
387            print "CGI requested!\n";
388            if ($http_path !~ /^\/[^\/]*\.cgi$/) {
389             html_nice_answer($c,"Invalid CGI name: $http_path, ".
390             "you can't request CGI that contain a slash in the name\n");
391            } elsif (stat "$cgi_dir"."$http_path") {
392             if (not -x "$cgi_dir/$http_path") {
393              html_nice_answer($c,"CGI $http_path found but not ".
394               "executable\n");
395             } else { # exec CGI and anser back its output
396              my %old_ENV = %ENV;
397              %ENV = ();
398              $ENV{'QUERY_STRING'} = $http_query;
399              my $cgi_output = `$cgi_dir/$http_path`;
400              answer($c,$cgi_output,"","");
401              %ENV = %old_ENV;
402             }
403            } else {
404             html_nice_answer($c,"CGI '$http_path' not found ".
405              "in CGI dir '$cgi_dir'");
406            }
407
408         } else { # unsupported request
409             print "\n";
410             print "INVALID REQUEST!!!!!\n";
411             print "(PATH: ",$http_path,", ";
412             print "QUERY: ",$http_query,")\n";
413             $c->send_error(RC_FORBIDDEN)
414         }
415
416         print "\nRequest solved: ".$r->url."\n\n";
417     }
418
419     $c->close;
420     undef($c);
421     print "\nCONNECTION CLOSED\n\n";
422     exit;
423   } # fork
424 }
425
426 #================================
427
428 sub isRdfUri { # return true if the uri is an rdf uri, false otherwise
429 # typycal rdf uri:
430 # helm:rdf/cic:www.cs.unibo.it/helm/rdf/foo_schema//cic:\
431 #  /Coq/Init/Logic/True_rec.con.types
432 #
433 # the format is "helm:rdf/<metadata_tree>:<metadata_scheme>//<xml_file_uri>"
434 #
435  my ($uri) = @_;
436  if ($uri =~ /^helm:rdf(.*):(.*)\/\/(.*)/) {
437   return 1;
438  } else {
439   return 0;
440  }
441 }
442
443 sub resolve { # resolve an uri in a url, work both with standard cic: or theory:
444               # uris and rdf uris
445  print "RESOLVE subroutine\n";
446  my ($uri) = @_;
447  print "GIVEN URI: \"$uri\"\n";
448  if (isRdfUri ($uri)) { # rdf uri, resolve using rdf db
449   print "IS A RDF URI\n";
450   print "I WILL RETURN '$rdf_map{$uri}'\n";
451   return ($rdf_map{$uri});
452  } else { # standard cic: or theory: uri, resolve using std uri db
453   print "IS NOT A RDF URI\n";
454   print "I WILL RETURN '$xml_map{$uri}'\n";
455   return ($xml_map{$uri});
456  }
457 }
458
459 sub getalluris { # get all the keys whose prefix is cic
460  my $content = "";
461  my ($uri);
462  my $debug=1; # for debug
463
464   $content .= '<?xml version="1.0" encoding="ISO-8859-1"?>' . "\n";
465   $content .= "<!DOCTYPE alluris SYSTEM ";
466   $content .= "\"$myownurl/getdtd?uri=alluris.dtd\">" . "\n\n";
467   $content .= "<alluris>\n";
468   foreach $uri (sort (keys(%xml_map))) { # select matching uris
469    if ($uri =~ /^cic:/ && not $uri =~ /.types$/) {
470     print "GETALLURI: $uri\n" if defined($debug);
471     $content .= "\t<uri value=\"$uri\"/>\n";
472    }
473   }
474   $content .= "</alluris>\n";
475  return $content;
476 }
477
478 sub getallrdfuris {
479  my $content = "";
480  my ($uri);
481  my $debug=1; # for debug
482
483   $content .= '<?xml version="1.0" encoding="ISO-8859-1"?>' . "\n";
484   $content .= "<!DOCTYPE allrdfuris SYSTEM ";
485   $content .= "\"$myownurl/getdtd?uri=alluris.dtd\">" . "\n\n";
486   $content .= "<allrdfuris>\n";
487   foreach $uri (sort (keys(%rdf_map))) {
488    print "GETALLRDFURI: $uri\n" if defined($debug);
489    $content .= "\t<uri value=\"$uri\"/>\n";
490   }
491   $content .= "</allrdfuris>\n";
492  return $content;
493 }
494
495 sub finduris { # find uris for cic and theory trees generation
496  my ($uritype,$uripattern,$format) = @_;
497  my $content = "";
498  my ($uri,$localpart,$basepart,$dirname,$suffix,$flags,$key);
499  my (@itemz,@already_pushed_dir);
500  my (%objects,%dirs); # map uris to suffixes' flags
501  my $debug=1; # for debug
502
503  print "FINDURIS, uritype: $uritype, uripattern: $uripattern, ".
504   "format: $format\n\n" if defined($debug);
505  
506  if (($uritype eq "cic") or ($uritype eq "theory")) {
507    # get info only of one type: cic or theory
508   foreach (keys(%xml_map)) { # select matching uris
509    $uri = $_;
510    if ($uri =~ /^$uritype:$uripattern(\/|$|\.)/) {
511     if ($uri =~ /^$uritype:$uripattern\//) { # directory match
512      $localpart = $uri;
513      $localpart =~ s/^$uritype:$uripattern\/(.*)/$1/;
514     } elsif ($uri =~ /^$uritype:$uripattern($|\.)/) { # file match
515      $localpart = $uri;
516      $localpart =~ s/^.*\/([^\/]*)/$1/;
517     } else {
518      die "Internal error, seems that requested match is none of ".
519       "directory match or file match";
520     }
521     print "LOCALPART: $localpart\n" if defined($debug);
522
523     if ($localpart =~ /^[^\/]*$/) { # no slash, an OBJECT
524      $basepart = $localpart;
525      $basepart =~ s/^([^.]*\.[^.]*)(\.types)?(\.ann)?/$1/;
526                                               # remove exts .types or
527                                               # .types.ann
528      $flags = $objects{$basepart}; # get old flags
529      if ($localpart =~ /\.ann$/) {
530       $flags = add_flag("ann","YES",$flags);
531      } else {
532       $flags = add_flag("ann","NO",$flags);
533      }
534      if ($localpart =~ /\.types$/) {
535       $flags = add_flag("types","YES",$flags);
536      } elsif ($localpart =~ /\.types\.ann$/) {
537       $flags = add_flag("types","ANN",$flags);
538      } else {
539       $flags = add_flag("types","NO",$flags);
540      }
541      $objects{$basepart} = $flags; # save new flags
542     } else { # exists at least one slash, a DIR
543      ($dirname) = split (/\//, $localpart);
544      $dirs{$dirname} = ""; # no flags requirement for dir
545     }
546    }
547   }
548  } else {
549   die "getter internal error: unsupported uritype: \"$uritype\"";
550  }
551                             # now generate OUTPUT:
552                             # output will be saved in $content
553  if ($format eq "txt") { # TXT output
554   foreach $key (sort(keys %dirs)) {
555    $content .= "dir, " . $key . "\n";
556   }
557   foreach $key (sort(keys %objects)) {
558    $content .= "object, $key, " . $objects{$key} . "\n";
559   }
560  } elsif ($format eq "xml") { # XML output
561   $content .= '<?xml version="1.0" encoding="ISO-8859-1"?>' . "\n";
562   $content .= "<!DOCTYPE ls SYSTEM ";
563   $content .= "\"$myownurl/getdtd?uri=ls.dtd\">" . "\n\n";
564   $content .= "<ls>\n";
565   foreach $key (sort(keys %dirs)) {
566    $content .= "\t<section>$key</section>\n";
567   }
568   foreach $key (sort(keys %objects)) {
569    $content .= "\t<object name=\"$key\">\n";
570    $flags = $objects{$key};
571    $flags =~ s/^<(.*)>$/$1/;
572    my ($annflag,$typesflag) = split /,/,$flags;
573    $content .= "\t\t<ann value=\"$annflag\" />\n";
574    $content .= "\t\t<types value=\"$typesflag\" />\n";
575    $content .= "\t</object>\n";
576   }
577   $content .= "</ls>\n";
578  } else { # may not enter this branch
579   die "Getter internal error: invalid format received by finduris sub";
580  }
581  return $content;
582 }
583
584 sub add_flag {
585 # manage string like: "<ann_flag,type_flag>"
586 # "ann_flag" may be one of "ann_YES", "ann_NO"
587 # "type_flag" may be one of "types_NO", "types_YES", "types_ANN"
588 # when adding a flag the max between the current flag and the new flag
589 # is taken, the orders are ann_NO < ann_YES and types_NO < types_YES <
590 # types_ANN
591  my ($flagtype,$newflag,$str) = @_;
592  $str = "<,>" if ($str eq "");
593  ($str =~ s/^<(.*,.*)>$/$1/) or die "Internal error: ".
594    "wrong string format for flag adding in $str";
595  my ($annflag,$typeflag) = split /,/,$str;
596  if ($flagtype eq "ann") { # ANN flag handling
597   if ($newflag eq "YES") {
598    $annflag = "YES";
599   } elsif ($newflag eq "NO") {
600    $annflag = "NO" unless ($annflag eq "YES");
601   } else {
602    die "Internal error: annflag must be \"YES\" or \"NO\"";
603   }
604  } elsif ($flagtype eq "types") { # TYPES flag handling
605   if ($newflag eq "ANN") {
606    $typeflag = "ANN";
607   } elsif ($newflag eq "YES") {
608    $typeflag = "YES" unless ($typeflag eq "ANN");
609   } elsif ($newflag eq "NO") {
610    $typeflag = "NO"
611      unless (($typeflag eq "ANN") or ($typeflag eq "YES"));
612   } else {
613    die "Internal error: typeflag must be \"YES\", \"NO\" or \"ANN\"";
614   }
615  } else {
616   die "Internal error: unsupported flagtype \"$flagtype\"";
617  }
618  $str = "<$annflag,$typeflag>";
619 }
620
621 #CSC: Too much powerful: creates even /home, /home/users/, ...
622 #CSC: Does not raise errors if could not create dirs/files
623 sub mkdirs
624 {
625  my ($pathname) = @_;
626  my @dirs = split /\//,$pathname;
627  my $tmp;
628  foreach $dir (@dirs) {
629   $tmp = ((defined($tmp)) ?  $tmp."\/".$dir : "");
630   mkdir($tmp,0777);
631  }
632  rmdir($tmp);
633 }
634
635 sub print_request
636 {
637  my ($uri,$url,$filename) = @_;
638  print "<download_request>\n";
639  print "uri: $uri\n";
640  print "url: $url\n";
641  print "filename: $filename\n\n";
642  print "</download_request>\n";
643 }
644
645 sub gunzip { # gunzip a file and return the deflated content
646         my ($filename) = @_;
647
648         my ($gz, $buffer, $cont);
649
650         print "deflating $filename ...\n";
651         $gz = gzopen($filename, "r")
652                 or die "Cannot open gzip'ed file $filename: $gzerrno";
653         $cont = "";
654         while ( $gz->gzread($buffer) > 0 ) {
655                 $cont .= $buffer;
656         }
657         die "Error while reading : $gzerrno\n" if $gzerrno != Z_STREAM_END ;
658         $gz->gzclose();
659
660         return $cont;
661 }
662
663 sub gzip {      # gzip the content argument and save it to filename argument
664         my ($cont, $filename) = @_;
665  #my $debug=1; # debug only
666
667  print "gzopening $filename ...\n" if (defined($debug));
668         my $gz = gzopen($filename, "w")
669                 or die "Cannot gzopen for writing file $filename: $gzerrno";
670  print "gzwriting ...\n" if (defined($debug));
671         $gz->gzwrite($cont) or die "error writing: $gzerrno, exiting!\n";
672  print "gzclosing ...\n" if (defined($debug));
673         $gz->gzclose();
674 }
675
676 sub download {
677  my ($patch_dtd,$url,$filename,$format) = @_;
678  my ($gz, $buffer);
679
680 # print "DOWNLOAD subs receives url: \"$url\"\n";
681 # print "DOWNLOAD subs receives filename: \"$filename\"\n";
682
683  my $resourcetype;      # retrieve mode: "normal" (.xml) or "gzipped" (.xml.gz)
684  if ($filename =~ /\.xml$/) {   # set retrieve mode
685          $resourcetype = "normal";
686  } elsif ($filename =~ /\.xml\.gz$/) {
687          $resourcetype = "gzipped";
688  } else {
689          die "Unsupported download extension, might be '.gz' or '.xml'\n";
690  }
691  my $basefname = $filename;
692  $basefname =~ s/\.gz$//;       # get base resource name removing trailing .gz
693  $cont = ""; # modified by side-effect by the callback function
694
695  my $localfname="";
696  if (stat($basefname)) {
697         $localfname=$basefname;
698  } elsif (stat($basefname.".gz")) {
699         $localfname=$basefname.".gz";
700  }
701  if ($localfname ne "") { # we already have local copy of requested file
702       # check both possible cache entry: gzipped or normal
703   print "Using local copy.\n";
704   if ($localfname =~ /\.xml\.gz$/) { # deflating cached file and return it
705    $cont = gunzip($localfname);
706   } elsif ($localfname =~ /\.xml$/) { # just return cached file
707    open(FD, $localfname) or die "Cannot open $localfname";
708    while(<FD>) { $cont .= $_; }
709    close(FD);
710   } else { # error
711    die "Internal error: unexpected file name $localfname,"
712    ."must end with '.gz' or '.xml.gz'\n";
713   }
714  } else { # download file from net
715    print "Downloading file ...\n"; # download file
716    my $ua = LWP::UserAgent->new;
717    my $request = HTTP::Request->new(GET => "$url");
718    my $response = $ua->request($request, \&callback);
719    
720    # cache retrieved file to disk
721    # <ZACK/> TODO: inefficent, I haven't yet undestood how to deflate
722    #    in memory gzipped file, without call "gzopen"
723    print "Storing file ...\n";
724 #   print "Making dirs ...\n";
725    mkdirs($filename);
726 #   print "Opening tmp file for writing ...\n";
727    open(FD, ">".$filename.".tmp") or die "Cannot open $filename.tmp\n";
728 #   print "Writing on tmp file ...\n";
729    print FD $cont;
730 #   print "Closing tmp file ...\n";
731    close(FD);
732
733    # handle cache conversion normal->gzipped or gzipped->normal as user choice
734    print "cachemode:$cachemode, resourcetype:$resourcetype\n"
735     if (defined($debug));
736    if (($cachemode eq 'normal') and ($resourcetype eq 'normal')) {
737      # cache the file as is
738     rename "$filename.tmp", $filename; 
739    } elsif (($cachemode eq 'gzipped') and ($resourcetype eq 'gzipped')) {
740      # cache the file as is
741      # and update the $cont variabile with deflated content
742     rename "$filename.tmp", $filename; 
743     $cont = gunzip($filename);
744    } elsif (($cachemode eq 'normal') and ($resourcetype eq 'gzipped')) {
745      # deflate cache entry
746      # and update $cont
747     open(FD, "> $basefname") or die "cannot open $basefname\n";
748     $cont = gunzip($filename.".tmp");
749     print FD $cont;
750     close(FD);
751     unlink "$filename.tmp"; # delete old gzipped file
752    } elsif (($cachemode eq 'gzipped') and ($resourcetype eq 'normal')) {
753      # compress cache entry
754     print "gzipping ...\n" if (defined($debug));
755     gzip($cont, $basefname.".gz");
756     unlink "$filename.tmp"; # delete old uncompressed file
757    } else {
758     die "Internal error, unsopported cachemode, resourcetype couple\n";
759    }
760    # $cont now contained uncompressed data
761  }
762  if ($patch_dtd eq "yes") {
763     $cont =~ s/DOCTYPE (.*) SYSTEM\s+"http:\/\/www.cs.unibo.it\/helm\/dtd\//DOCTYPE $1 SYSTEM "$myownurl\/getdtd?uri=/g;
764  }
765  if ($format eq "gz") {
766   gzip($cont,"$basefname.tmp");
767   open (TMP, "< $basefname.tmp")
768    or die "Can't open tempfile: $filename.tmp, exiting!\n";
769   $cont = "";
770   while(<TMP>) {
771    $cont .= $_;
772   }
773   close TMP;
774   unlink ($basefname . ".tmp") or
775    die "cannot unlink temporary file: $basefname.tmp\n";
776  }
777
778  return $cont;
779 }
780
781 sub answer {
782 # answer the client setting content, Content-Type and Content-Enconding
783 # of the answer
784  my ($c,$cont,$contype,$contenc) = @_;
785  my $res = new HTTP::Response;
786  $res->content($cont);
787  $res->push_header("Content-Type" => $contype)
788    unless ($contype eq "");
789  $res->push_header("Content-Encoding" => $contenc)
790    unless ($contenc eq "");
791  $res->push_header("Cache-Control" => "no-cache");
792  $res->push_header("Pragma" => "no-cache");
793  $res->push_header("Expires" => "0");
794  $c->send_response($res);
795 }
796
797 sub html_nice_answer {
798 # answer the client whith a nice html document
799  my ($c,$content) = @_;
800  $content = "<html><body><h1>$content</h1></body></html>";
801  answer($c,$content,"text/html","");
802 }
803
804 sub callback {
805  my ($data) = @_;
806  $cont .= $data;
807 }
808
809 sub helm_wget {
810 # retrieve a file from an url and write it to a temp dir
811 # used for retrieve resource index from servers
812  $cont = "";
813  my ($prefix, $URL) = @_;
814  my $ua = LWP::UserAgent->new;
815  my $request = HTTP::Request->new(GET => "$URL");
816  my $response = $ua->request($request, \&callback);
817  my ($filename) = reverse (split "/", $URL); # get filename part of the URL
818  open (TEMP, "> $prefix/$filename")
819   || die "Cannot open temporary file: $prefix/$filename\n";
820  print TEMP $cont;
821  close TEMP;
822 }
823
824 sub update {
825 # retie dbs
826  untie %xml_map;
827  tie(%xml_map, 'DB_File', $uris_dbm, O_RDWR, 0664);
828  untie %rdf_map;
829  tie(%rdf_map, 'DB_File', $rdf_dbm, O_RDWR, 0664);
830  untie %xslt_map;
831  tie(%xslt_map, 'DB_File', $xslt_dbm, O_RDWR, 0664);
832 }
833
834 sub update_dbs {
835 # rebuild dbs fetching resource indexes from servers.
836 # Rebuild urls_of_uris db (1), rdf db (2) and xslt db (3)
837  my (
838   $server, $idxfile, $rdf_idxfile, $uri, $url, $comp, $line,
839   @servers,
840   %urls_of_uris, %rdf, %xslt # local proxy of dbs
841  );
842
843  untie %xml_map;
844  untie %rdf_map;
845  untie %xslt_map;
846  foreach my $file ($uris_dbm, $rdf_dbm, $xslt_dbm) { # remove old db file
847   if (stat $file) { # remove if exists
848    unlink ($file) or die "can't unlink old db file: $file\n";
849   }
850  }
851  tie(%urls_of_uris, 'DB_File', $uris_dbm, O_RDWR|O_CREAT, 0664);
852  tie(%rdf, 'DB_File', $rdf_dbm, O_RDWR|O_CREAT, 0664);
853  tie(%xslt, 'DB_File', $xslt_dbm, O_RDWR|O_CREAT, 0664);
854
855  open (SRVS, "< $servers_file") or
856   die "cannot open servers file: $servers_file\n";
857  @servers = <SRVS>; # read all servers
858  close (SRVS);
859
860  while ($server = pop @servers) { # cicle on servers in _reverse_ order
861   print "processing server: $server ...\n";
862   chomp $server;
863   helm_wget($tmp_dir, $server."/".$indexname); # get index
864   helm_wget($tmp_dir, $server."/".$rdf_indexname); # get rdf index
865   helm_wget($tmp_dir, $server."/".$xslt_indexname); # get xslt index
866   $idxfile = $tmp_dir."/".$indexname;
867   $rdf_idxfile = $tmp_dir."/".$rdf_indexname;
868   $xslt_idxfile = $tmp_dir . "/" . $xslt_indexname;
869
870                   # (1) REBUILD URLS_OF_URIS DB
871   open (INDEX, "< $idxfile") or
872    die "cannot open temporary index file: $idxfile\n";
873   while (my $line = <INDEX>) {  # parse index and add entry to urls_of_uris db
874    chomp $line;
875    ($uri,$comp) = split /[ \t]+/, $line;
876              # build url:
877    if ($comp =~ /gz/) { 
878     $url = $uri . ".xml" . ".gz";
879    } else {
880     $url = $uri . ".xml";
881    }
882    $url =~ s/cic:/$server/;
883    $url =~ s/theory:/$server/;
884    $urls_of_uris{$uri} = $url;
885   }
886
887                   # (2) REBUILD RDF DB
888   open (RDF_INDEX, "< $rdf_idxfile") or
889    die "cannot open temporary RDF index file: $rdf_idxfile\n";
890   while (my $line = <RDF_INDEX>) {  # parse index and add entry to rdf db
891    chomp $line;
892    ($uri,$comp) = split /[ \t]+/, $line; # comp is "gz" or nothing
893              # build url:
894    if ($comp =~ /gz/) { 
895     $url = $uri . ".xml" . ".gz";
896    } else {
897     $url = $uri . ".xml";
898    }
899    $url =~ s/^helm:rdf(.*)\/\/cic:/$server/;
900    $url =~ s/^helm:rdf(.*)\/\/theory:/$server/;
901    $rdf{$uri} = $url;
902   }
903
904                   # (3) REBUILD XSLT DB
905   open (XSLT_INDEX, "< $xslt_idxfile") or
906     die "cannot open temporary XSLT index file: $xslt_idxfile\n";
907   while (my $line = <XSLT_INDEX>) { # parse index and add entry to xslt db
908     chomp $line;
909     my $stylesheet = $line;
910     my $url = $server . "/" . $stylesheet;
911     $xslt{$stylesheet} = $url;
912   }
913
914   close INDEX;  # close indexes
915   close RDF_INDEX;
916   close XSLT_INDEX;
917
918                   # remove temp files
919   foreach my $file ($idxfile, $rdf_idxfile, $xslt_idxfile) {
920     print "cannot unlink temporary file: $file\n" if (unlink $file) != 1;
921   }
922
923  }
924
925  untie(%urls_of_uris); # untie local proxies
926  untie(%rdf);
927  untie(%xslt);
928  tie(%xml_map, 'DB_File', $uris_dbm, O_RDWR, 0664); # retie global ones
929  tie(%rdf_map, 'DB_File', $rdf_dbm, O_RDWR, 0664);
930  tie(%xslt_map, 'DB_File', $xslt_dbm, O_RDWR, 0664);
931
932 } # update_dbs
933
934 # vim modline: do not remove!
935 # vim: set ft=perl:
936