X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhttp_getter%2Fhttp_getter.pl.in;h=e9d1f4a3e04609137ad68b8db5658759be797f81;hb=5d7d6bd5090f3f82279bef0b93b4b361a5b1d751;hp=cf2052a0236c345db549da9762485735c411657c;hpb=e8f0da12ea20a97083be016fc4e2a09688f786c8;p=helm.git diff --git a/helm/http_getter/http_getter.pl.in b/helm/http_getter/http_getter.pl.in index cf2052a02..e9d1f4a3e 100755 --- a/helm/http_getter/http_getter.pl.in +++ b/helm/http_getter/http_getter.pl.in @@ -30,7 +30,7 @@ my $VERSION = "@VERSION@"; # various variables my ($HELM_LIB_PATH); my $cgi_dir = "@HELM_CGI_DIR@"; -my (%map, %rdf_map); +my (%xml_map, %rdf_map, %xslt_map); # First of all, let's load HELM configuration use Env; @@ -54,12 +54,17 @@ if (($cachemode ne 'gzipped') and ($cachemode ne 'normal')) { die "Invalid HTTP_GETTER_CACHE_MODE environment variable, must be". "'normal' or 'gzipped'\n"; } -my $helm_rdf_dir = $ENV{'HTTP_GETTER_RDF_DIR'} || - "/usr/local/helm/rdf_library"; -my $rdf_dbm = $ENV{'HTTP_GETTER_RDF_DBM'} || - "/usr/local/helm/rdf_urls_of_uris"; -my $rdf_indexname = $ENV{'HTTP_GETTER_RDF_INDEXNAME'} || - "rdf_index.txt"; + +$helm_rdf_dir = $ENV{'HTTP_GETTER_RDF_DIR'} || $helm_rdf_dir; +$rdf_dbm = $ENV{'HTTP_GETTER_RDF_DBM'} || $rdf_dbm; +$xslt_dbm = $ENV{'HTTP_GETTER_XSLT_DBM'} || $xslt_dbm; +$rdf_indexname = $ENV{'HTTP_GETTER_RDF_INDEXNAME'} || $rdf_indexname; +$xslt_indexname = $ENV{'HTTP_GETTER_XSLT_INDEXNAME'} || $xslt_indexname; +$servers_file = $ENV{'HTTP_GETTER_SERVERS_FILE'} || $servers_file; +$uris_dbm = $ENV{'HTTP_GETTER_URIS_DBM'} || $uris_dbm; +$dtdbaseurl = $ENV{'HTTP_GETTER_DTD_BASE_URL'} || $dtdbaseurl; +$getterport = $ENV{'HTTP_GETTER_PORT'} || $getterport; + # # Let's override the configuration file @@ -73,14 +78,15 @@ use LWP::UserAgent; use DB_File; use Compress::Zlib; use CGI; +use URI; use URI::Escape; #CSC: mancano i controlli sulle condizioni di errore di molte funzioni #CSC: ==> non e' robusto #CSC: altra roba da sistemare segnata con CSC -my $d = new HTTP::Daemon LocalPort => 8081 - or die "Error: port 8081 not available."; +my $d = new HTTP::Daemon LocalPort => $getterport + or die "Error: port $getterport not available."; my $myownurl = $d->url; # Let's patch the returned URL @@ -91,22 +97,28 @@ $myownurl =~ s/http:\/\/(.*):(.*)/$1/; ($myownurl) = gethostbyname($myownurl); $myownurl = "http://".$myownurl.":".$myownport; -tie(%map, 'DB_File', $uris_dbm.".db", O_RDWR, 0664); # open dbs -tie(%rdf_map, 'DB_File', $rdf_dbm.".db", O_RDWR, 0664); +tie(%xml_map, 'DB_File', $uris_dbm, O_RDWR, 0664); # open dbs +tie(%rdf_map, 'DB_File', $rdf_dbm, O_RDWR, 0664); +tie(%xslt_map, 'DB_File', $xslt_dbm, O_RDWR, 0664); print "\n"; print "HTTP Getter $VERSION\n"; # print hello information print "Please contact me at: \n"; print "\n"; +print "servers_file: $servers_file\n"; print "helm_dir: $helm_dir\n"; print "helm_rdf_dir: $helm_rdf_dir\n"; print "style_dir: $style_dir\n"; print "dtd_dir: $dtd_dir\n"; -print "urls_of_uris db: $uris_dbm.db\n"; -print "rdf db: $rdf_dbm.db\n"; +print "urls_of_uris db: $uris_dbm\n"; +print "rdf db: $rdf_dbm\n"; +print "xslt db: $xslt_dbm\n"; print "cache mode: $cachemode\n"; print "indexname: $indexname\n"; print "rdf_indexname: $rdf_indexname\n"; +print "xslt_indexname: $xslt_indexname\n"; +print "dtdbaseurl: $dtdbaseurl\n"; +print "getterport: $getterport\n"; print "\n"; $SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes @@ -198,7 +210,7 @@ while (my $c = $d->accept) { } elsif ($http_method eq 'GET' and $http_path eq "/register") { my $inputurl = $cgi->param('url'); print "Register requested...\n"; - $map{$inputuri}=$inputurl; + $xml_map{$inputuri}=$inputurl; # Now let's clean the cache my $cicfilename = $inputuri; @@ -210,13 +222,13 @@ while (my $c = $d->accept) { unlink ($helm_dir.$cicfilename.".xml.gz"); kill(USR1,getppid()); # signal changes to parent - untie %map; + untie %xml_map; print "done.\n"; html_nice_answer($c,"Register done"); # "/resolve" works with rdf uri } elsif ($http_method eq 'GET' and $http_path eq "/resolve") { - #my $outputurl = $map{$inputuri}; + #my $outputurl = $xml_map{$inputuri}; my $outputurl = resolve($inputuri); $outputurl = "" if (not defined($outputurl)); $cont = "\n\n"; @@ -229,45 +241,9 @@ while (my $c = $d->accept) { } elsif ($http_method eq 'GET' and $http_path eq "/getdtd") { -# my $filename = $inputuri; -# $filename = $dtd_dir."/".$filename; -# print "DTD: $inputuri ==> ($filename)\n"; -# if (stat($filename)) { -# print "Using local copy\n"; -# open(FD, $filename) or die "Cannot open $filename\n"; -# $cont = ""; -# while() { -# # Vary bad heuristic for substituion of absolute URLs -# # for relative ones -# s/ENTITY (.*) SYSTEM\s+"/ENTITY $1 SYSTEM "$myownurl\/getdtd?uri=/g; -# $cont .= $_; -# } -# close(FD); -# answer($c,$cont,"text/xml",""); -# } else { -# die "Could not find DTD!"; -# } - - } elsif ($http_method eq 'GET' and $http_path eq "/getstyleconf") { my $filename = $inputuri; - $filename = $style_dir."/config/".$filename; - if (stat($filename)) { - open(FD, $filename) or die "Cannot open $filename\n"; - $cont = ""; - while() { - s/DOCTYPE (.*) SYSTEM\s+"/DOCTYPE $1 SYSTEM "$myownurl\/getstyleconf?uri=/g; - $cont .= $_; - } - close(FD); - answer($c,$cont,"text/plain",""); - } else { - die "Could not find Style Configuration File!"; - } - - } elsif ($http_method eq 'GET' and $http_path eq "/getxslt") { - my $filename = $inputuri; - $filename = $style_dir."/".$filename; - print "XSLT: $inputuri ==> ($filename)\n"; + $filename = $dtd_dir."/".$filename; + print "DTD: $inputuri ==> ($filename)\n"; if (stat($filename)) { print "Using local copy\n"; open(FD, $filename) or die "Cannot open $filename\n"; @@ -275,16 +251,58 @@ while (my $c = $d->accept) { while() { # Vary bad heuristic for substituion of absolute URLs # for relative ones - s/xsl:import\s+href="/xsl:import href="$myownurl\/getxslt?uri=/g ; - s/xsl:include\s+href="/xsl:include href="$myownurl\/getxslt?uri=/g ; - $cont .= $_; - } + s/ENTITY (.*) SYSTEM\s+"/ENTITY $1 SYSTEM "$myownurl\/getdtd?uri=/g; + $cont .= $_; + } close(FD); answer($c,$cont,"text/xml",""); } else { - die "Could not find XSLT!"; + die "Could not find DTD!"; } + } elsif ($http_method eq 'GET' and $http_path eq "/getxslt") { + + $url = $xslt_map{$inputuri}; + print "Downloading XSLT ...\n"; + helm_wget($tmp_dir, $url); + print "XSLT downloaded!\n"; + $inputuri =~ s/.*\///; + my $filename = $tmp_dir . "/" . $inputuri; + my $cont; + die "Could not find XSLT!\n" unless stat($filename); + open(FD, $filename) or die "Can't open xslt local copy: '$filename'\n"; + while() { + s/xsl:import\s+href="/xsl:import href="$myownurl\/getxslt?uri=/g; + s/xsl:include\s+href="/xsl:include href="$myownurl\/getxslt?uri=/g; + $cont .= $_; + } + close(FD); + answer($c, $cont, "text/xml", ""); + unlink $filename or + print "Can't unlink XSLT temp file '$filename'"; + +# +# my $filename = $inputuri; +# $filename = $style_dir."/".$filename; +# print "XSLT: $inputuri ==> ($filename)\n"; +# if (stat($filename)) { +# print "Using local copy\n"; +# open(FD, $filename) or die "Cannot open $filename\n"; +# $cont = ""; +# while() { +# # Vary bad heuristic for substituion of absolute URLs +# # for relative ones +# s/xsl:import\s+href="/xsl:import href="$myownurl\/getxslt?uri=/g ; +# s/xsl:include\s+href="/xsl:include href="$myownurl\/getxslt?uri=/g ; +# $cont .= $_; +# } +# close(FD); +# answer($c,$cont,"text/xml",""); +# } else { +# die "Could not find XSLT!"; +# } +# + # "/update" works with rdf uri } elsif ($http_method eq 'GET' and $http_path eq "/update") { # rebuild urls_of_uris db and rdf uris db @@ -294,7 +312,21 @@ while (my $c = $d->accept) { print " done\n"; html_nice_answer($c,"Update done"); - # "/ls" does not work with rdf uris + # "/getalluris" does not work with rdf uris + } elsif ($http_method eq 'GET' and $http_path eq "/getalluris") { + # send back all the keys in xml + print "BASEURI $baseuri, FORMAT $outype\n"; + $cont = getalluris(); + answer($c,$cont,"text/xml",""); + + # "/getallrdfuris" + } elsif ($http_method eq 'GET' and $http_path eq "/getallrdfuris") { + # send back all the keys in xml + my $class = $cgi->param('class'); + print "BASEURI $baseuri, FORMAT $outype, CLASS $class\n"; + $cont = getallrdfuris($class); + answer($c,$cont,"text/xml",""); + } elsif ($http_method eq 'GET' and $http_path eq "/ls") { # send back keys that begin with a given uri my ($uritype,$uripattern,$uriprefix); @@ -419,11 +451,54 @@ sub resolve { # resolve an uri in a url, work both with standard cic: or theory: return ($rdf_map{$uri}); } else { # standard cic: or theory: uri, resolve using std uri db print "IS NOT A RDF URI\n"; - print "I WILL RETURN '$map{$uri}'\n"; - return ($map{$uri}); + print "I WILL RETURN '$xml_map{$uri}'\n"; + return ($xml_map{$uri}); } } +sub getalluris { # get all the keys whose prefix is cic + my $content = ""; + my ($uri); + my $debug=1; # for debug + + $content .= '' . "\n"; + $content .= "" . "\n\n"; + $content .= "\n"; + foreach $uri (sort (keys(%xml_map))) { # select matching uris + if ($uri =~ /^cic:/ && not $uri =~ /.types$/) { + print "GETALLURI: $uri\n" if defined($debug); + $content .= "\t\n"; + } + } + $content .= "\n"; + return $content; +} + +sub getallrdfuris { + my $class = $_[0]; + my $content = ""; + my ($uri); + my $debug=1; # for debug + + $content .= '' . "\n"; + $content .= "" . "\n\n"; + $content .= "\n"; + foreach $uri (sort (keys(%rdf_map))) { + if ($class eq "forward" && + $uri =~ /^helm:rdf:www.cs.unibo.it\/helm\/rdf\/forward/ + || + $class eq "backward" && + $uri =~ /^helm:rdf:www.cs.unibo.it\/helm\/rdf\/backward/) { + print "GETALLRDFURI: $uri\n" if defined($debug); + $content .= "\t\n"; + } + } + $content .= "\n"; + return $content; +} + sub finduris { # find uris for cic and theory trees generation my ($uritype,$uripattern,$format) = @_; my $content = ""; @@ -437,7 +512,7 @@ sub finduris { # find uris for cic and theory trees generation if (($uritype eq "cic") or ($uritype eq "theory")) { # get info only of one type: cic or theory - foreach (keys(%map)) { # select matching uris + foreach (keys(%xml_map)) { # select matching uris $uri = $_; if ($uri =~ /^$uritype:$uripattern(\/|$|\.)/) { if ($uri =~ /^$uritype:$uripattern\//) { # directory match @@ -454,9 +529,9 @@ sub finduris { # find uris for cic and theory trees generation if ($localpart =~ /^[^\/]*$/) { # no slash, an OBJECT $basepart = $localpart; - $basepart =~ s/^([^.]*\.[^.]*)(\.types)?(\.ann)?/$1/; - # remove exts .types or - # .types.ann + $basepart =~ s/^([^.]*\.[^.]*)((\.body)|(\.types))?(\.ann)?/$1/; + # remove exts .types, .body, + # .types.ann or .body.ann $flags = $objects{$basepart}; # get old flags if ($localpart =~ /\.ann$/) { $flags = add_flag("ann","YES",$flags); @@ -470,6 +545,13 @@ sub finduris { # find uris for cic and theory trees generation } else { $flags = add_flag("types","NO",$flags); } + if ($localpart =~ /\.body$/) { + $flags = add_flag("body","YES",$flags); + } elsif ($localpart =~ /\.body\.ann$/) { + $flags = add_flag("body","ANN",$flags); + } else { + $flags = add_flag("body","NO",$flags); + } $objects{$basepart} = $flags; # save new flags } else { # exists at least one slash, a DIR ($dirname) = split (/\//, $localpart); @@ -501,9 +583,10 @@ sub finduris { # find uris for cic and theory trees generation $content .= "\t\n"; $flags = $objects{$key}; $flags =~ s/^<(.*)>$/$1/; - my ($annflag,$typesflag) = split /,/,$flags; + my ($annflag,$typesflag,$bodyflag) = split /,/,$flags; $content .= "\t\t\n"; $content .= "\t\t\n"; + $content .= "\t\t\n"; $content .= "\t\n"; } $content .= "\n"; @@ -514,17 +597,18 @@ sub finduris { # find uris for cic and theory trees generation } sub add_flag { -# manage string like: "" +# manage string like: "" # "ann_flag" may be one of "ann_YES", "ann_NO" # "type_flag" may be one of "types_NO", "types_YES", "types_ANN" +# "body_flag" may be one of "body_NO", "body_YES", "body_ANN" # when adding a flag the max between the current flag and the new flag -# is taken, the orders are ann_NO < ann_YES and types_NO < types_YES < -# types_ANN +# is taken, the orders are ann_NO < ann_YES, types_NO < types_YES < +# types_ANN and body_NO < body_YES < body_ANN my ($flagtype,$newflag,$str) = @_; - $str = "<,>" if ($str eq ""); - ($str =~ s/^<(.*,.*)>$/$1/) or die "Internal error: ". + $str = "<,,>" if ($str eq ""); + ($str =~ s/^<(.*,.*,.*)>$/$1/) or die "Internal error: ". "wrong string format for flag adding in $str"; - my ($annflag,$typeflag) = split /,/,$str; + my ($annflag,$typeflag,$bodyflag) = split /,/,$str; if ($flagtype eq "ann") { # ANN flag handling if ($newflag eq "YES") { $annflag = "YES"; @@ -544,10 +628,21 @@ sub add_flag { } else { die "Internal error: typeflag must be \"YES\", \"NO\" or \"ANN\""; } + } elsif ($flagtype eq "body") { # BODY flag handling + if ($newflag eq "ANN") { + $bodyflag = "ANN"; + } elsif ($newflag eq "YES") { + $bodyflag = "YES" unless ($bodyflag eq "ANN"); + } elsif ($newflag eq "NO") { + $bodyflag = "NO" + unless (($bodyflag eq "ANN") or ($bodyflag eq "YES")); + } else { + die "Internal error: typeflag must be \"YES\", \"NO\" or \"ANN\""; + } } else { die "Internal error: unsupported flagtype \"$flagtype\""; } - $str = "<$annflag,$typeflag>"; + $str = "<$annflag,$typeflag,$bodyflag>"; } #CSC: Too much powerful: creates even /home, /home/users/, ... @@ -574,12 +669,6 @@ sub print_request print "\n"; } -sub callback -{ - my ($data) = @_; - $cont .= $data; -} - sub gunzip { # gunzip a file and return the deflated content my ($filename) = @_; @@ -698,7 +787,7 @@ sub download { # $cont now contained uncompressed data } if ($patch_dtd eq "yes") { - $cont =~ s/DOCTYPE (.*) SYSTEM\s+"http:\/\/www.cs.unibo.it\/helm\/dtd\//DOCTYPE $1 SYSTEM "$myownurl\/getdtd?uri=/g; + $cont =~ s/DOCTYPE (.*) SYSTEM\s+"$dtdbaseurl\//DOCTYPE $1 SYSTEM "$myownurl\/getdtd?uri=/g; } if ($format eq "gz") { gzip($cont,"$basefname.tmp"); @@ -730,6 +819,7 @@ sub answer { $res->push_header("Pragma" => "no-cache"); $res->push_header("Expires" => "0"); $c->send_response($res); + $c->force_last_request(); } sub html_nice_answer { @@ -739,9 +829,14 @@ sub html_nice_answer { answer($c,$content,"text/html",""); } +sub callback { + my ($data) = @_; + $cont .= $data; +} + sub helm_wget { -#retrieve a file from an url and write it to a temp dir -#used for retrieve resource index from servers +# retrieve a file from an url and write it to a temp dir +# used for retrieve resource index from servers $cont = ""; my ($prefix, $URL) = @_; my $ua = LWP::UserAgent->new; @@ -756,30 +851,34 @@ sub helm_wget { sub update { # retie dbs - untie %map; - tie(%map, 'DB_File', $uris_dbm.".db", O_RDWR, 0664); + untie %xml_map; + tie(%xml_map, 'DB_File', $uris_dbm, O_RDWR, 0664); untie %rdf_map; - tie(%rdf_map, 'DB_File', $rdf_dbm.".db", O_RDWR, 0664); + tie(%rdf_map, 'DB_File', $rdf_dbm, O_RDWR, 0664); + untie %xslt_map; + tie(%xslt_map, 'DB_File', $xslt_dbm, O_RDWR, 0664); } sub update_dbs { # rebuild dbs fetching resource indexes from servers. -# Rebuild urls_of_uris db (1) and rdf db (2) +# Rebuild urls_of_uris db (1), rdf db (2) and xslt db (3) my ( $server, $idxfile, $rdf_idxfile, $uri, $url, $comp, $line, @servers, - %urls_of_uris, %rdf # local proxy of $map and $rdf_map + %urls_of_uris, %rdf, %xslt # local proxy of dbs ); - untie %map; + untie %xml_map; untie %rdf_map; - foreach my $file ($uris_dbm, $rdf_dbm) { # remove old db file - if (stat $file.".db") { # remove if exists - unlink ($file.".db") or die "can't unlink old db file: $file.db\n"; + untie %xslt_map; + foreach my $file ($uris_dbm, $rdf_dbm, $xslt_dbm) { # remove old db file + if (stat $file) { # remove if exists + unlink ($file) or die "can't unlink old db file: $file\n"; } } - tie(%urls_of_uris, 'DB_File', $uris_dbm.".db", O_RDWR|O_CREAT, 0664); - tie(%rdf, 'DB_File', $rdf_dbm.".db", O_RDWR|O_CREAT, 0664); + tie(%urls_of_uris, 'DB_File', $uris_dbm, O_RDWR|O_CREAT, 0664); + tie(%rdf, 'DB_File', $rdf_dbm, O_RDWR|O_CREAT, 0664); + tie(%xslt, 'DB_File', $xslt_dbm, O_RDWR|O_CREAT, 0664); open (SRVS, "< $servers_file") or die "cannot open servers file: $servers_file\n"; @@ -791,12 +890,15 @@ sub update_dbs { chomp $server; helm_wget($tmp_dir, $server."/".$indexname); # get index helm_wget($tmp_dir, $server."/".$rdf_indexname); # get rdf index + helm_wget($tmp_dir, $server."/".$xslt_indexname); # get xslt index $idxfile = $tmp_dir."/".$indexname; $rdf_idxfile = $tmp_dir."/".$rdf_indexname; + $xslt_idxfile = $tmp_dir . "/" . $xslt_indexname; - open (INDEX, "< $idxfile") or # (1) REBUILD URLS_OF_URIS DB + # (1) REBUILD URLS_OF_URIS DB + open (INDEX, "< $idxfile") or die "cannot open temporary index file: $idxfile\n"; - while ($line = ) { # parse index and add entry to urls_of_uris db + while (my $line = ) { # parse index and add entry to urls_of_uris db chomp $line; ($uri,$comp) = split /[ \t]+/, $line; # build url: @@ -810,9 +912,10 @@ sub update_dbs { $urls_of_uris{$uri} = $url; } - open (RDF_INDEX, "< $rdf_idxfile") or # (2) REBUILD RDF DB - die "cannot open temporary rdf index file: $rdf_idxfile\n"; - while ($line = ) { # parse index and add entry to rdf db + # (2) REBUILD RDF DB + open (RDF_INDEX, "< $rdf_idxfile") or + die "cannot open temporary RDF index file: $rdf_idxfile\n"; + while (my $line = ) { # parse index and add entry to rdf db chomp $line; ($uri,$comp) = split /[ \t]+/, $line; # comp is "gz" or nothing # build url: @@ -826,19 +929,34 @@ sub update_dbs { $rdf{$uri} = $url; } + # (3) REBUILD XSLT DB + open (XSLT_INDEX, "< $xslt_idxfile") or + die "cannot open temporary XSLT index file: $xslt_idxfile\n"; + while (my $line = ) { # parse index and add entry to xslt db + chomp $line; + my $stylesheet = $line; + my $url = $server . "/" . $stylesheet; + $xslt{$stylesheet} = $url; + } + close INDEX; # close indexes close RDF_INDEX; - die "cannot unlink temporary file: $idxfile\n" # remove temp files - if (unlink $idxfile) != 1; - die "cannot unlink temporary file: $rdf_idxfile\n" - if (unlink $rdf_idxfile) != 1; + close XSLT_INDEX; + + # remove temp files + foreach my $file ($idxfile, $rdf_idxfile, $xslt_idxfile) { + print "cannot unlink temporary file: $file\n" if (unlink $file) != 1; + } } untie(%urls_of_uris); # untie local proxies untie(%rdf); - tie(%map, 'DB_File', $uris_dbm.".db", O_RDWR, 0664); # retie global ones - tie(%rdf_map, 'DB_File', $rdf_dbm.".db", O_RDWR, 0664); + untie(%xslt); + tie(%xml_map, 'DB_File', $uris_dbm, O_RDWR, 0664); # retie global ones + tie(%rdf_map, 'DB_File', $rdf_dbm, O_RDWR, 0664); + tie(%xslt_map, 'DB_File', $xslt_dbm, O_RDWR, 0664); + } # update_dbs # vim modline: do not remove!