#!/usr/bin/perl -w
##### 
# freecache.cgi
# Author: Ralf Muehlen, based on earlier code from Jon Aizen and Brad Tofel.
# Idea from Brewster Kahle.
# Version: 2.0
# Description: This is a cgi script that implements a freecache server as part of the
#              freecache system. It should be usuable on any Apache server that
#              runs Perl cgi scripts. To use this file, please modify the lines
#              in the USER CONFIGURATION section.
#
# For feedback, please use the online forum at http://freecache.org/
#
use strict;
###############################################################################
##
##     USER CONFIGURATION
##
# MODIFY NOTHING ABOVE THIS LINE.
# SEE http://freecache.org/ FOR MORE INFORMATION
#
my $debug_level        = 2; # 0=least, 3=most debugging info
my $freecache_password = 'ChangeMe';
my $server_admin_email = $ENV{'SERVER_ADMIN'};    # take it from Apache 
#  $server_admin_email = 'webmaster@example.com'; # or specify it yourself
#
# Put the largest directory first; that's a little more efficient.
my @cache_dirs         = ('/1/freecache','/2/freecache','/3/freecache','/4/freecache','/5/freecache','/6/freecache','/7/freecache','/0/freecache'); 
my @cache_sizes        = (110,110,110,110,110,110,110,90); # in GBytes
my $serving_ip_range   = '0.0.0.0/0';
my $unzip_cmd          = '/usr/local/bin/unzip';
# The following 2 entires are for experimental support of the 
# Distributed Storage Initiative on Internet2.
my $dsi                = 0; # Is this FC close to the Internet2? 0=no, 1=yes
my $lors_bin_dir       = '/home/muehlen/lors/lors-runtime/bin'; # Only needed if you set $dsi to 1.
#
# All FreeCaches need be on a public IP to able to communicate with the
# Redirector and other FreeCaches. $serving_ip_range will be taken into
# consideration by the Redirector. Currently you can only specify one
# IP range. This IP range does not have to reflect actual routing rules.
# Examples:
#   serve anyone '0.0.0.0/0';
#   serve 1 class C network: '209.237.233.0/24';
#   serve 2 class C networks 209.237.233.0/24 and 209.237.234.0/24 plus a few more:
#     '209.237.232.0/22';
#
#
# After changing this configuration, invoke FreeCache and start it:
# http://your.site/cgi-bin/freecache.cgi
#
# The heartbeat of this cgi can be monitored as:
# http://your.site/cgi-bin/freecache.cgi?action=status
#
#
# MODIFY NOTHING BELOW THESE LINES.
# SEE http://freecache.org/ FOR MORE INFORMATION
#
###############################################################################
#
# TODO globally: die with HTTP error

my $free_cache_agent = "InternetArchiveFreeCache(tm)v.2.0";
my $redirector = 'freecache.org';

use Digest::MD5;
use POSIX;
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Response;

my $start = (POSIX::times())[0];
my $section = "main";
my $total_read = 0;
my $total_wrote = 0;
$SIG{ABRT} = sub { signal_handler("ABRT"); };
$SIG{ALRM} = sub { signal_handler("ALRM"); };
$SIG{HUP}  = sub { signal_handler("HUP");  };
$SIG{PIPE} = sub { signal_handler("PIPE"); };
$SIG{TERM} = sub { signal_handler("TERM"); };
#sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT USR1 USR2"",0"

my $GBytes = 1024 * 1024 * 1024;
#my $cache_request_timeout    = 60 * 60 * 24;
my $cache_request_timeout    = 600;
my $cache_request_block_size = 1024 * 64; # should be bigger, small for testing
my $client_buff_size         = 1024 * 128; # same deal
# not used anymore: #my $client_max_write         = 1024 * 4;  # ditto   
#my $cache_request_block_size = 1024 * 1; # should be bigger, small for testing
#my $client_buff_size         = 1024 * 1; # same deal
#my $client_max_write         = 1024 * 1;  # ditto
my $buffer                   = "";
my $error_buffer             = "";
my $tail_file_sleep          = 5;
my $my_protocol              = $ENV{'SERVER_PROTOCOL'};
my $my_hostname              = $ENV{'SERVER_NAME'};
my $my_port                  = $ENV{'SERVER_PORT'};
my $my_ip                    = $ENV{'SERVER_ADDR'};
my $remote_ip                = $ENV{'REMOTE_ADDR'};
my $remote_ua                = $ENV{'HTTP_USER_AGENT'} || "";
my $request_uri              = $ENV{'REQUEST_URI'};
my $method                   = $ENV{'REQUEST_METHOD'};
my $range                    = $ENV{'HTTP_RANGE'};
my $pid;

my $CACHE_MISS    = "0";
my $CACHE_HIT     = "1";
my $CACHE_CACHING = "2";

my $get_cache_source_url_template = "http://%s/%s";
my $num_redirect_attempts = 5;
my $number_of_retries = 2;

# we'll use this a few times:

my $ua = LWP::UserAgent->new;
$ua->agent($free_cache_agent);
$ua->from($server_admin_email);
$ua->timeout($cache_request_timeout);


###
# FreeCache Alogrithm:
# 
# if fill_cache
#   get file size
#   if disk_free + file_size > $high_watermark
#     delete_files
#   download file
#   calculate MD5 hash
#   if url
#     rename file
#     notify redirector of url_addition
#   else /* md5 */
#     if md5sum != filename
#       notify redirector of md5_mismatch
#     else
#       notify redirector of md5_addition
#     
# 
# if file_request
#   if file found
#     serve file
#     notify redirector of serving 
#   if file not found
#     redirect client to redirector with file_not_found
# 
# sub_delete
#   find the oldest files and their sizes
#   notify redirector of deletions
#   delete files till low_watermark is reached
#   done  
# 
# 
###


# time stamp
  my ($sec,$min,$hour,$mday,$mon,$year,$wday, $yday,$isdst)=localtime(time);
  my $timestamp = sprintf "%4d-%02d-%02d %02d:%02d:%02d", $year+1900,$mon+1,$mday,$hour,$min,$sec;

# parse arguments and query envirnment
  $my_protocol =~ s/\/.*//;
  $my_protocol =~ tr/[A-Z]/[a-z]/;
  my $fc_url = $my_protocol ."://$my_hostname";
  $fc_url .= ":". $my_port unless $my_port == 80;
  my $my_path = $request_uri;
  $my_path =~ s/(.*freecache\.cgi).*/$1/;
  $fc_url .= $my_path;

  $request_uri =~ s/^\///;
  debug_msg("Invoked at ". (POSIX::times())[0] ."=$timestamp from $remote_ip with $request_uri ua:$remote_ua",2);

  #my $cgi             = new CGI;
  #my $fill_cache      = $cgi->param("fill_cache") || "";
  #my $md5             = $cgi->param("md5") || "";
  #my $xnode           = $cgi->param("xnode") || "";
  #my $zip             = $cgi->param("zip") || "";
  #my $action          = $cgi->param("action") || "";
  #my $password        = $cgi->param("password") || "";
  #my $redirector_ip   = $cgi->param("redirectorIP") || $redirector;
  #my $mime            = $cgi->param("mime") || "";
  #my $file_base       = $cgi->param("base") || "";

  my $fill_cache; my $md5; my $xnode; my $zip; my $action; my $password; my $redirector_ip; my $mime; my $file_base;
  if ($request_uri =~ 'freecache.cgi\?') { # invoked via rewrite-rule
    my ($path,$args) = split(/freecache.cgi\?/, $request_uri);
    my ($command,$parameters) = split('&',$args,2);
    debug_msg("? invokation: command($command), parameters($parameters)",2);

    if ($command =~ s/fill_cache=//) { $fill_cache = $command; if ($parameters =~ s/redirectorIP=//) { $redirector_ip = $parameters;} }
    if ($command =~ s/action=//)     { $action     = $command; if ($parameters =~ s/password=//)          { $password = $parameters;} }
    if ($command =~ s/md5=//)        { $md5        = $command; ($redirector_ip,$mime,$file_base) = split('&',$parameters,3); }
    if ($command =~ s/xnode=//)      { $xnode      = $command; ($redirector_ip,$mime,$file_base) = split('&',$parameters,3); }
    if ($command =~ s/zip=//)        { $zip        = $command; ($redirector_ip,$mime,$file_base) = split('&',$parameters,3); }

    if ($redirector_ip) { $redirector_ip =~ s/redirectorIP=//; }
    if ($mime)      { $mime      =~ s/mime=//; }
    if ($file_base) { $file_base =~ s/base=//; }
    $redirector_ip   = $redirector_ip || $redirector;
  }
  if ($request_uri =~ 'freecache.cgi\/') { # invoked via rewrite-rule
    # fill the parameter variables correctly
    my ($path,$args) = split(/freecache.cgi\//, $request_uri);
    (my $command,my $url,$redirector_ip,$mime,$file_base) = split('/', $args, 5);
    $redirector_ip   = $redirector_ip || $redirector;
    $mime            = $mime || "";
    $file_base       = $file_base || "";
    debug_msg("/ invokation: $command,$url,$redirector_ip,$mime,$file_base",3);
    if ($command =~ "fill_cache") { $fill_cache = $command; }
    if ($command =~ "action")     { $action     = $command; }
    if ($command =~ "md5")        { $md5        = $url; }
    if ($command =~ "xnode")      { $xnode      = $url; }
    if ($command =~ "zip")        { $zip        = $url; }
  }
  if ($mime) { $mime =~ s/-/\//; }


################################################################################
### main ###
################################################################################

if ($fill_cache) {
    $section = "fill_cache";
    debug_msg("FILL request: $fill_cache",3);
    $|++; # autoflush to avoid time-out
    ok_response("Filling."); # Do it early otherwise redirector thinks fill operation failed.
    my $request_url = $fill_cache;

    # get file size
    my $request = HTTP::Request->new(HEAD => $request_url);
    my $response = $ua->request($request);

    my $file_min_size;
    my $header = $response->headers_as_string;
    if ($header =~ s/^[\s\S]*X-Content-Minimum-Length: (\d+)[\s\S]*$/$1/m) { 
      $file_min_size = int (1.1 *$header); 
    }
    debug_msg("file_min_size($file_min_size)",2);

    my $ori_file_size = $response->content_length;
    my $file_size     = $response->content_length || $file_min_size || 2 * $GBytes;
    my $last_modified = $response->last_modified || '';
    my $mime          = $response->content_type || '';
  
    if ($dsi) { $file_size *= 1.1; } # leave space for xnode

    # choose cache_dir
    my $cache_dir;
    my $cache_size;
    my $max_disk_avail =0;
    my $disk_usage =0;

    # choose random cache_dir
    my $j = int(rand scalar(@cache_dirs));
    $cache_dir  = $cache_dirs[$j];
    $cache_size = $cache_sizes[$j] * $GBytes;
    $disk_usage = disk_usage($cache_dir);

    my $high_watermark = int($cache_size * 0.95);
    my $low_watermark  = int($cache_size * 0.9);
    debug_msg("cache_dir:$cache_dir cache_size:$cache_size",2);

    # do we have enough disk space? 
    if ( (0 + $disk_usage + $file_size) > $high_watermark ) {
      debug_msg("high_watermark ($high_watermark) reached. Deleting files.",3);
      delete_files($cache_dir,$disk_usage,$low_watermark);
    } 
    my $disk_free  =  disk_free($cache_dir);
    if ($disk_free <= $file_size * 2) {
      debug_msg("Low disk space: $disk_free free. Admin should adjust cache_size in config section.",1);
      $low_watermark -= $file_size;
      delete_files($cache_dir,$disk_usage,$low_watermark);
    }
    
    # need a temporary file name that will repeatably map the URL to a file:
    my $cache_file = $cache_dir . "/" . Digest::MD5::md5_hex($request_url) .".temp";
    if (-e $cache_file) { error_msg("temp file exists:$cache_file($!)"); }

    # download file
    debug_msg("Requesting($cache_file,$request_url)",3);
    $request = HTTP::Request->new(GET => $request_url);

    # this deserves a comment:
    # We want to build the MD5 as we recieve the data, so we use the 2nd argument(and 3rd)
    # arguments to UserAgent->request(), but we want the callback function to have access
    # to the lexically(locally) scoped Digest::MD5 object. We have to use an anonymous sub
    # to achieve this. If you understand why, please let me (Brad) know.

    open(CACHE_FILE,">$cache_file") || error_msg("open $cache_file($!)");
    #binmode(CACHE_FILE);

    my $i =0;
    my $ctx = new Digest::MD5();
    $total_read = 0;
    my $read_sub = sub {
        my $data = shift;
        $total_read += length($data);
        $ctx->add($data);
        print CACHE_FILE $data;
        if ($i++ > 1024) { print ".\n"; $i =0; }
    };

    $response = $ua->request($request,$read_sub,$cache_request_block_size);
    debug_msg("Done with request($cache_file,$request_url,$total_read bytes)",3);
    close(CACHE_FILE) || error_msg("close CACHE_FILE($!)"); # to get file_size right

    if($response->is_success) { debug_msg("downloaded: $cache_file",3); } 
    else { my $status_line = $response->status_line; fail("Failed to download $cache_file: $status_line",$cache_file); }

    # test size
    $file_size = (-s $cache_file);
    if (($ori_file_size) && ($ori_file_size != $file_size) ) {
      fail("file_size($file_size) does not match Content-Length($ori_file_size)",$cache_file);
    }

    # test zip files
    # unzip does not work with files over 2GB
    if ( ($file_size < 2* $GBytes) && ($request_uri =~ m|http://\w*.archive.org/.*.zip|) ) {
      open(UZ, "$unzip_cmd -l $cache_file 2>&1 1>/dev/null |");
      if (<UZ>) { fail("ZIP file is corrupted",$cache_file); }
      close UZ;
    }

    my $calc_md5 = $ctx->hexdigest();
    debug_msg("calc_md5: $calc_md5",3);
    my $final_cache_file = $cache_dir . "/" . $calc_md5;


    # is it a MD5 ?
    if($request_url =~ /[0-9a-f]{32}/) { 
        my $want_md5 = $request_url;
        #debug_msg("want_md5: $want_md5",3);
        $want_md5 =~ s/.*([0-9a-f]{32})+.*/$1/;
        debug_msg("want_md5: $want_md5",3);

        # do the MD5s match?
	if($calc_md5 ne $want_md5) {
          notify($redirector_ip,"md5_mismatch:$request_url:$calc_md5");
          fail("Got wrong md5. Got ($calc_md5) but wanted ($want_md5)",$cache_file);
	} 
        else {
          debug_msg("renaming $cache_file to $final_cache_file",3);
	  rename($cache_file,$final_cache_file) || error_msg("unable to rename $cache_file -> $final_cache_file($!)");
          my $elapsed = (POSIX::times())[0] - $start;
          debug_msg("add_md5:$calc_md5",3);
	  notify($redirector_ip,"add_md5:$calc_md5:$elapsed");
	}
    } else { # It's an URL.
        debug_msg("renaming $cache_file to $final_cache_file",3);
	rename($cache_file,$final_cache_file) || error_msg("unable to rename $cache_file -> $final_cache_file($!)");
        $mime =~ s/\//-/; # In FC communications and DB, the MIME type should always be xxx-yyy, not xxx/yyy.
        my $elapsed = (POSIX::times())[0] - $start;
	debug_msg("$redirector_ip,add_url:$calc_md5:$last_modified:$mime:$file_size:$elapsed:$request_url",2);
	notify($redirector_ip,"add_url:$calc_md5:$last_modified:$mime:$file_size:$elapsed:$request_url");
        if ($dsi) { 
          chdir $cache_dir;
          if ($file_size < 0.042 * $GBytes) { create_xnode($request_url,$calc_md5,$file_size,$mime,$last_modified); }
        }
    }
    print "Done filling.\n";
} # fill_cache
elsif ($md5 || $xnode || $zip) { # MD5
  $section = "md5";
  if ($xnode) { $md5 = $xnode; }
  if ($zip)   { $md5 = $zip; }
  debug_msg("MD5 Request URL($md5) MIME($mime) FILEBASE($file_base)",3);
  my $cache_dir;
  foreach $cache_dir (@cache_dirs) {
    my $cache_file = $cache_dir . "/" . $md5;
    if(-e $cache_file) {
      debug_msg("Request method($method)",3);
      my $action;
      # TODO: take $file_size from redirector
      my $file_size = (-s $cache_file);
      if ($method =~ "HEAD") {
        if ($xnode) { return_header($mime,$file_base); }
        else        { return_header($mime,$file_base,$file_size); }
        $action = "servedhead";  
      }
      elsif ($method =~ "GET") {
        if ($remote_ua =~ /.*FreeCache.*/i) { $action = "served2fc"; }
        else                                { $action = "served2u";  }
        my $start_byte; my $end_byte;
        $start_byte=0; $end_byte=$file_size-1;
        if ($range) {
          debug_msg("range($range) ua:$remote_ua",2);
          if ( ($range =~ s/^bytes=(\d*)-(\d*)$/$1-$2/) && ($range !~ s/^-$/$1/) ) {
            if    ($range =~ s/^-(\d+)/$1/) { $start_byte = $file_size - $range; $end_byte = $file_size -1;}
            elsif ($range =~ s/(\d+)-$/$1/) { $start_byte = $range;              $end_byte = $file_size -1;}
            else { ($start_byte, $end_byte) = split('-',$range); }
            debug_msg("start_byte($start_byte), end_byte($end_byte)",3);
            $action = "servedPu"; 
          }
          else {
            debug_msg("Unknown range request: $range",1);
            notify($redirector_ip,"error_range:$range:$request_uri:$remote_ua"); 
            $range = "";
          }
        }
        if ($xnode) { 
          return_header($mime,$file_base);
          return_xnode($cache_file,$mime,$file_base,$start_byte,$end_byte);
        }
        elsif ($zip) { 
          if ($remote_ua =~ /.*FreeCache.*/i) { $action = "served2fc"; }
          else                                { $action = "served2u";  }
          return_header($mime,$file_base);
          if (!return_zip($cache_file,$mime,$file_base)) { $action="servedEu"; }
        }
        else {
          return_header($mime,$file_base,$file_size,$start_byte,$end_byte);
          if (!return_file($cache_file,$mime,$file_base,$start_byte,$end_byte)) { $action="servedEu"; }
        }
      }
      else { # request method not supported
        error_msg("Unsupported request method($method)");
      } 
      my $elapsed = (POSIX::times())[0] - $start;
      if ($action) { notify($redirector_ip,"$action:$md5:$total_wrote:$elapsed:$remote_ip"); }
      debug_msg("Done and exiting! elapsed($elapsed)\n",2);
      exit();
    }
  }

  # file not found in any cache_dir
  debug_msg("MD5 cache miss ($md5)",1);
  #print $cgi->header(-status=>'404 Not Found');
  print "Status: 404 Not Found\n\n";
  notify($redirector_ip,"not_found:$md5");
  debug_msg("Exiting with error!\n",2);
  exit;
} # MD5
elsif ($action) { # action
  debug_msg("action invoked:$action",3);
  my $message = "";
  # actions triggered remotely
  if ($action eq "status") {
    $message = "$free_cache_agent running on $my_hostname ($my_ip)"; 
  }
  elsif ($action eq "inventory") {
    $|++; # autoflush to avoid time-out
    my $cache_dir;
    my $cache_size = 0;
    my $total_size = 0;
    my $disk_free  = 0;
    my $disk_usage = 0;
    foreach $cache_size (@cache_sizes) { $total_size += $cache_size; }
    $total_size *= $GBytes;
    ok_response("cache_size $total_size");
    foreach $cache_dir (@cache_dirs) {
      $disk_free  += disk_free($cache_dir);
      $disk_usage += disk_usage($cache_dir);
    }
    print "disk_free $disk_free\n"; 
    print "disk_usage $disk_usage\n"; 
    foreach $cache_dir (@cache_dirs) {
      disk_inventory($cache_dir);
    }
    my $elapsed = (POSIX::times())[0] - $start;
    debug_msg("Done and exiting! elapsed($elapsed)\n",2);
    exit();
  }
  elsif ($action =~ /delete=[0-9a-f]{32}(\.temp){0,1}/) {
    my $file = $action;
    $file =~ s/(\w*)=//;
    my $cache_dir;
    foreach $cache_dir (@cache_dirs) {
      my $cache_file = $cache_dir . "/" . $file;
      if(-e $cache_file) {
        debug_msg("deleting $cache_file",3);
        unlink("$cache_file") or error_msg("Unable to Unlink($cache_file)($!)");
        if ($dsi) {
          my $cache_file = $cache_file .".xnd";
          if (-e $cache_file) {
            debug_msg("deleting $cache_file",3);
            unlink("$cache_file") or error_msg("Unable to Unlink($cache_file)($!)");
          }
        }
        if ($file =~ /[0-9a-f]{32}/) { notify($redirector_ip,"del_md5:$file"); }
        else {                         notify($redirector_ip,"del_temp:$file"); }
        $message = "deleted $cache_file";
        last;
      }
    }
  }
  elsif ($action =~ /refresh=[0-9a-f]{32}(\.xnd){1}/) {
    my $file = $action;
    $file =~ s/(\w*)=//;
    my $cache_dir;
    foreach $cache_dir (@cache_dirs) {
      my $cache_file = $cache_dir . "/" . $file;
      if(-e $cache_file) {
        debug_msg("refreshing xnode $cache_file",2);
        ok_response("refreshing xnode $file");
        if ($dsi) { refresh_xnode($cache_file); }
        my $elapsed = (POSIX::times())[0] - $start;
        debug_msg("Done and exiting! elapsed($elapsed)\n",2);
        exit;
      }
    }
  }
  # actions triggered by host admin via HTML form
  elsif ($action eq "Start") {
    if ($password ne $freecache_password) { $message = "Wrong password."; }
    else {
      my $cache_dir;
      foreach $cache_dir (@cache_dirs) {
        # write test file
        my $cache_file = $cache_dir . "/freecache_test";
        open(CACHE_FILE,">$cache_file") || error_msg("open $cache_file($!)");
        print CACHE_FILE "freecache_test\n";
        close(CACHE_FILE) || error_msg("close CACHE_FILE($!)");
    
        # delete test file
        unlink("$cache_file") or error_msg("Unable to Unlink($cache_file)($!)");
    
        # write another test file
        $cache_file = $cache_dir . "/.TEST";
        open(CACHE_FILE,">$cache_file") || error_msg("open $cache_file($!)");
        print CACHE_FILE "freecache_test\n";
        close(CACHE_FILE) || error_msg("close CACHE_FILE($!)");
      } 
      my $cache_size = 0;
      my $total_size = 0;
      foreach $cache_size (@cache_sizes) { $total_size += $cache_size; }
      $total_size *= $GBytes;
    
      # register with redirector
      my $start_template = "start:%s,%s,%s,%s,%s";
      my $registration = sprintf($start_template,$my_hostname,$serving_ip_range,$total_size,$server_admin_email,$fc_url);
      notify($redirector,$registration);
      $message = "<pre>Started successfully.\n";
      $message .= "my_ip($my_ip)\n";
      $message .= "hostname($my_hostname)\n";
      $message .= "serving_ip_range($serving_ip_range)\n";
      $message .= "total_size($total_size)\n";
      $message .= "server_admin_email($server_admin_email)\n";
      $message .= "fc_url($fc_url)\n";
    }
  }
  elsif ($action eq "Stop") {
    if ($password ne $freecache_password) { $message = "Wrong password."; }
    else {
      my $cache_size = 0;
      my $total_size = 0;
      foreach $cache_size (@cache_sizes) { $total_size += $cache_size; }
      $total_size *= $GBytes;

      # unregister with redirector
      my $stop_template  =  "stop:%s,%s,%s,%s,%s";
      my $registration = sprintf($stop_template,$my_hostname,$serving_ip_range,$total_size,$server_admin_email,$fc_url);
      notify($redirector,$registration);
      $message = "Stopped successfully.";
    }
  }
  elsif ($action eq "Flush") {
    if ($password ne $freecache_password) { $message = "Wrong password."; }
    else {
      $|++; # autoflush to avoid time-out
      ok_response("flushing");
      my $cache_dir;
      foreach $cache_dir (@cache_dirs) {
        my $disk_usage = disk_usage($cache_dir);
        delete_files($cache_dir,$disk_usage,0);
      }
      print "Files flushed.";
      my $elapsed = (POSIX::times())[0] - $start;
      debug_msg("Done and exiting! elapsed($elapsed)\n",2);
      exit();
    }
  }
  else {
      $message = "Unknown action";
  } 
  ok_response($message);
}

else { # unknown request
  debug_msg("Unknown request: $request_uri",1);

  # Show the admin page
  print "Status: 401 Unknown Request\n";
  print "Content-type: text/html\n\n";
  print '<html>
	<head>
	<title>FreeCache Administration</title>
	</head>
	<body>
	<h2>FreeCache Administration</h2>
	<h3><font color="red">';
  print $my_hostname;
  print '
	</font></h3>
	<form method="get" action="">
	<input type="submit" name="action" value="Start">
	&nbsp;&nbsp;&nbsp;
	&nbsp;&nbsp;&nbsp;
	<input type="submit" name="action" value="Stop">
	&nbsp;&nbsp;&nbsp;
	&nbsp;&nbsp;&nbsp;
	<input type="submit" name="action" value="Flush">
	Flushing deletes all files in your FreeCache. It might take a while...
	<p>
	Your FreeCache password:
	<input type="password" name="password">
	</form>
	</body>
	<html>';
}

debug_msg("Done and exiting!\n",2);
exit();

################################################################################
### subs ###
################################################################################

# FUNCTIONS:
# Divided into 4 chunks:
#  Helpers:
#      disk_usage
#      delete_files
#      debug_msg
#  REDIRECTOR Communications:
#      notify
#  Cache Interface:
#      return_file
#  Header Stuff:
#      return_header

sub ok_response {
  my $message = shift;
  print "Status: 200 OK\n";
  print "Content-type: text/html\n\n";
  print $message ."\n";
  debug_msg("ok_response: $message",3);
}


sub disk_usage {
  # Tested on SunOS 5.8, FreeBSD 4.4, Linux Debian woody, Linux RedHat.
  my $dir = shift;
  my $du = "";
  open(DU, "du -sk $dir |"); # -k is the default, but we want to be sure.
  while (<DU>) {
    chomp;
    s/(\S+)(\s+)(\S+)/$1/;
    $du = $_;
  }
  $du *= 1024;
  close DU;
  return $du ;
}

sub disk_inventory {
  my $dir = shift;
  my $di = "";
  open(DI, "ls -l $dir |"); 
  while (<DI>) {
    s|(\S+\s+){4}(\S+).*([0-9a-f]{32})$|$2 $3|;
    print;
  }
  print "End of inventory.\n";
  debug_msg("End of inventory.",3);
}

sub disk_free {
  my $dir = shift;
  my $df = "";
  open(DF, "df -k $dir |"); # -k is the default, but we want to be sure.
  while (<DF>) {
    chomp;
    s/\S+\s+\S+\s+\S+\s+(\S+)\s+\S+\s+\S+/$1/;
    $df = $_;
  }
  $df *= 1024;
  close DF;
  return $df ;
}

sub delete_files {
  # find the oldest files and their sizes
  # notify redirector of deletions
  # unlink files till low_watermark is reached

  # Tested on SunOS 5.8, FreeBSD 4.4, Linux Debian woody, Linux RedHat.
  
  my ($dir, $disk_usage, $min) = @_;
  my $size;
  my $file;
  # Order by oldest accessed. On a noatime file system, we default to ctime.
  #open(LS, "ls -rtuks1 $dir |"); # atime
  #open(LS, "ls -rttks1 $dir |"); # mtime
  open(LS, "ls -rtcks1 $dir |"); # ctime
  while (<LS>) {
      ($size,$file) = split; 
      if ($size eq "total") { next; } # discard (on non-BSD Unix)
      notify($redirector_ip,"del_md5:$file");
      debug_msg("deleting $dir/$file",2);
      print "deleting $dir/$file\n"; # keeps the connection alive in case many files get deleted
      unlink("$dir/$file") or error_msg("Unable to Unlink($dir/$file)($!)");
      $disk_usage -= ($size * 1024);
      if ($disk_usage < $min) { last; }
  }
  close LS;
  return;
}


sub notify {
  $section = "notify";
  my ($redirector_ip,$message) = @_;

  my $success = 0;
  my $notify_redirector_url_template = "http://%s/NOTIFY:%s:%s";
  my $notify_redirector_url = sprintf($notify_redirector_url_template,$redirector_ip,$my_ip,$message);
    
  debug_msg("Notifying redirector($notify_redirector_url)",3);

  while ($number_of_retries > 0) {
    my $request = HTTP::Request->new(GET => $notify_redirector_url);
    my $response = $ua->simple_request($request);
    if($response->is_success) {
      $success = 1;
      debug_msg("Notified redirector($redirector_ip): $message",2);
      last;
    } else {
      debug_msg("Failed TO NOTIFY redirector($redirector_ip) of ($message)",1);
      $number_of_retries--;
    }
  }
  #return $success;
  $section = "main";
  return;
###

###
}



sub return_file {
    $section = "return_file";
    my ($cache_file,$mime,$file_base,$start_byte,$end_byte) = @_;
    debug_msg("return_file($cache_file)",3);
    $|++; # autoflush to avoid time-out

    my $success = 1;
    (sysopen(READ_FILE, $cache_file, O_RDONLY)) || error_msg("can't open $cache_file ($!)");
    #binmode(STDOUT);
    #$client_buff_size = (stat STDOUT)[11] || $client_buff_size;
    #debug_msg("client_buff_size for STDOUT: $client_buff_size",2);
    my $position = sysseek(READ_FILE,$start_byte,0);
    $position--;
    LOOP: while(1) {
        if ($position + $client_buff_size > $end_byte) { $client_buff_size = $end_byte - $position; }
	my $num_read = sysread(READ_FILE,$buffer,$client_buff_size);
	if (not defined($num_read)) {
            $success = 0;
	    error_msg("Got undef bytes back from sysread!\n");
	} 
        elsif ($num_read == 0) {
            $success = 0;
	    debug_msg("Got 0 bytes back from sysread: $client_buff_size = $end_byte - $position",2);
	    last;
	}
        
        # handle partial writes
        my $num_wrote = 0;
        while ($num_read) { 
	  my $num_wrote = syswrite(STDOUT,$buffer,$num_read,$num_wrote);
	  #error_msg("wrote 0 bytes") unless $num_wrote;
          if (!$num_wrote) {
            $success = 0;
            debug_msg("wrote 0 bytes",2);
            last LOOP;
          }
          $total_wrote += $num_wrote;
          $position    += $num_wrote;
          $num_read    -= $num_wrote;
	  if ($num_read) { 
            debug_msg("Short syswrite. Tried to write $num_read+$num_wrote, actually wrote $num_wrote.",2); 
            $success = 0;
            last LOOP;
            #last;
          }
        }
        #debug_msg("client_buff_size($client_buff_size) position($position) end_byte($end_byte)",2);
        if ($position == $end_byte) { last LOOP; }
    }
    close(READ_FILE);
    debug_msg("leaving return_file($cache_file)",3);
    $section = "main";
    return $success;
}


sub return_header {
    $section = "return_header";
    my ($mime,$file_base,$file_size,$start_byte,$end_byte) = @_;
    $mime        = $mime        || "application/octet-stream";
    $file_base   = $file_base   || "";
    $file_size  = $file_size  || 0;
    $start_byte = $start_byte || 0;
    $end_byte   = $end_byte   || 0;
    my $range_length = 1 + $end_byte - $start_byte;

    debug_msg("return_header($mime,$file_base,$file_size)\n",3);

    my $http_header;
    if ($range) {
      $http_header = "Status: 206 Partial content\n";
      $http_header .= "Content-Range: bytes $start_byte-$end_byte/$file_size\n";
      $http_header .= "Content-Length: $range_length\n";
    }
    else {
      $http_header = "Status: 200 OK\n";
      if ($file_size) { $http_header .= "Content-Length: $file_size\n"; }
    }
    # evil browser: Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt) requests 1024 bytes at a time
    $http_header .= "Accept-Ranges: bytes\n" unless ($remote_ua eq 'Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt)');

    $http_header .= "Content-Transfer-Encoding: binary\n";
    if ($file_base) { $http_header .= "Content-Type: $mime\n"; }
    $http_header .= "Connection: close\n\n";

    my $header_length = length($http_header);
    my $num_wrote = syswrite(STDOUT,$http_header);
    error_msg("Bad HTTP Header syswrite($!) tried($header_length) wrote($num_wrote)\n")
	unless ($header_length == $num_wrote);
    #debug_msg("HTTP header: $http_header",3);
    #debug_msg("Sent HTTP header file_base: ($file_base) length($header_length)",3);
    $section = "main";
}

sub create_xnode {
  my ($url,$md5,$file_size,$mime,$last_modified) = @_;
  debug_msg("creating xnode: $url,$md5,$file_size,$mime",2);
  my $stderr;
  my $last_line;
  open(LU, "$lors_bin_dir/lors_upload -d 10d -f $md5 2>&1 |") or error_msg("LORS error"); 
  while (<LU>) {
    print; # to keep the connection with the filler going
    chomp;
    $last_line = $_;
    $stderr .= $last_line;
  }
  debug_msg("last_line: $last_line",2);
  if ($last_line eq "End Success") {
    my $elapsed = (POSIX::times())[0] - $start;
    notify($redirector_ip,"add_xnode:$md5:$last_modified:$mime:$file_size:$elapsed:$url");
  }
  else {
    debug_msg("LORS failed: $stderr",2);
    my $cache_file = $md5 .".xnd";
    (1==unlink($cache_file)) or error_msg("Unable to Unlink($cache_file)($!)");
  }
}

sub refresh_xnode {
  my $cache_file = shift;
  $cache_file .= '.xnd';
  debug_msg("refresh_xnode($cache_file)",2);
  $|++; # autoflush to avoid time-out

  open(LR, "$lors_bin_dir/lors_refresh -d 2d $cache_file 2>&1 |") or error_msg("LORS error"); 
  while (<LR>) {
    print;
  }
}

sub return_xnode {
  my ($cache_file,$mime,$file_base,$start_byte,$end_byte) = @_;
  $cache_file .= '.xnd';
  debug_msg("return_xnode($cache_file)",2);
  $|++; # autoflush to avoid time-out

  open(LD, "$lors_bin_dir/lors_download $cache_file 2>/dev/null |") or error_msg("LORS error"); 
  while (<LD>) {
    print;
  }
  debug_msg("leaving return_xnode($cache_file)",2);
}

sub return_zip {
  my ($cache_file,$mime,$file_base) = @_;
  debug_msg("return_zip: cache_file($cache_file) mime($mime) file_base($file_base)",2);
  $|++; # autoflush to avoid time-out

  $total_wrote =0;
 debug_msg("$unzip_cmd -p $cache_file $file_base 2>/dev/null |",2);
  open(UZ, "$unzip_cmd -p $cache_file $file_base 2>/dev/null |") or error_msg("UNZIP error"); 
  #binmode(UZ);
  while (<UZ>) {
    $total_wrote += length($_);
    print;
  }
  debug_msg("leaving return_zip($cache_file)",2);
}


sub fail {
  my ($msg, $file) = @_;
  print "Status: 500 Internal Server Error\n";
  print "Content-type: text/plain\n\n";
  print "$msg\n";
  debug_msg("Exiting with error! $msg\n",1);
  (1==unlink($file)) or error_msg("Unable to Unlink($file)($!)");
  exit;
}

sub error_msg {
  my $msg = shift;
  debug_msg("Error: $msg,$!,". $request_uri ,0);
  #print STDERR "\nFCe($$): error_buffer:\n$error_buffer\n";
  print "Status: 500 Internal Server Error\n";
  print "Content-type: text/plain\n\n";
  print "An error occurred.\n";
  my $elapsed =(POSIX::times())[0] -$start; 
  notify($redirector_ip,"exit_error:$total_wrote:$elapsed:$md5:$remote_ip:$request_uri:$msg:$remote_ua");
  debug_msg("Exiting with error! elapsed($elapsed)\n",2);
  exit;
}

sub debug_msg {
  my ($msg,$level) = @_;
  if ($level <= $debug_level) {
    print STDERR "FC ($$):$level: $msg\n";
  }
  $error_buffer .= "FCe($$):$level: $msg\n";
}

sub signal_handler {
  my $signal = shift;
  my $elapsed =(POSIX::times())[0] -$start; 
  $section   = "" unless $section;
  $total_read = 0 unless $total_read;
  my $severity = 3;
  if ($signal eq "TERM") { $severity = 3; }
  if ($^S) { debug_msg("$signal signal:$section,$^S,$^E,$elapsed cs,total read($total_read)",$severity); }
  else {        debug_msg("$signal signal:$section,,$^E,$elapsed cs,total read($total_read)",$severity); }
}