#!/usr/bin/perl -w
#
# fserve.pl
#
# IRC-based file server for idiots
# Author: Mark Dominus (mjd-fserve+@plover.com)
# Copyright 2001 Mark Dominus.
#
# Based on dcctest.pl (sample program distributed with 
# POE::Component::IRC, by -- dennis taylor, <dennis@funkplanet.com>)
#
# To do: record privmessages more carefully
# add permanent bans
# add feature to forbid upload of certain kinds of files
# test max simultaneous get feature
# test re-upload feature
# some files should be free to download
# add better config mechanism---file-based, have admin command for
#    realoading config at run time.
#
# Add setup instructions


use strict;

my $SHUTDOWN;
my $HOME = die "You must configure the \$HOME variable";
my $FILE_ROOT = "$HOME/download"; # download area is here
my $STAGING = "$HOME/staging";  # should be sibling directory to download area
my $UPLOAD = "$HOME/upload";    # uploaded files are placed here
my $CREDIT = "$HOME/credit";    # this directory contains the credit database
my $MD5DB = "$HOME/DIGEST";     # Database of MD5 checksums
my $PAGES = "$HOME/Pages";      # record of pages to the owner 
my $LAST_MD5_LOAD = 0;          # Last time the MD5 database was examined
my $START_CREDIT = 100_000;     # new users get this many credits
my $CREDIT_FACTOR = 4;          # uploading 1 byte receives this many credits
my $MAX_DUPLICATES = 3;         # Ban user who uploads this many duplicates

# where does the bot hang out?
my $SERVER = 'irc.infobot.org'; 
# keys are channel names; values are banner frequencies (in seconds)
my %CHANNELS = ('#mjd' => 30);        

my $nick = sprintf("fserve%03d", rand(1000)); # My nick
my $LOG = "$HOME/LOG-$nick";    # Log file name

# Following items in seconds
my $HOUSEKEEPING_DELAY = 1;     # Run the housekeeping loop this often
my $IDLE_TIMEOUT = 300;         # idle chat sessions closed after this long
my $IDLE_TIMEOUT_WARN = 240;    # warn idle sessions after this long

my $MAX_GETS = 5;               # maximum number of simultaneous downloads
my $KEYPHRASE = '!feedme';      # IRC users say this to request a chat session
my $ADMIN_PASSWORD = "Abraxas";
my $MAX_SESSIONS = 6;           # refuse chat requests when this many in progress

## Public invitation banner
my @BANNER = (
              "Plover fserve.  Use '$KEYPHRASE' to enter.",
              "Start credit: $START_CREDIT.  Ratio: $CREDIT_FACTOR:1",
              "I like pie!.",
             );

## Also see ### WELCOME MESSAGE and ### RULES below

open LOG, ">> $LOG" or die "Couldn't open log file: $!; aborting";
sub LOG {
  print LOG scalar(localtime), " ", @_;
}
open PAGES, ">> $PAGES" or die "Couldn't open pages file: $!; aborting";
{ my $o = select PAGES; $|=1; select $o }
$| = 1; # Flush stdout too

#sub POE::Kernel::ASSERT_DEFAULT () { 1 }
#sub POE::Kernel::TRACE_DEFAULT () { 1 }
use POE::Kernel;
use POE::Session;
use POE::Component::IRC;
use DB_File;
use Fcntl ':flock';
use File::Basename;
use POSIX 'ceil';
use Digest::MD5;

chdir $STAGING or die "chdir $STAGING: $!";
#tie my %CREDIT => 'DB_File', $CREDIT, O_RDWR|O_CREAT, 0666
#  or die "Couldn't tie credit: $!";
select('LOG'); $| = 1; select('STDOUT');

# %S is the variable that records the active sessions
# %T records file downloads in progress
# %D is a table of MD5 digests for the files in /home/download
my (%S, %T, %D);

# This gets executed as soon as the kernel sets up this session.
sub _start {
  my ($kernel, $session) = @_[KERNEL, SESSION];
  LOG "Start state.\n";

  # Uncomment this to turn on more verbose POE debugging information.
  # $session->option( trace => 1 );

  # Make an alias for our session, to keep it from getting GC'ed.
  $kernel->alias_set( 'smileyninja' );

  # Ask the IRC component to send us all IRC events it receives. This
  # is the easy, indiscriminate way to do it.
  $kernel->post( 'test', 'register', 'all');

  # Start up the housekeeping thread
  $kernel->delay('housekeeping', 1);

  # Setting Debug to 1 causes P::C::IRC to print all raw lines of text
  # sent to and received from the IRC server. Very useful for debugging. 

  $kernel->post( 'test', 'connect', { Debug    => 0,
                                      Nick     => $nick,
                                      Server   => $SERVER,
                                      Port     => 6667,
                                      Username => 'fserve',
                                      Ircname  => 'Plover.com FServe', }
               );

  # adjust %CHANNELS data structure to include last announcement time
  for my $channel (keys %CHANNELS) {
    $CHANNELS{$channel} = [$CHANNELS{$channel}, 0];
  }
}

# convert 'yrlnry!mjd@plover.com' to 'yrlnry'
# callback functions sometimes get the one, sometimes the other
sub _nick {
  my $who = shift;
  my ($nick) = $who =~ /([^!]+)!/;
  defined $nick ? $nick : $who;
}

# After we successfully log into the IRC server, join the channels.
sub irc_001 {
  my ($kernel) = $_[KERNEL];
  LOG "Connected to server.\n";

  $kernel->post( 'test', 'mode', $nick, '+i' );
  for my $ch (keys %CHANNELS) {
    $kernel->post( 'test', 'join', $ch );
  }
}

sub irc_433 {
  die "Nickname already in use.\n";
}

sub _default {
  my ($state, $event, $args) = @_[STATE, ARG0, ARG1];

  $args ||= [];
  return if $event =~ /^irc_(nick|join|quit|mode|part|ctcp_action|dcc_get|dcc_send)$/;
  print "*** _DEFAULT $state -- $event @$args\n";
  return 0;
}

sub _stop {
  my ($kernel) = $_[KERNEL];

  print "Control session stopped.\n";
  $kernel->alias_remove( 'smileyninja' );
}

sub irc_disconnected {
  my ($server) = $_[ARG0];
  print "Lost connection to server $server.\n";
}

sub irc_error {
  my $err = $_[ARG0];
  print "Server error occurred! $err\n";
}

sub irc_socketerr {
  my $err = $_[ARG0];
  print "Couldn't connect to server: $err\n";
}

sub irc_kick {
  my ($who, $where, $isitme, $reason) = @_[ARG0 .. ARG4];

  print "Kicked from $where by $who: $reason\n" if $isitme eq $who;
}

sub irc_public {
  my ($kernel, $who, $where, $msg) = @_[KERNEL, ARG0 .. ARG2];
  $who = (split /!/, $who)[0];

  if ($msg =~ /^\Q$KEYPHRASE/) {
    LOG "Public keyphrase from $who; sending DCC chat request.\n";
    respond_to_keyphrase($kernel, $who);
  }

  return;
}


my %admin_command = 
  ('die' => sub { LOG "Magic word of death!\n";
                  exit 0; },    # Don't use this.
   # Use this instead
   'shutdown' => sub { LOG "Shutting down\n"; $SHUTDOWN = 1 }, 
   'unshutdown' => sub { LOG "Shutdown cancelled\n"; $SHUTDOWN = 0 }, 
   'kill' => sub {              # kick off a user
     my %args = @_;
     my $who = $args{ARGS}[0] || return;
     if (exists $S{$who}) { $S{$who}{dead} = 1 }
   },
   'eval' => sub {
     my %args = @_;
     my $command = $args{MESSAGE};
     return unless $command =~ s/^\s*eval\s+//;
     my $result = eval $command;
     $args{KERNEL}->post('test', 'privmsg', $args{WHO}, "Result: $result");
     $args{KERNEL}->post('test', 'privmsg', $args{WHO}, "Errors: $@") if $@;
   }, 
   'grant' => sub {             # increase or decrease credits
     my %args = @_;
     my ($who, $amount) = @{$args{ARGS}};
     credit_inc($who, $amount);
     if (exists $S{$who}) {
       if ($amount > 0) {
         dcctell($args{KERNEL}, $who, 
                 "The operator has given you a bonus of $amount credits.\n");
       } else {
         $amount *= -1;
         dcctell($args{KERNEL}, $who, 
                 "The operator has revoked $amount credits.\n");
       }
     }
   },
   'status' => sub {            # list current sessions
     my %args = @_;
     if (%S) {
       for my $u (sort keys %S) {
         my ($t) = time - $S{$u}{last};
         $args{KERNEL}->post
           ('test', 'privmsg', $args{WHO},
            "$u: $S{$u}{pwd} credit=$S{$u}{credit} last=$t gets=$S{$u}{gets}",
           );
       }
     } else {
       $args{KERNEL}->post
         ('test', 'privmsg', $args{WHO},
          "No users.",
         );
     }
   },
   'tell' => sub {
     my %args = @_;
     my $who = shift @{$args{ARGS}};
     if (exists $S{$who}) {
       dcctell($args{KERNEL}, $who, join(' ', @{$args{ARGS}}));
     } else {
       $args{KERNEL}->post
         ('test', 'privmsg', $who, join(' ', @{$args{ARGS}}));
     }
     $args{KERNEL}->post
       ('test', 'privmsg', $args{WHO}, "Done.");
   },
  );

sub irc_msg {
  my ($kernel, $sender, $trecip, $msg) = @_[KERNEL, ARG0 .. ARG2];
  $sender = _nick($sender);
  print qq{*** MESSAGE from $sender: "$msg"\n};
  if ($msg =~ /^\Q$KEYPHRASE/) {
    LOG "Private keyphrase from $sender\n";
    respond_to_keyphrase($kernel, $sender);
    return;
  } 

  my ($password, $cmd, @args) = split /\s+/, $msg;
  my $action = $admin_command{$cmd};
  if (defined $action && $password eq $ADMIN_PASSWORD) {
    $action->(KERNEL => $kernel, WHO => $sender, 
              ARGS => \@args, MESSAGE => $msg);
    return;
  } 

  if ($msg =~ /^\s*page\s+(.*)/i) {
    print PAGES scalar(localtime()), " <$sender> $msg\n";
    $kernel->post('test', 'privmsg', $sender, 
                  "Your message has been recorded.");
  } else {
  # Catchall
    $kernel->post('test', 'privmsg', $sender, 
                  "I am just a machine and can't respond to your message.",
                  "To access the fserve, say '$KEYPHRASE'.",
                  "To leave a message for my owner, say 'page <your message>'.",
                  "This is a recording.",
                 );
  }
}

sub irc_dcc_request {
  my ($kernel, $who, $type, $port, $magic, $filename, $size) =
    @_[KERNEL, ARG0 .. ARG5];
  my $nick = _nick($who);
  my $file = basename($filename);
  my $destfile = sub {
    my $file = basename(shift);
    _sanitize($file);
    "$UPLOAD/$file";
  };

  print "*** DCC $type request from $who ($S{$nick}{magic}) on port $port\n";
  if ($type eq 'SEND') {
    LOG "$who is sending $filename.\n";
    if ($S{$nick}{here}) {
      if (-e "$UPLOAD/$filename") {
        dcctell($kernel, $nick,
             "Sorry, I already seem to have the file '$filename'.  Please send a different file.",
               );
      } elsif ($S{$nick}{received}{$file} == $size) {
        LOG "*** $nick is trying to send $file, which they just got from me.";
        dcctell($kernel, $nick,
                "You just got that file from me.",
               );
        $S{$nick}{dead} = 1;
      } elsif ($filename =~ /^!!!!/) { 
        dcctell($kernel, $nick,
                "That filename begins with too many !'s.",
                "Please send a file with a normal name.",
               );
      } elsif ($filename =~ /(mpe?g|avi|divx|ra?m|mov|mp3|bmp)$/i) { 
        dcctell($kernel, $nick,
                "Thank you, but I do not want movie files.  Stills only, please.",
               );
      } else {
        dcctell($kernel, $nick,
             "Receiving file $filename.  I will notify you when it is finished.",
                     );
        $S{$nick}{last} = time if exists $S{$nick};
        $kernel->post( 'test', 'dcc_accept', $magic, $destfile->($filename) );
      }
    } else {
      print "*** Telling $nick to go away; I will not accept.\n";
      $kernel->post( 'test', 'privmsg', $nick,
                     "Sorry, I only accept files from people with open chat sessions.",
                     "This bug may be fixed in a future release.", 
                     "Please /msg me with '$KEYPHRASE' to request a chat session.",
                   );
    }
  } else {                      # $type is not SEND
    print "***** Unknown type; ignoring.\n";
  }
}



sub irc_dcc_start {
  my ($kernel, $magic, $who, $type, $port, $name, $size) =
    @_[KERNEL, ARG0 .. ARG5];

  print "*** DCC $type started from $who on port $port\n";
  if ($type eq 'CHAT') {
    $S{$who} = {pwd => '/', credit => get_credit($who), magic => $magic,
                last => time(), here => 1, gets => 0};
    LOG "DCC chat with $who starting.\n";

    ### WELCOME MESSAGE
    dcctell($kernel, $who,
            "Welcome to Plover fserve, $who.",
            "You have $S{$who}{credit} credits.",
           );

  } else {
    print "IGNORING dcc_start of type $type.\n";
  }
}

sub irc_dcc_get {
  my ($kernel, $magic, $who) = @_[KERNEL, ARG0, ARG1];
  
}

sub irc_dcc_done {
  my ($kernel, $magic, $who, $type, $port, $file, $size, $done) = @_[KERNEL, ARG0 .. ARG5];
  $who = _nick($who);
  print "*** irc_dcc_done **$magic $who, $type, $port, $file, $size, $done\n";
  print "***** $who -> $S{$who}{magic}\n";
  if (uc $type eq 'SEND') {
    LOG "DCC SEND of $file to $who is complete.\n";
    print "DCC $type to $who ($file) done: $size bytes transferred.\n";
#    $S{$who}{credit} -= $size;
    $S{$who}{gets}--;
    $S{$who}{last} = time;
    dcctell($kernel, $who,
            "Finished sending $file.  You now have $S{$who}{credit} credits",
           );
  } elsif (uc $type eq 'GET') {
    LOG "DCC GET of $file from $who is complete.\n";
    print "DCC $type from $who ($file) done: $size bytes transferred.\n";
    my $newmd5 = filesum($file);
    if (exists $D{$newmd5}) {
      my $oldfile = $D{$newmd5};
      LOG "* It is a duplicate of $oldfile!\n";
      if (exists $S{$who}) {
        if (++$S{$who}{duplicates} >= $MAX_DUPLICATES) {
          dcctell($kernel, $who,
                  "That file is the same as $oldfile.",
                  "Please stop wasting my time and yours.",
                 );
          $S{$who}{dead} = 1;
          LOG "* User $who was booted for sending too many duplicates!\n";
        } else {
          dcctell($kernel, $who,
                  "That file is the same as $oldfile.",
                  "No credit granted; sorry.",
                 );
        }
      }
    } else {                    # New, non-duplicate file
      $D{$newmd5} = $file;
      my $new_credit = $CREDIT_FACTOR * $size;
      my $basefile = basename($file);
      credit_inc($who, $new_credit);
      if (exists $S{$who}) {
        $S{$who}{duplicates} = 0;  # Accidents happen
        dcctell($kernel, $who,
                "I have received $basefile.",
                "You get $new_credit credits, for a total of $S{$who}{credit}",
               );
      }
    }
    unlink basename($file);     # The symlink in the staging area 
  } elsif (uc $type eq 'CHAT') {
    LOG "DCC chat with $who is complete.\n";
    print "DCC chat to $who complete.\n";
    $S{$who}{done} = 1;
    $S{$who}{here} = 0;
  }
#  print "*** Returning from irc_dcc_done.\n"
}

sub irc_dcc_error {
  my ($magic, $err, $who, $type, $port, $file) = @_[ARG0 .. ARG5];
  $who = _nick($who);
  LOG "*** irc_dcc_error: $magic $err $who $type $port $file\n";
  print "*** irc_dcc_error: $magic $err $who $type $port $file\n";
  print "DCC $type to $who ($file) failed: $err.\n";
  if ($type eq 'SEND') {
    LOG "SEND of file $file to $who failed\n";
    dcctell($_[KERNEL], $who,
         "Delivery of file $file failed; $T{$file} credits given back.");
    credit_inc($who, $T{$file});
  } elsif ($type eq 'CHAT') {
    $S{$who}{dead} = 1;
    LOG "Chat with $who failed; they are dead.\n";
  } elsif ($type eq 'GET') {
    LOG "GET of file $file from $who failed\n";
    $S{$who}{gets}--;
    unlink $file;
    my $shortfile = basename($file);
    dcctell($_[KERNEL], $who,
         "Delivery of file $shortfile was incomplete; no credits awarded.");
  }
}

my %commands = (
                credit => \&cmd_show,
                pwd => \&cmd_show,
                'cd..' => sub { cmd_cd(@_, '..')},
                cd => \&cmd_cd,
                '!list' => \&cmd_ls,
                ls => \&cmd_ls,
                dir => \&cmd_ls,
                dur => \&cmd_ls, # Common typo
                quit => \&cmd_quit,
                exit => \&cmd_quit,
                bye => \&cmd_quit,
                rules => \&cmd_rules,
                get => \&cmd_get,
#                die => \&cmd_die,
                help => \&cmd_UNKNOWN,
               );

sub irc_dcc_chat {
  my ($kernel, $magic, $who, $port, $text) = @_[KERNEL, ARG0 .. ARG3];
  LOG "DCC Chat: $who says ($text)\n";
  print "*** irc_dcc_chat: **$magic $who $port $text\n";
#  $kernel->post( 'test', 'dcc_chat', $magic, "$who said:\n", $text );
  $text =~ s/^\s+//;
  $text =~ s/\s+$//;
  my ($cmd, @args) = split /\s+/, $text;
  my $action = $commands{lc $cmd} || \&cmd_UNKNOWN;
  $S{$who}{last} = time;
  $S{$who}{warned} = 0;
  print "*** Dispatching command $cmd <$who> @args\n";
  $action->($kernel, $cmd, $magic, $who, @args);
}

sub housekeeping {
  my ($kernel) = @_[KERNEL];
#  LOG "***** HOUSEKEEPING\n";
  my (@dead, @not_here);
  for my $who (keys %S) {
#    print "**** <$who>\n";
    if (not $S{$who}{here}) {
#      print "***** (not here).\n";
      push @not_here, $who;
      next;
    }
#    print "**** ", map {"$  => $S{$who}{$_}, "} (keys %{$S{$who}});
#    print "\n";
    if ($S{$who}{dead}) {
#      print "***** (dead).\n";
      LOG "$who is dead.\n";
      push @dead, $who;
    } elsif ($S{$who}{last} + $IDLE_TIMEOUT < time) {
      LOG "$who has timed out.\n";
      dcctell($kernel, $who, "Idle time exceeded.  Bye.");
      $S{$who}{dead} = 1;
    } elsif ($S{$who}{last} + $IDLE_TIMEOUT_WARN < time
             &&  not $S{$who}{warned}) {
      LOG "$who gets an idle warning.\n";
      my $time = $IDLE_TIMEOUT - $IDLE_TIMEOUT_WARN;
      dcctell($kernel, $who, "Idle connection will be closed in $time seconds.");
      $S{$who}{warned} = 1;
    }
  }
  
  delete @S{@not_here};

  for my $dead (@dead) {
    LOG "Closing chat with $dead.\n";
    $kernel->post( 'test', 'dcc_close', $S{$dead}{magic});
    _cleanup_user($dead);
  }

  if ($SHUTDOWN && !%S) {
    LOG "Last user has left.  Exiting.\n";
     $kernel->signal( $kernel, 'KILL');
  }

  unless ($SHUTDOWN || keys(%S) >= $MAX_SESSIONS) {
    for my $ch (keys %CHANNELS) {
      my ($frequency, $last_time) = @{$CHANNELS{$ch}}; 
      if ($last_time + $frequency < time()) { 
        print "Sending banner to $ch.\n";
        $CHANNELS{$ch}[1] = time;
        $kernel->post( 'test', 'privmsg', $ch, @BANNER);
      }
    }
  }

  if ($LAST_MD5_LOAD < (stat $MD5DB)[9]) {
    load_md5sums();
  }

  $kernel->delay('housekeeping',$HOUSEKEEPING_DELAY);
}

################################################################
#
# Utility functions

sub respond_to_keyphrase {
  my ($kernel, $who) = @_;
  return if exists $S{$who} and $S{$who}{here};
  if (-e "$HOME/bans/\L$who") {
    LOG "... but they are banned!\n";
    $kernel->post( 'test', 'privmsg', $who, 
                   "You are permanently banned.", 
                   "Go away." 
                 );
  } elsif ($who =~ /^guest\d+$/i) {
    LOG "... but they're a guest.\n";
    $kernel->post( 'test', 'privmsg', $who, 
                   "Sorry, Plover fserve is not open to guest users.", 
                 );
  } elsif ($SHUTDOWN) {
    LOG "... but the fserve is shutting down!\n";
    $kernel->post( 'test', 'privmsg', $who, 
                   "Sorry, Plover fserve is shutting down temporarily.", 
                   "Please try again in a few minutes." 
                 );
 }  elsif (keys %S >= $MAX_SESSIONS) {
    LOG "... but the fserve is full!\n";
    $kernel->post( 'test', 'privmsg', $who, 
                   "Sorry, Plover fserve is presently full.", 
                   "Please try again in a few minutes." 
                 );
  } else {
    LOG "Sending DCC chat request to $who\n";
    $kernel->post( 'test', 'dcc', $who, "chat" );
  }
}


################################################################
#
# Command actions

sub cmd_UNKNOWN {
  my ($kernel, $cmd, $magic, $who, @args) = @_;
  dcctell($kernel, $who,
          "credit   - show current credits ($S{$who}{credit})",
          "pwd      - show current directory ($S{$who}{pwd})",
          "cd DIR   - change current directory to DIR",
          "cd ..    - go up one directory",
          "ls       - compact listing of files in current directory",
          "dir      - longer listing with file sizes",
          "get FILE - get a file",
          "quit     - quit",
         );
}

sub cmd_rules {
  my ($kernel, $cmd, $magic, $who) = @_;

  ### RULES
  dcctell($kernel, $who, 
          "There are no rules.",
         );
}

sub cmd_die {
  my ($kernel, $cmd, $magic, $who, @args) = @_;
  dcctell($kernel, $who, 
                 "Goodbye, cruel world!",
                 );
  exit 0;
}

sub cmd_get {
  my ($kernel, $cmd, $magic, $who, $file) = @_;

  unless (defined $file && $file =~ /\S/) {
    dcctell($kernel, $who, 
            "Use 'get FILE' to get the file named 'FILE'.",
            "Capital and small letters are NOT THE SAME.",
           );
  }

  

  my $fullpath = _fixpath("$S{$who}{pwd}/$file");
  my $truepath = "$FILE_ROOT/$fullpath";
  my $size = -s $truepath;

  print "Request to GET '$file' by <$who> ($S{$who}{credit} credit)\n";
  print "Full path: $fullpath; true path: $truepath size=$size.\n";

  if (-d $truepath) {
    dcctell($kernel, $who, 
                   "That is a directory.  To enter it, use 'cd $file'."
                 );
    return;
  }

  if (! defined $size) {
    my @files = file_approx_match($kernel, $S{$who}{pwd}, $file, 
                                  sub { -f "$_[0]/$_[1]" });
    if (@files != 1) {
      file_approx_warn($kernel, $who, @files);
      return;
    } else {
      $file = $files[0];
      $fullpath = _fixpath("$S{$who}{pwd}/$file");
      $truepath = "$FILE_ROOT/$fullpath";
      $size = -s $truepath;
    }
  }

  if ($S{$who}{credit} < $size) {
    dcctell($kernel, $who, 
            "For $file you would need $size credits",
            "but you have only $S{$who}{credit}.",
            "Use   /dcc send $nick yourfile.jpg  to get more credit.",
           );
    return;
  }

  if ($S{$who}{gets} >= $MAX_GETS) {
    dcctell($kernel, $who, 
            "You already have $S{$who}{gets} in progress.",
            "Please wait until you have fewer than $MAX_GETS.",
           );
    return;
  }

  my ($shortfile) = basename($file);
  unlink $shortfile;
  unless (symlink $truepath, $shortfile) {
    die "symlink: $!" unless $! =~ /exists/;
  }

  credit_inc($who, -$size);
  $kernel->post( 'test', 'dcc', $who, 'send', "$shortfile" );
  dcctell($kernel, $who, 
                 "Sending $shortfile. You now have $S{$who}{credit} credits.");
  $T{$shortfile} = $size;
  $S{$who}{gets}++;

  # To detect if they try to give it back to us later
  $S{$who}{received}{$shortfile} = $size;
}

sub cmd_show {
  my ($kernel, $cmd, $magic, $who, @args) = @_;
  my $S = $S{$who};
  if (exists $S->{lc $cmd}) {
    dcctell($kernel, $who, 
                   "$cmd: $S->{lc $cmd}"
                 );
  } else {
    dcctell($kernel, $who, 
                   "Can't find session for <$who>!"
                 );
  }
}

sub cmd_cd {
  my ($kernel, $cmd, $magic, $who, $newdir) = @_;

  unless (defined $newdir && $newdir =~ /\S/) {
    dcctell($kernel, $who, 
                   "You must say what directory to move into.",
                   "Use 'cd ..' to move up one level and 'cd /' to return to the top.",
                 );
    return;
  }

  my $dir = $S{$who}{pwd};
  $newdir =~ tr{\\}{/};
  if ($newdir =~ m{^/}) {       # Absolute path
    $dir = $newdir;
  } else {
    if ($newdir eq '..') { 
      $dir = _fixpath("$dir/..");
    } else { 
      my @guesses = file_approx_match($kernel, $dir, $newdir, 
                                      sub { -d "$_[0]/$_[1]" } );
      if (@guesses != 1) {
        file_approx_warn($kernel, $who, @guesses);
        return;
      }  else {
        $dir = _fixpath("$dir/$guesses[0]");
      }
    }
  }

  if (! -e "$FILE_ROOT/$dir") {
    dcctell($kernel, $who, 
                   "Directory $newdir does not exist",
                 );
  } elsif (! -d "$FILE_ROOT/$dir") {
    dcctell($kernel, $who, 
                   "$newdir is not a directory",
                 );
  } else {
    $S{$who}{pwd} = $dir;
    dcctell($kernel, $who, 
                   "Current directory is now $dir.",
                 );
    if (-e "$FILE_ROOT/$dir/README") {
      dcctell_file($kernel, $who, "$FILE_ROOT/$dir/README") ;
    }
  }
}

sub cmd_ls {
  my ($kernel, $cmd, $magic, $who) = @_;
  my $dir = $S{$who}{pwd};
  unless (opendir D, "$FILE_ROOT/$dir") {
    dcctell($kernel, $who, 
                   "Can't read current directory <$dir>",
                   "Full path <$FILE_ROOT/$dir>",
                   $!,
                 );
    return;
  }
  my @items = sort grep {$_ !~ /^\./ && $_ ne 'README'} readdir D;
  if ($cmd eq 'ls') {
    my $COLUMNS = 4;
    my $curcol = $COLUMNS;
    my $fmt = "%-15s";
    my @cols;
    while (@items) {
      my $colsize = ceil(@items/$curcol);
      print "**** Splicing column $curcol: $colsize items out of ", scalar(@items), "\n";
      $curcol--;
      push @cols, [splice @items, 0, $colsize];
    }
    @cols = ([]) unless @cols;
    while (@{$cols[0]}) {
      my @row;
      for (0..($COLUMNS-1)) {
        my $entry = shift @{$cols[$_]};
        push @row, $entry if defined $entry;
      }
      dcctell($kernel, $who, 
              sprintf(join(" ", ($fmt) x @row), 
                      map {-d "$FILE_ROOT/$dir/$_" ? "$_/": $_} @row)
             );
    }
  } else {
    dcctell($kernel, $who, 
            map{-d "$FILE_ROOT/$dir/$_" ?
                  sprintf("%19s   (DIR)", $_) :
                    sprintf("%19s %8d", $_, -s "$FILE_ROOT/$dir/$_") }
            @items
           );
  }
  dcctell($kernel, $who, 
          "-- End of listing", );
}

sub cmd_quit {
  my ($kernel, $cmd, $magic, $who) = @_;
  $who = _nick($who);
  dcctell($kernel, $who, "Bye.");
  $S{$who}{dead} = 1;
}

sub _cleanup_user {
  my $who = _nick(shift());
  print "*** Cleaning up user $who\n";
  set_credit($who, $S{$who}{credit});
  delete $S{$who};
}

sub _sanitize {
  for my $a (@_) {
    $a =~ tr/A-Z0-9a-z.-/_/c;
  }
}

sub _fixpath {
  my $path = shift;
  my @components = split m{/}, $path;
  my $abs = ($path =~ m{^/} ? '/' : '');
  my @stack;
  for (@components) {
    next if $_ eq '.' || $_ eq '' ;
    if ($_ eq '..') { pop @stack; }
    else { push @stack, $_ }
  }
  if (@components) {
    return $abs . join '/', @stack;
  } else {
    return $abs;
  }
  
}

# Arguments: $kernel = POE Kernel object
# $dir = real path of directory in which to search
# $guess = file we are trying to locate in this directory
# $filter = predicate function that returns only acceptable files
# Return list of matches
sub file_approx_match {
  my ($kernel, $dir, $guess, $filter) = @_;
#  print "Guessing '$guess' in '$dir'\n";
  my @good;
  while (<$FILE_ROOT/$dir/*>) {
    my $short = basename($_);
#    print "  checking $short\n";
    if ($short eq $guess) {
#      print "Exact match!\n";
      push @{$good[0]}, $short;
    }
    next unless $filter->("$FILE_ROOT/$dir", $short);
    if (lc $short eq lc $guess) {
      push @{$good[1]}, $short;
    } elsif (substr($short, 0, length($guess)) eq $guess) {
      push @{$good[2]}, $short;
    } elsif (lc substr($short, 0, length($guess)) eq lc $guess) {
      push @{$good[3]}, $short;
    }
  }
  my @best_matches = ();
  for my $goodlist (@good) {
    @best_matches = @$goodlist, last if $goodlist && @$goodlist;
  }
#  print "Near misses: @best_matches!\n";
  @best_matches;
}

# Issue warning about filename mismatches:
# @good is a list of alternative possibilities
sub file_approx_warn {
  my ($kernel, $who, @good) = @_;
  if (@good == 0) {
    dcctell($kernel, $who,
           "No such file.");
  } elsif (@good == 1) {
    dcctell($kernel, $who,
           "Perhaps you meant     @good  ?");
  } elsif (@good > 1) {
    dcctell($kernel, $who,
           "Perhaps you meant one of these:  @good");
  }
}

sub dcctell {
  my ($kernel, $who, @text) = @_;
  my $magic = $S{$who}{magic};
  if ($S{$who}{here}) {
    print "** Telling $who:\n";
  } else {
    print "** Trying to tell $who who is not here:\n";
    if (defined $magic) {
      print "** Magic number is $magic.\n";
    } else {
      print "***** NO MAGIC NUMBER!\n";
    }
  }
  for (@text) {
    print "***  ", $_, "\n";
  }
  return unless defined $magic && $S{$who}{here};
  $kernel->post( 'test', 'dcc_chat', $magic, @text);
}

sub dcctell_file {
  my ($kernel, $who, $file) = @_;
  open F, "< $file" or return;
  my @lines = <F>;
  chomp @lines;
  dcctell($kernel, $who, @lines);
  close F;
}

sub near_match {
  my ($name, $dir, $filter) = @_;
  local *D;
  opendir D, $dir or return;
  my @names = grep { $_ ne '.' && $_ ne '..' && $filter->($_, $dir) } 
    readdir D;
  my @near_misses;
  for my $n (@names) {
    return $n if $n eq $name;
    push @near_misses, $n if lc $n eq lc $name;
  }
  return wantarray ? @near_misses : $near_misses[0];
}


################################################################
# Credit

sub get_credit {
  my $who = shift;
  print "*** get_credit($who)\n";
  my $file = _credit_file($who);
  my $LOCK = credit_lock();
  if (-e $file) {
    unless (open C, "< $file") {
      LOG "** Couldn't open credit file <$file>: $!\n";
      return 0;
    }
    my $credit = <C>;
    chomp $credit;
    close C;
    return $credit;
    print "**** ... yields $credit\n";
  } else {
    init_credit($who);
    print "**** ... yields $START_CREDIT by default\n";
    return $START_CREDIT;
  }
}

# warning: this does NOT lock the credit database
# you should have the lock already when you call this
sub init_credit {
  my $who = shift;
  my $file = _credit_file($who);
  unless (open C, "> $file") {
    LOG "** Couldn't open credit file <$file> for writing: $!\n";
    return 0;
  }
  print C $START_CREDIT;
  close C;
  return
}

sub set_credit {
  my ($who, $credit) = @_;
  print "*** set_credit($who, $credit)\n";
  my $file = _credit_file($who);
  my $LOCK = credit_lock();
  unless (open C, "> $file") {
    LOG "** Couldn't open credit file <$file> for writing: $!\n";
    return 0;
  }
  print C $credit;
  close C;
  return;
}

sub credit_inc {
  my ($who, $how_much) = @_;
  if ($how_much > 0) {
    LOG "Awarding $how_much credits to $who.\n";
  } else {
    LOG "Deducting ", -$how_much, " credits from $who.\n";
  }
  if (exists $S{$who} && defined $S{$who}{credit}) {
    $S{$who}{credit} += $how_much;
  } else {
    my $new_credit = get_credit($who)+$how_much;
    set_credit($who, $new_credit);
  }
}

sub credit_lock {
#  LOG "* credit_lock...\n";
  my $lockfile = "$CREDIT/!LOCK";
  open my $fh, "+> $lockfile" or die "Couldn't open credit lockfile: $!; aborting";
  flock $fh, LOCK_EX or die "Couldn't lock credit lockfile: $!; aborting";
#  LOG "* got lock...\n";
  bless $fh => 'LOCK';
}

sub _credit_file {
  "$CREDIT/\L$_[0]";
}

sub LOCK::DESTROY {
  my $self = shift;
#  LOG "* unlock...\n";
  close $self;
}

################################################################
# MD5 sums

sub load_md5sums {
  local ($_, *D);
  unless (open D, "< $MD5DB") {
    LOG "*** Couldn't open MD5 database $MD5DB: $!; continuing...\n";
    return;
  }
  while (<D>) {
    chomp;
    my ($sum, $file) = split / /, $_, 2;
    $D{$sum} = $file;
  }
  $LAST_MD5_LOAD = time;
  LOG "*** $. MD5 sums loaded.\n";
}

sub filesum {
  my $file = shift;
  open my $fh, $file or return undef;
  return Digest::MD5->new->addfile($fh)->b64digest;  
}

################################################################
#
# here's where execution starts.

# Set 'trace' to 1 to get some more debugging information.
POE::Component::IRC->new( 'test') or
  die "Can't instantiate new IRC component!\n";
POE::Session->new( 'main' => [qw(_start _stop _default irc_001 irc_kick
				 irc_disconnected irc_error irc_socketerr
				 irc_dcc_done irc_dcc_error irc_dcc_request
				 irc_public irc_msg irc_dcc_chat
                                 irc_dcc_start housekeeping
                                 irc_433)]);

$poe_kernel->run();

exit 0;
