#!/home/merlyn/bin/perl -Tw
use strict;
$|++;

use CGI qw(:cgi);
use HTTP::Date qw(time2str);
use IO::File;

### constants

my $SERVED_DIR = "/home/merlyn/Web/Limit";
my $BYTES_FILE = "/tmp/merlyn.web.limit";

my $WINDOW_SECONDS = 5;
my $MAX_BYTES_PER_SECOND = 10 * 1024;
my $MAX_BYTES_PER_WRITE = 8 * 1024;

### end constants

my $file = path_info;

eval {
  if ($file eq "/.." or $file !~ m{ ^/[a-zA-Z0-9_\-.]+$ }x) {
    die "403 Forbidden\nYou are not permitted to access $file\n";
  } elsif (! -e (my $full_file = "$SERVED_DIR$file")) {
    die "404 Not Found\nYour requested file $file is not found\n";
  } else {
    my $mime_type;
    {
      local $_ = $file;
      /\.txt$/ and ($mime_type = "text/plain"), last;
      /\.html$/ and ($mime_type = "text/html"), last;
      /\.gif$/ and ($mime_type = "image/gif"), last;
      /\.jpe?g$/ and ($mime_type = "image/jpeg"), last;
      $mime_type = "application/octet-stream";
    }
    my $f = new IO::File $full_file, O_RDONLY
      or die "404 Not Found\nYour requested file $file cannot be opened\n";
    my $b = new IO::File $BYTES_FILE, O_RDWR | O_CREAT
      or die "500 Internal Error\nCannot create/open $BYTES_FILE\n";
    autoflush $b 1;
    print
      header(-type => $mime_type,
             -nph => 1,
             -status => '200 Found',
             "last-modified" => time2str ((stat $f)[9]));
  OUTER:
    {
      flock $b, 2;              # wait for exclusive lock
      seek $b, 0, 0;
      my @times = map [ split ], <$b>;
      {
        my $now = time;
        my $then = $now - $WINDOW_SECONDS;
        shift @times while @times and $times[0][0] <= $then;
        my $sent = 0;
        for (@times) {
          $sent += $_->[1];
        }
        my $can_send = $MAX_BYTES_PER_SECOND * $WINDOW_SECONDS - $sent;
        $can_send = $MAX_BYTES_PER_WRITE if $can_send > $MAX_BYTES_PER_WRITE;
        if ($can_send > 0) { # ok to send
          my $buf;
          last unless read($f, $buf, $can_send);
          push @times, [$now, length $buf];
          seek $b, 0, 0;
          truncate $b, 0;
          print $b map "$_->[0] $_->[1]\n", @times;
          flock $b, 8;          # release lock
          print $buf;
          redo OUTER;
        }
        ## not ok to send, must sleep
        sleep $times[0][0] - $then + 1;
        redo;
      }
    }
  }
};
    
if ($@) {
  my $text = $@;
  my $status = ($text =~ s/^(\d\d\d .*)\n//) ? $1 : "500 Server Error";
  print
    header(-type => 'text/plain',
           -nph => 1,
           -status => $status,
           -date => time2str),
    $text;
}