helm/graphs/tools/uri_set_queue.cgi

   1 #!/usr/bin/perl
   2
   3 use HTTP::Daemon;
   4 use HTTP::Status;
   5 use HTTP::Response;
   6 use CGI;
   7
   8 my $d = new HTTP::Daemon LocalPort => 8084;
   9 print "Please contact me at: <URL:", $d->url, ">\n";
  10
  11 $SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes
  12
  13 my %uri_sets;
  14 my %uri_queues;
  15
  16 #NOT REENTRANT: CAN NOT FORK DUE TO THE GLOBAL VARIABLES %uri_sets & %uri_queues
  17 #HENCE, THE "PID" ARGUMENT OF EVERY REQUEST MUST IDENTIFY THE SET OF URI
  18 #IT WANTS TO WORK WITH. MOREOVER, EVERY CLIENT MUST WORK WITH A DIFFERENT SET
  19 #OF URI, I.E. EVERY PID MUST BE UNIQUE.
  20
  21 #CSC: WHAT IF THE CLIENTS ARE ON DIFFERENT MACHINES AND HAVE THE SAME PID?
  22 #CSC: CGI MODULE REQUIRED TO PROCESS PARAMETERS BETTER
  23
  24 while (my $c = $d->accept) {
  25     while (my $r = $c->get_request) {
  26         if ($r->method eq 'GET' and $r->url->path eq '/add_if_not_in') {
  27             my $http_query = $r->url->equery;
  28             my $cgi = new CGI("$http_query");
  29             my $uri = $cgi->param('uri');
  30             my $pid = $cgi->param('PID');
  31             print "$pid: ";
  32             print(@{$uri_queues{$pid}} + 0);
  33             print "/";
  34             my $tot = keys(%{$uri_sets{$pid}}) + 0;
  35             print "$tot $uri: ";
  36
  37             my $res;
  38             if (!(defined($uri_sets{$pid}->{$uri}))) {
  39                 if ($tot + 1 > 20) {
  40                    $uri_sets{$pid}->{$uri} = -1;
  41                    push @{$uri_queues{$pid}},$uri;
  42                    $res = "added_with_mark";
  43                 } else {
  44                    $uri_sets{$pid}->{$uri} = 1;
  45                    push @{$uri_queues{$pid}},$uri;
  46                    $res = "added";
  47                 }
  48             } else {
  49                 $res = "already_in";
  50             }
  51             print $res."\n";
  52
  53             my $response = new HTTP::Response;
  54             $response->content("<?xml version=\"1.0\"?>\n<$res/>\n");
  55             $response->content_type('text/xml');
  56             $c->send_response($response);
  57         } elsif ($r->method eq 'GET' and $r->url->path eq '/get_next') {
  58             my $http_query = $r->url->equery;
  59             my $cgi = new CGI("$http_query");
  60             my $pid = $cgi->param('PID');
  61             print "$pid: ";
  62             print(@{$uri_queues{$pid}} + 0);
  63             print "/";
  64             print(keys(%{$uri_sets{$pid}}) + 0);
  65             print " ";
  66
  67             my $elem = shift @{$uri_queues{$pid}};
  68             my $mark = $uri_sets{$pid}->{$elem};
  69
  70             my $response = new HTTP::Response;
  71             my $xml_header = "<?xml version=\"1.0\"?>\n";
  72             if ($mark == 1) {
  73                print "$elem removed\n";
  74                $response->content("$xml_header<uri value=\"$elem\"/>\n");
  75             } elsif ($mark == -1) {
  76                print "$elem (marked) removed\n";
  77                $response->content("$xml_header<marked_uri value=\"$elem\"/>\n");
  78             } else {
  79                print "is now empty\n";
  80                $response->content("$xml_header<empty/>\n");
  81             }
  82             $response->content_type('text/xml');
  83             $c->send_response($response);
  84         } elsif ($r->method eq 'GET' and $r->url->path eq '/reset_to_empty') {
  85             my $pid = $r->url->query;
  86             $pid =~ s/[^=]*=//;
  87             # Next loop for debugging purposes only
  88             my $count = 1;
  89             while (my $e = shift @{$uri_queues{$pid}}) {
  90              print "#$count $e forced out of the set\n";
  91              $count++;
  92             }
  93             print "************\nThe URI set $pid is now empty again\n";
  94             delete($uri_sets{$pid});
  95             my $response = new HTTP::Response;
  96             $response->content("<?xml version=\"1.0\"?>\n<done/>\n");
  97             $response->content_type('text/xml');
  98             $c->send_response($response);
  99         } else {
 100             $c->send_error(RC_FORBIDDEN)
 101         }
 102     }
 103     $c->close;
 104     undef($c);
 105 }