Coro/myhttpd/diridx.pl

use List::Util qw(sum);

use Storable ();

my $SD_VERSION = 1;

my $ignore = qr/ ^(?:robots.txt$|\.) /x;

our %diridx;

if ($db_env) {
   tie %diridx, BerkeleyDB::Hash,
       -Env => $db_env,
       -Filename => "directory",
       -Flags => DB_CREATE,
          or die "unable to create database index";
}

sub conn::gen_statdata {
   my $self = shift;
   my $data;
   
   {
      my $path = "";
      my $prefix = "";

      for ("http://".$self->server_hostport, split /\//, substr $self->{name}, 1) {
         next if $_ eq ".";
         $path .= "<a href='".escape_uri("$prefix$_")."/'>$_</a> / ";
         $prefix .= "$_/";
      }
      $data->{path} = $path;
   }

   sub read_file {
      local ($/, *X);
      (open X, "<$_[0]\x00") ? <X> : ();
   }

   {
      my $path = $self->{path};
      do {
         $data->{top} ||= read_file "$path.dols/top";
         $data->{bot} ||= read_file "$path.dols/bot";
         $path =~ s/[^\/]*\/+$//
            or die "malformed path: $path";
      } while $path ne "";
   }

   local *DIR;
   if (opendir DIR, $self->{path}) {
      my $dlen = 0;
      my $flen = 0;
      my $slen = 0;
      for (sort readdir DIR) {
         next if /$ignore/;
         stat "$self->{path}$_";
         if (-d _) {
            next unless 0555 == ((stat _)[2] & 0555);
            $dlen = length $_ if length $_ > $dlen;
            push @{$data->{d}}, $_;
         } else {
            next unless 0444 == ((stat _)[2] & 0444);
            my $s = -s _;
            $flen = length $_ if length $_ > $dlen;
            $slen = length $s if length $s > $dlen;
            push @{$data->{f}}, [$_, $s];
         }
      }
      $data->{dlen} = $dlen;
      $data->{flen} = $flen;
      $data->{slen} = $slen;
   }

   $data;
}

sub conn::get_statdata {
   my $self = shift;

   my $mtime = $self->{stat}[9];

   $statdata = $diridx{$self->{path}};

   if (defined $statdata) {
      $$statdata = Storable::thaw $statdata;
      return $$statdata
         if $$statdata->{version} == $SD_VERSION
            && $$statdata->{mtime} == $mtime;
   }

   $self->slog(8, "creating index cache for $self->{path}");

   $$statdata = $self->gen_statdata;
   $$statdata->{version} = $SD_VERSION;
   $$statdata->{mtime}   = $mtime;

   $diridx{$self->{path}} = Storable::freeze $$statdata;
   (tied %diridx)->db_sync;

   $$statdata;
}

sub handle_redirect { # unused
   if (-f ".redirect") {
      if (open R, "<.redirect") {
         while (<R>) {
            if (/^(?:$host$port)$uri([^ \tr\n]*)[ \t\r\n]+(.*)$/) {
               my $rem = $1;
               my $url = $2;
               print $nph ? "HTTP/1.0 302 Moved\n" : "Status: 302 Moved\n";
               print <<EOF;
Location: $url
Content-Type: text/html

<html>
<head><title>Page Redirection to $url</title></head>
<meta http-equiv="refresh" content="0;URL=$url">
</head>
<body text="black" link="#1010C0" vlink="#101080" alink="red" bgcolor="white">
<large>
This page has moved to $url.<br />
<a href="$url">
The automatic redirection has failed. Please try a <i>slightly</i>
newer browser next time, and in the meantime <i>please</i> follow this link ;)
</a>
</large>
</body>
</html>
EOF
            }
         }
      }
   }
}

sub format_time {
   if ($_[0] < 0) {
      "--:--:--";
   } elsif ($_[0] >= 60*60*24) {
      sprintf "%02dd&#160;%02d:%02d:%02d",
              int ($_[0] / (60 * 60 * 24)),
              int ($_[0] / (60 * 60)) % 24,
              int ($_[0] / 60) % 60,
              int ($_[0]) % 60;
   } else {
      sprintf "%02d:%02d:%02d",
              int ($_[0] / (60 * 60)) % 24,
              int ($_[0] / 60) % 60,
              int ($_[0]) % 60;
   }
}

sub conn::diridx {
   my $self = shift;

   my $data = $self->get_statdata;

   my $stat;
   if ($data->{dlen}) {
      $stat .= "<table><tr><th>Directories</th></tr>";
      $data->{dlen} += 1;
      my $cols = int ((79 + $data->{dlen}) / $data->{dlen});
      $cols = @{$data->{d}} if @{$data->{d}} < $cols;
      my $col = $cols;
      for (@{$data->{d}}) {
         if (++$col >= $cols) {
            $stat .= "<tr>";
            $col = 0;
         }
         if ("$self->{path}$_" =~ $conn::blockuri{$self->{country}}) {
            $stat .= "<td>$_ ";
         } else {
            $stat .= "<td><a href='".escape_uri("$_/")."'>$_</a> ";
         }
      }
      $stat .= "</table>";
   }
   if ($data->{flen}) {
      $data->{flen} += 1 + $data->{slen} + 1 + 3;
      my $cols = int ((79 + $data->{flen}) / $data->{flen});
      $cols = @{$data->{f}} if @{$data->{f}} < $cols;
      my $col = $cols;
      $stat .= "<table><tr>". ("<th align='left'>File<th>Size<th>&nbsp;" x $cols);
      for (@{$data->{f}}) {
         if (++$col >= $cols) {
            $stat .= "<tr>";
            $col = 0;
         }
         $stat .= "<td><a href='".escape_uri($_->[0])."'>$_->[0]</a><td align='right'>$_->[1]<td>&nbsp;";
      }
      $stat .= "</table>";
   }

   <<EOF;
<html>
<head><title>$self->{uri}</title></head>
<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
<h1>$data->{path}</h1>
$data->{top}
<hr />
<a href="/internal/status">Server Status Page &amp; Queueing Info</a>
<hr />
$stat
$data->{bot}
</body>
</html>
EOF
}

sub statuspage {
   my ($self, $verbose) = @_;

   my $uptime = format_time ($::NOW - $::starttime);
   
   my $content = <<EOF;
<html>
<head><title>Server Status Page</title></head>
<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
<h1>Server Status Page</h1>
<h2>Myhttpd</h2>
version <b>$VERSION</b>; current:max connection count: <b>$::conns</b>:<b>$::maxconns</b>; uptime: <b>$uptime</b>;<br />
client-id <b>$self->{remote_id}</b>; client country <b>$self->{country}</b>;<br />
<h2>Queue Statistics</h2>
<ul>
EOF

   for (
         ["download queue", $queue_file],
         ["other queue",    $queue_index],
   ) {
      my ($name, $queue) = @$_;
      my @waiters = $queue->waiters;
      $waiters[$_]{idx} = $_ + 1 for 0..$#waiters;

      if (@waiters) {
         $content .= "<li>$name<br />".(scalar @waiters)." client(s); $queue->{started} downloads started;";
         
         $content .= "<p>Waiting time until download starts, estimated:<ul>";
         for (
               ["by most recently started transfer", $queue->{lastspb}],
               ["by queue average", $queue->{avgspb}],
               ["by next client in queue", $waiters[0]{spb}],
         ) {
            my ($by, $spb) = @$_;
            $content .= "<li>$by<br />";
            if ($spb) {
               $content .= sprintf "100 KB file: <b>%s</b>; 1 MB file: <b>%s</b>; 100MB file: <b>%s</b>;",
                                   format_time($spb*    100_000),
                                   format_time($spb*  1_000_000),
                                   format_time($spb*100_000_000);
            } else {
               $content .= "(unavailable)";
            }
            $content .= "</li>";
         }
         $content .= "</ul></p>";

         @waiters = grep { $verbose || $_->{coro}{conn}{remote_id} eq $self->{remote_id} } @waiters;
         if (@waiters) {
            $content .= "<table border='1' width='100%'><tr><th>#</th><th>Remote ID</th>".
                        "<th>CN</th><th>Size</th><th>Waiting</th><th>ETA</th><th>URI</th></tr>";
            for (@waiters) {
               my $conn = $_->{coro}{conn};
               my $time = format_time ($::NOW - $_->{time});
               my $eta  = $queue->{avgspb} * $_->{size} - ($::NOW - $_->{time});

               $content .= "<tr>".
                           "<td align='right'>$_->{idx}</td>".
                           "<td>$conn->{remote_id}</td>".
                           "<td>$conn->{country}</td>".
                           "<td align='right'>$_->{size}</td>".
                           "<td align='right'>$time</td>".
                           "<td align='right'>".($eta < 0 ? "<font color='red'>overdue</font>" : format_time $eta)."</td>".
                           "<td>".escape_html($conn->{name})."</td>".
                           "</tr>";
            }
            $content .= "</table></li>";
         }
         $content .= "</li>";
      } else {
         $content .= "<li>$name<br />(empty)</li>";
      }
   }

   $content .= <<EOF;
</ul>
</body>
</html>
EOF

   $self->response(200, "ok",
         {
            "Content-Type"   => "text/html",
            "Content-Length" => length $content,
         },
         $content);
};

$::internal{status} = sub { statuspage($_[0], 0) };
$::internal{queue}  = sub { statuspage($_[0], 1) };

1;
Revision:	1.27
Committed:	Mon Dec 3 21:45:45 2001 UTC (22 years, 7 months ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.26:	+5 -6 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.12	use List::Util qw(sum);
2
3	root	1.1	use Storable ();
4
5			my $SD_VERSION = 1;
6
7			my $ignore = qr/ ^(?:robots.txt$\|\.) /x;
8
9	root	1.9	our %diridx;
10
11	root	1.10	if ($db_env) {
12			tie %diridx, BerkeleyDB::Hash,
13			-Env => $db_env,
14			-Filename => "directory",
15			-Flags => DB_CREATE,
16			or die "unable to create database index";
17	root	1.9	}
18
19	root	1.1	sub conn::gen_statdata {
20			my $self = shift;
21			my $data;
22
23			{
24			my $path = "";
25			my $prefix = "";
26
27			for ("http://".$self->server_hostport, split /\//, substr $self->{name}, 1) {
28			next if $_ eq ".";
29	root	1.7	$path .= "<a href='".escape_uri("$prefix$_")."/'>$_</a> / ";
30	root	1.1	$prefix .= "$_/";
31			}
32			$data->{path} = $path;
33			}
34
35			sub read_file {
36			local ($/, *X);
37			(open X, "<$_[0]\x00") ? <X> : ();
38			}
39
40			{
41			my $path = $self->{path};
42			do {
43			$data->{top} \|\|= read_file "$path.dols/top";
44			$data->{bot} \|\|= read_file "$path.dols/bot";
45			$path =~ s/[^\/]*\/+$//
46			or die "malformed path: $path";
47			} while $path ne "";
48			}
49
50			local *DIR;
51			if (opendir DIR, $self->{path}) {
52			my $dlen = 0;
53			my $flen = 0;
54			my $slen = 0;
55			for (sort readdir DIR) {
56			next if /$ignore/;
57			stat "$self->{path}$_";
58			if (-d _) {
59	root	1.15	next unless 0555 == ((stat _)[2] & 0555);
60	root	1.1	$dlen = length $_ if length $_ > $dlen;
61	root	1.9	push @{$data->{d}}, $_;
62	root	1.1	} else {
63	root	1.15	next unless 0444 == ((stat _)[2] & 0444);
64	root	1.1	my $s = -s _;
65			$flen = length $_ if length $_ > $dlen;
66			$slen = length $s if length $s > $dlen;
67	root	1.9	push @{$data->{f}}, [$_, $s];
68	root	1.1	}
69			}
70	root	1.9	$data->{dlen} = $dlen;
71			$data->{flen} = $flen;
72			$data->{slen} = $slen;
73	root	1.1	}
74
75			$data;
76			}
77
78			sub conn::get_statdata {
79			my $self = shift;
80
81			my $mtime = $self->{stat}[9];
82
83	root	1.9	$statdata = $diridx{$self->{path}};
84	root	1.6
85	root	1.9	if (defined $statdata) {
86			$$statdata = Storable::thaw $statdata;
87			return $$statdata
88			if $$statdata->{version} == $SD_VERSION
89			&& $$statdata->{mtime} == $mtime;
90	root	1.1	}
91
92			$self->slog(8, "creating index cache for $self->{path}");
93
94	root	1.6	$$statdata = $self->gen_statdata;
95			$$statdata->{version} = $SD_VERSION;
96	root	1.9	$$statdata->{mtime} = $mtime;
97	root	1.1
98	root	1.9	$diridx{$self->{path}} = Storable::freeze $$statdata;
99	root	1.11	(tied %diridx)->db_sync;
100	root	1.1
101	root	1.6	$$statdata;
102	root	1.1	}
103
104	root	1.16	sub handle_redirect { # unused
105			if (-f ".redirect") {
106			if (open R, "<.redirect") {
107			while (<R>) {
108			if (/^(?:$host$port)$uri([^ \tr\n])[ \t\r\n]+(.)$/) {
109			my $rem = $1;
110			my $url = $2;
111			print $nph ? "HTTP/1.0 302 Moved\n" : "Status: 302 Moved\n";
112			print <<EOF;
113			Location: $url
114			Content-Type: text/html
115
116			<html>
117			<head><title>Page Redirection to $url</title></head>
118			<meta http-equiv="refresh" content="0;URL=$url">
119			</head>
120			<body text="black" link="#1010C0" vlink="#101080" alink="red" bgcolor="white">
121			<large>
122			This page has moved to $url.<br />
123			<a href="$url">
124			The automatic redirection has failed. Please try a <i>slightly</i>
125			newer browser next time, and in the meantime <i>please</i> follow this link ;)
126			</a>
127			</large>
128			</body>
129			</html>
130			EOF
131			}
132			}
133			}
134			}
135			}
136
137			sub format_time {
138	root	1.23	if ($_[0] < 0) {
139			"--:--:--";
140			} elsif ($_[0] >= 606024) {
141			sprintf "%02dd %02d:%02d:%02d",
142			int ($_[0] / (60 * 60 * 24)),
143			int ($_[0] / (60 * 60)) % 24,
144			int ($_[0] / 60) % 60,
145			int ($_[0]) % 60;
146			} else {
147			sprintf "%02d:%02d:%02d",
148			int ($_[0] / (60 * 60)) % 24,
149			int ($_[0] / 60) % 60,
150			int ($_[0]) % 60;
151			}
152	root	1.16	}
153
154	root	1.1	sub conn::diridx {
155			my $self = shift;
156
157			my $data = $self->get_statdata;
158	root	1.5
159	root	1.9	my $stat;
160			if ($data->{dlen}) {
161			$stat .= "<table><tr><th>Directories</th></tr>";
162			$data->{dlen} += 1;
163			my $cols = int ((79 + $data->{dlen}) / $data->{dlen});
164			$cols = @{$data->{d}} if @{$data->{d}} < $cols;
165			my $col = $cols;
166			for (@{$data->{d}}) {
167			if (++$col >= $cols) {
168			$stat .= "<tr>";
169			$col = 0;
170			}
171			if ("$self->{path}$_" =~ $conn::blockuri{$self->{country}}) {
172			$stat .= "<td>$_ ";
173			} else {
174			$stat .= "<td><a href='".escape_uri("$_/")."'>$_</a> ";
175			}
176			}
177			$stat .= "</table>";
178			}
179			if ($data->{flen}) {
180			$data->{flen} += 1 + $data->{slen} + 1 + 3;
181			my $cols = int ((79 + $data->{flen}) / $data->{flen});
182			$cols = @{$data->{f}} if @{$data->{f}} < $cols;
183			my $col = $cols;
184			$stat .= "<table><tr>". ("<th align='left'>File<th>Size<th> " x $cols);
185			for (@{$data->{f}}) {
186			if (++$col >= $cols) {
187			$stat .= "<tr>";
188			$col = 0;
189			}
190			$stat .= "<td><a href='".escape_uri($_->[0])."'>$_->[0]</a><td align='right'>$_->[1]<td> ";
191			}
192			$stat .= "</table>";
193			}
194
195	root	1.1	<<EOF;
196			<html>
197			<head><title>$self->{uri}</title></head>
198			<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
199			<h1>$data->{path}</h1>
200			$data->{top}
201	root	1.13	<hr />
202	root	1.16	<a href="/internal/status">Server Status Page & Queueing Info</a>
203	root	1.12	<hr />
204	root	1.9	$stat
205	root	1.1	$data->{bot}
206			</body>
207			</html>
208			EOF
209			}
210
211	root	1.22	sub statuspage {
212			my ($self, $verbose) = @_;
213	root	1.1
214	root	1.16	my $uptime = format_time ($::NOW - $::starttime);
215
216			my $content = <<EOF;
217	root	1.1	<html>
218	root	1.16	<head><title>Server Status Page</title></head>
219			<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
220			<h1>Server Status Page</h1>
221			<h2>Myhttpd</h2>
222	root	1.22	version <b>$VERSION</b>; current:max connection count: <b>$::conns</b>:<b>$::maxconns</b>; uptime: <b>$uptime</b>;<br />
223	root	1.25	client-id <b>$self->{remote_id}</b>; client country <b>$self->{country}</b>;<br />
224	root	1.16	<h2>Queue Statistics</h2>
225			<ul>
226	root	1.1	EOF
227	root	1.16
228	root	1.19	for (
229	root	1.22	["download queue", $queue_file],
230			["other queue", $queue_index],
231	root	1.19	) {
232			my ($name, $queue) = @$_;
233	root	1.22	my @waiters = $queue->waiters;
234	root	1.27	$waiters[$_]{idx} = $_ + 1 for 0..$#waiters;
235
236	root	1.22	if (@waiters) {
237	root	1.24	$content .= "<li>$name<br />".(scalar @waiters)." client(s); $queue->{started} downloads started;";
238	root	1.22
239			$content .= "<p>Waiting time until download starts, estimated:<ul>";
240			for (
241			["by most recently started transfer", $queue->{lastspb}],
242	root	1.23	["by queue average", $queue->{avgspb}],
243	root	1.22	["by next client in queue", $waiters[0]{spb}],
244			) {
245			my ($by, $spb) = @$_;
246			$content .= "<li>$by<br />";
247			if ($spb) {
248			$content .= sprintf "100 KB file: <b>%s</b>; 1 MB file: <b>%s</b>; 100MB file: <b>%s</b>;",
249			format_time($spb* 100_000),
250			format_time($spb* 1_000_000),
251			format_time($spb*100_000_000);
252			} else {
253			$content .= "(unavailable)";
254			}
255			$content .= "</li>";
256			}
257			$content .= "</ul></p>";
258
259	root	1.23	@waiters = grep { $verbose \|\| $_->{coro}{conn}{remote_id} eq $self->{remote_id} } @waiters;
260			if (@waiters) {
261	root	1.26	$content .= "<table border='1' width='100%'><tr><th>#</th><th>Remote ID</th>".
262			"<th>CN</th><th>Size</th><th>Waiting</th><th>ETA</th><th>URI</th></tr>";
263	root	1.22	for (@waiters) {
264			my $conn = $_->{coro}{conn};
265			my $time = format_time ($::NOW - $_->{time});
266	root	1.27	my $eta = $queue->{avgspb} * $_->{size} - ($::NOW - $_->{time});
267	root	1.26
268	root	1.22	$content .= "<tr>".
269	root	1.27	"<td align='right'>$_->{idx}</td>".
270	root	1.22	"<td>$conn->{remote_id}</td>".
271			"<td>$conn->{country}</td>".
272	root	1.26	"<td align='right'>$_->{size}</td>".
273			"<td align='right'>$time</td>".
274	root	1.27	"<td align='right'>".($eta < 0 ? "<font color='red'>overdue</font>" : format_time $eta)."</td>".
275	root	1.22	"<td>".escape_html($conn->{name})."</td>".
276			"</tr>";
277	root	1.18	}
278	root	1.19	$content .= "</table></li>";
279	root	1.1	}
280	root	1.22	$content .= "</li>";
281	root	1.16	} else {
282			$content .= "<li>$name<br />(empty)</li>";
283	root	1.1	}
284			}
285	root	1.16
286			$content .= <<EOF;
287			</ul>
288			</body>
289			</html>
290			EOF
291
292			$self->response(200, "ok",
293			{
294			"Content-Type" => "text/html",
295			"Content-Length" => length $content,
296			},
297			$content);
298			};
299	root	1.22
300			$::internal{status} = sub { statuspage($_[0], 0) };
301			$::internal{queue} = sub { statuspage($_[0], 1) };
302	root	1.1
303			1;