#!/usr/bin/perl -w -T
#-----------------------------------------------------------------------------
#
#  Copyright (C) 2002 Ryan C. Gordon (icculus@icculus.org)
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
#
#-----------------------------------------------------------------------------


# !!! TODO: Let [img] tags nest inside [link] tags.


use strict;             # don't touch this line, nootch.
use warnings;           # don't touch this line, either.
use POSIX qw(strftime); # or this, I guess.
use File::Basename;     # blow.
use File::Spec;         # bitch.
use IO::Select;         # bleh.
use Cwd 'abs_path';     # aka realpath()
use MIME::Base64;

my $version = "0.0.3";

#-----------------------------------------------------------------------------#
#             CONFIGURATION VARIABLES: Change to suit your needs...           #
#-----------------------------------------------------------------------------#

# This is a the hostname you want to claim to be...
#  This reports "Finger info for $user\@$host ..." in the web interface,
#  and is used for listing finger requests to finger clients:
#   "Finger $user?section=sectionname\@$host", etc.
my $host = 'icculus.org';

# The processes path is replaced with this string, for security reasons, and
#  to satisfy the requirements of Taint mode. Make this as simple as possible.
#  Currently, the only thing that uses the PATH environment var is the
#  "fortune" fakeuser, which can be safely removed.
my $safe_path = '/usr/bin:/usr/local/bin';

# Turn the process into a daemon. This will handle creating/answering socket
#  connections, and forking off children to handle them. This flag can be
#  toggled via command line options (--daemonize, --no-daemonize, -d), but
#  this sets the default. Daemonizing tends to speed up processing (since the
#  script stays loaded/compiled), but may cause problems on systems that
#  don't have a functional fork() or IO::Socket::INET package. If you don't
#  daemonize, this program reads requests from stdin and writes results to
#  stdout, which makes it suitable for command line use or execution from
#  inetd and equivalents.
my $daemonize = 0;
my $background = 1;
my $dropprivs = 1;

# This is only used when daemonized. Specify the port on which to listen for
#  incoming connections. The RFC standard finger port is 79.
my $server_port = 8080;

# Set this to immediately drop priveledges by setting uid and gid to these
#  values. Set to undef to not attempt to drop privs. You will probably need
#  to leave these as undef and run as root (risky!) if you plan to enable
#  $the use_homedir variable, below.
#my $wanted_uid = undef;
#my $wanted_gid = undef;
my $wanted_uid = 1056;  # (This is the uid of "finger" ON _MY_ SYSTEM.)
my $wanted_gid = 971;   # (This is the gid of "iccfinger" ON _MY_ SYSTEM.)

# This is only used when daemonized. Specify the maximum number of finger
#  requests to service at once. A separate child process is fork()ed off for
#  each request, and if there are more requests then this value, the extra
#  clients will be made to wait until some of the current requests are
#  serviced. 5 to 10 is usually a good number. Set it higher if you get a
#  massive amount of finger requests simultaneously.
my $max_connects = 10;

# This is how long, in seconds, before an idle connection will be summarily
#  dropped. This prevents abuse from people hogging a connection without
#  actually sending a request, without this, enough connections like this
#  will block legitimate ones. At worst, they can only block for this long
#  before being booted and thus freeing their connection slot for the next
#  guy in line. Setting this to undef lets people sit forever, but removes
#  reliance on the IO::Select package. Note that this timeout is how long
#  the user has to complete the read_request() function, so don't set it so
#  low that legitimate lag can kill them. The default is usually safe.
my $read_timeout = 30;

# Set this to non-zero to log all finger requests via the standard Unix
#  syslog facility (requires Sys::Syslog qw(:DEFAULT setlogsock) ...)
my $use_syslog = 1;

# This is the maximum size, in bytes, that a finger request can be. This is
#  to prevent malicious finger clients from trying to fill all of system
#  memory.
my $max_request_size = 512;

# You can screw up your output with this, if you like.
# You can append "?debug=1" to your finger request to enable this without
# changing the source.
my $debug = 0;

# Defaults for authorization to download file. Leave blank for none.
my $username = '';
my $password = '';
my $realm = 'Restricted area';

# filename to download.
my $filename = '';
my $mimetype = 'application/octet-stream';

# Server ID.
my $servername = 'ServeOneUp';
my $hosttype = 'MS-DOS 3.1';

#-----------------------------------------------------------------------------#
#     The rest is probably okay without you laying yer dirty mits on it.      #
#-----------------------------------------------------------------------------#

my $chopped = '';

sub read_request {
    my $retval = '';
    my $count = 0;
    my $s = undef;
    my $elapsed = undef;
    my $starttime = undef;

    if (defined $read_timeout) {
        $s = new IO::Select();
        $s->add(fileno(STDIN));
        $starttime = time();
        $elapsed = 0;
    }

    while (1) {
        if (defined $read_timeout) {
            my $ready = scalar($s->can_read($read_timeout - $elapsed));
            return undef if (not $ready);
            $elapsed = (time() - $starttime);
        }

        my $ch;
        my $rc = sysread(STDIN, $ch, 1);
        return undef if ($rc != 1);
        if ($ch ne "\015") {
            return($retval) if ($ch eq "\012");
            $retval .= $ch;
            $count++;
            return($retval) if ($count >= $max_request_size);
        }
    }

    return(undef);  # shouldn't ever hit this.
}


sub replyError {
    my $err = shift;
    my $desc = shift;

    my $d = strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime);
    print("HTTP/1.0 $err $desc\r\n");
    print("Server: $servername/$version ($hosttype)\r\n");
    print("Date: $d\r\n");
    print("Allow: GET\r\n");
    print("Connection: close\r\n");
    print("WWW-Authenticate: basic realm=\"$realm\"\r\n") if ($err == 401);
    print("Content-Type: text/html; charset=iso-8859-1\r\n");
    print("Expires: $d\r\n");
    print("\r\n");
    print("<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\r\n");
    print("<HTML><HEAD>\r\n");
    print("<TITLE>$err $desc</TITLE>\r\n");
    print("</HEAD><BODY>\r\n");
    print("<H1>$desc</H1>\r\n");
    #print("<P>$text<P>\r\n");
    print("<HR>\r\n");
    print("<ADDRESS>$servername/$version Server</ADDRESS>\r\n");
    print("</BODY></HTML>\r\n\r\n")
}

sub passAuth {
    my $authstr = shift;

    if ((defined $authstr) and ($authstr =~ s/\A\s*Basic\s+//i)) {
        my $decoded = decode_base64($authstr);
        #syslog('info', "auth string [$decoded].\n");
        if ($decoded =~ /\A(.*?):(.*?)\Z/) {
            return(1) if (($1 eq $username) and ($2 eq $password));
        }
    }

    replyError(401, 'Authorization Required');
    #replyError(403, 'Forbidden');
    return(0);
}

sub server_mainline {
    my %request;

    while (1) {
        my $query_string = read_request();
        %request = undef, last if (not defined $query_string);
        last if ($query_string eq '');
        next if not ($query_string =~ /\A([a-zA-Z].*?)\s+(.*?)\s*\Z/);
        my ($key, $val) = ($1, $2);
        $key =~ tr/A-Z/a-z/;
        $request{$key} = $val;
    }

    if (not %request) {
        my $syslog_text = "input timeout or bogus request. Dropped client.\n";
        print($syslog_text);  # tell the client, if they care.
        syslog('info', $syslog_text) if ($use_syslog);
        return(0);
    }

    my $get = $request{'get'};
    if (not defined $get) {
        replyError(401, 'Invalid request');
        return(0);
    }

    if ($use_syslog) {
        my $syslog_text = "request: \"GET $get\"\n";
        syslog('info', $syslog_text);
    }

    if ($password ne '') {
        my $auth = $request{'authorization:'};
        return(0) if not passAuth($auth);
    }

    $get =~ s#\A/+##;
    $get =~ s#\s*HTTP.*\Z##;
    if ($get ne $chopped) {
        replyError(404, 'Not found');
        return(0);
    }

    if (not open(CONTENT, '<', $filename)) {

        replyError(404, "Can't open: $!");
        return(0);
    }

    # okay, feed them the file.
    my $siz = (stat(CONTENT))[7];
    my $d = strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime);
    print("HTTP/1.0 200 OK\r\n");
    print("Server: $servername/$version ($hosttype)\r\n");
    print("Date: $d\r\n");
    print("Allow: GET\r\n");
    print("Connection: close\r\n");
    print("Expires: $d\r\n");
    print("Content-Length: $siz\r\n");
    print("Content-Type: $mimetype\r\n"); #; charset=iso-8859-1\r\n"
    print("\r\n");

    my $bytes = '';
    while (1) {
        my $rc = sysread(CONTENT, $bytes, 256 * 1024);
        last if ($rc <= 0);
        print $bytes;
    }

    close(CONTENT);
    return(0);
}


sub syslog_and_die {
    my $err = shift;
    $err .= "\n";
    syslog("info", $err) if ($use_syslog);
    die($err);
}


sub go_to_background {
    use POSIX 'setsid';
    chdir('/') or syslog_and_die("Can't chdir to '/': $!");
    open STDIN,'/dev/null' or syslog_and_die("Can't read '/dev/null': $!");
    open STDOUT,'>/dev/null' or syslog_and_die("Can't write '/dev/null': $!");
    defined(my $pid=fork) or syslog_and_die("Can't fork: $!");
    exit if $pid;
    setsid or syslog_and_die("Can't start new session: $!");
    open STDERR,'>&STDOUT' or syslog_and_die("Can't duplicate stdout: $!");
    syslog("info", "Daemon process is now detached") if ($use_syslog);
}


sub drop_privileges {
    delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
    $ENV{'PATH'} = $safe_path;
    $) = $wanted_gid if (defined $wanted_gid);
    $> = $wanted_uid if (defined $wanted_uid);
}


sub signal_catcher {
    my $sig = shift;
    syslog("info", "Got signal $sig. Shutting down.") if ($use_syslog);
    exit 0;
}


my @kids;
use POSIX ":sys_wait_h";
sub reap_kids {
    my $i = 0;
    my $x = scalar(@kids);
    while ($i < scalar(@kids)) {
        my $rc = waitpid($kids[$i], &WNOHANG);
        if ($rc != 0) {  # reaped a zombie.
            splice(@kids, $i, 1); # take it out of the array.
        } else {  # still alive, try next one.
            $i++;
        }
    }

    $SIG{CHLD} = \&reap_kids;  # make sure this works on crappy SysV systems.
}


sub daemon_upkeep {
    # no-op.
}


sub parse_cmdline {
    foreach (@_) {
        chomp;
        s/\A\s*//;
        s/\s*\Z//;
        next if ($_ eq '');
        if (s/\A--config=(.*?)\Z/$1/) {
            open(CFG, '<', $_) or die("Can't open $_: $!\n");
            my @vals = <CFG>;
            close(CFG);
            parse_cmdline(@vals);
            next;
        }
        $daemonize = 1, next if $_ eq '--daemonize';
        $daemonize = 1, next if $_ eq '-d';
        $daemonize = 0, next if $_ eq '--no-daemonize';
        $use_syslog = 1, next if $_ eq '--syslog';
        $use_syslog = 0, next if $_ eq '--no-syslog';
        $background = 0, next if $_ eq '--no-background';
        $background = 1, next if $_ eq '--background';
        $dropprivs = 0, next if $_ eq '--no-dropprivs';
        $dropprivs = 1, next if $_ eq '--dropprivs';
        $server_port = $_, next if s/\A--port=(.*?)\Z/$1/;
        $filename = $_, next if s/\A--filename=(.*?)\Z/$1/;
        $mimetype = $_, next if s/\A--mimetype=(.*?)\Z/$1/;
        $username = $_, next if s/\A--username=(.*?)\Z/$1/;
        $password = $_, next if s/\A--password=(.*?)\Z/$1/;
        $realm = $_,    next if s/\A--realm=(.*?)\Z/$1/;
        die("Unknown command line \"$_\".\n");
    }
}

# Mainline.
parse_cmdline(@ARGV);

die("No content file specified.\n") if ($filename eq '');
$chopped = basename($filename); # Chop path off content filename.
$filename = File::Spec->catfile(abs_path(dirname($filename)), basename($filename));

if ($use_syslog) {
    use Sys::Syslog qw(:DEFAULT setlogsock);
    setlogsock("unix");
    openlog("ServeOneUp", "user") or die("Couldn't open syslog: $!\n");
}

my $retval = 0;
if (not $daemonize) {
    drop_privileges();
    $retval = server_mainline();
    exit $retval;
}

# The daemon.

if ($use_syslog) {
    syslog("info", "ServeOneUp daemon $version starting up...");
}

go_to_background() if $background;

# reap zombies from client forks...
$SIG{CHLD} = \&reap_kids;
$SIG{TERM} = \&signal_catcher;
$SIG{INT} = \&signal_catcher;

use IO::Socket::INET;
my $listensock = IO::Socket::INET->new(LocalPort => $server_port,
                                       Type => SOCK_STREAM,
                                       ReuseAddr => 1,
                                       Listen => $max_connects);

syslog_and_die("couldn't create listen socket: $!") if (not $listensock);

my $selection = new IO::Select( $listensock );
drop_privileges() if ($dropprivs);

if ($use_syslog) {
    syslog("info", "Now accepting connections (max $max_connects" .
                    " simultaneous on port $server_port).");
}

while (1)
{
    # prevent connection floods.
    daemon_upkeep(), sleep(1) while (scalar(@kids) >= $max_connects);

    # if timed out, do upkeep and try again.
    daemon_upkeep() while not $selection->can_read(10);

    # we've got a connection!
    my $client = $listensock->accept();
    if (not $client) {
        syslog("info", "accept() failed: $!") if ($use_syslog);
        next;
    }

    my $ip = $client->peerhost();
    syslog("info", "connection from $ip") if ($use_syslog);

    my $kidpid = fork();
    if (not defined $kidpid) {
        syslog("info", "fork() failed: $!") if ($use_syslog);
        close($client);
        next;
    }

    if ($kidpid) {  # this is the parent process.
        close($client);  # parent has no use for client socket.
        push @kids, $kidpid;
    } else {
        $ENV{'TCPREMOTEIP'} = $ip;
        close($listensock);   # child has no use for listen socket.
        local *FH = $client;
        open(STDIN, "<&FH") or syslog_and_die("no STDIN reassign: $!");
        open(STDERR, ">&FH") or syslog_and_die("no STDERR reassign: $!");
        open(STDOUT, ">&FH") or syslog_and_die("no STDOUT reassign: $!");
        my $retval = server_mainline();
        close($client);
        exit $retval;  # kill child.
    }
}

close($listensock);  # shouldn't ever hit this.
exit $retval;

# end of ServeOneUp.pl ...


