# -*- perl -*-
#
# INetSim::TFTP - A fake TFTP server
#
# RFC 1350 - Trivial File Transfer Protocol
#
# (c)2007-2019 Matthias Eckert, Thomas Hungenberg
#
#############################################################

package INetSim::TFTP;

use strict;
use warnings;
use POSIX;
use IO::Socket;
use IO::Select;
use Digest::SHA;
use Fcntl ':flock';


# RFC 2347
my %OPT_AVAIL = ( blksize   => 2, # RFC 2348
                  timeout   => 2, # RFC 2349
                  tsize     => 1, # RFC 2349
                  multicast => 0  # RFC 2090
);
# status: 3 of 4


my %ERR = ( 0 => "Not defined, see error message",
            1 => "File not found",
            2 => "Access violation",
            3 => "Disk full or allocation exceeded",
            4 => "Illegal TFTP operation",
            5 => "Unknown transfer ID",
            6 => "File already exists",
            7 => "No such user",
            8 => "Terminate transfer due to option negotiation"
);

my %TFTP_OPT;

my %VFS;

my %CONN;


sub configure_hook {
    my $self = shift;
    my ($dev, $inode, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks, $grpname);

    $self->{server}->{host} = INetSim::Config::getConfigParameter("Default_BindAddress");
    $self->{server}->{port} = INetSim::Config::getConfigParameter("TFTP_BindPort");
    $self->{server}->{proto} = 'udp';
    $self->{server}->{type} = SOCK_DGRAM;
    $self->{server}->{user} = INetSim::Config::getConfigParameter("Default_RunAsUser");
    $self->{server}->{user} =~ /\A(.*)\z/; # evil untaint!
    $self->{server}->{user} = $1;
    $self->{server}->{group} = INetSim::Config::getConfigParameter("Default_RunAsGroup");
    $self->{server}->{group} =~ /\A(.*)\z/; # evil untaint!
    $self->{server}->{group} = $1;

    $self->{servicename} = INetSim::Config::getConfigParameter("TFTP_ServiceName");
    $self->{maxchilds} = INetSim::Config::getConfigParameter("Default_MaxChilds");
    $self->{timeout} = INetSim::Config::getConfigParameter("Default_TimeOut");

    $self->{document_root} = INetSim::Config::getConfigParameter("TFTP_DocumentRoot");
    $self->{upload_dir} = INetSim::Config::getConfigParameter("TFTP_UploadDir");
    $self->{allow_overwrite} = INetSim::Config::getConfigParameter("TFTP_AllowOverwrite");
    $self->{options} = INetSim::Config::getConfigParameter("TFTP_EnableOptions");
    $self->{max_filesize} = INetSim::Config::getConfigParameter("TFTP_MaxFileSize");
    $self->{sessionfile} = "$self->{upload_dir}/tftp.session";

    $self->{sessionfile} =~ /\A(.*)\z/; # evil untaint!
    $self->{sessionfile} = $1;

    # check DocumentRoot directory
    if (! -d $self->{document_root}) {
        INetSim::Log::MainLog("failed! DocumentRoot directory '$self->{document_root}' does not exist", $self->{servicename});
        exit 1;
    }

    # check Upload directory
    $self->{upload_dir} =~ /\A(.*)\z/; # evil untaint!
    $self->{upload_dir} = $1;
    if (! -d $self->{upload_dir}) {
        INetSim::Log::MainLog("failed! Upload directory '$self->{upload_dir}' does not exist", $self->{servicename});
        exit 1;
    }

    $gid = getgrnam($self->{server}->{group});
    if (! defined $gid) {
        INetSim::Log::MainLog("Warning: Unable to get GID for group '$self->{server}->{group}'", $self->{servicename});
    }
    chown -1, $gid, $self->{upload_dir};
    ($dev, $inode, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat $self->{upload_dir};

    # check group owner
    $grpname = getgrgid $gid;
    if ($grpname ne $self->{server}->{group}) {
        INetSim::Log::MainLog("Warning: Group owner of Upload directory '$self->{upload_dir}' is not '$self->{server}->{group}' but '$grpname'", $self->{servicename});
    }
    # check for group r/w permissions
    if ((($mode & 0060) >> 3) != 6) {
        INetSim::Log::MainLog("Warning: No group r/w permissions on Upload directory '$self->{upload_dir}'", $self->{servicename});
    }

    # register options from config file
    $self->register_options();

    # initialize the virtual filesystem
    $self->init_VFS;

    # initialize random number generator
    srand(time() ^($$ + ($$ <<15)));
}


sub pre_loop_hook {
    my $self = shift;

    $0 = 'inetsim_' . $self->{servicename};
    INetSim::Log::MainLog("started (PID $$)", $self->{servicename});
}



sub pre_server_close_hook {
    my $self = shift;

    $self->_save_vfs_changes();
    INetSim::Log::MainLog("stopped (PID $$)", $self->{servicename});
}


sub fatal_hook {
    my ($self, $msg) = @_;

    if (defined $msg) {
        $msg =~ s/[\r\n]*//;
        INetSim::Log::MainLog("failed! $msg", $self->{servicename});
    }
    else {
        INetSim::Log::MainLog("failed!", $self->{servicename});
    }
    exit 1;
}


sub process_request {
    my $self = shift;
    my $client = $self->{server}->{client};
    my $rhost = $client->peerhost;
    my $rport = $client->peerport;
    my $packet = $self->{server}->{data};
    my $bytes = length($packet);

    # check minimum packet size -> 4 bytes
    ($bytes >= 4) or return;
    # check maximum packet size -> 516 bytes (or 65468 bytes with blocksize option)
    ($bytes <= 516 || ($self->{options} && $bytes <= 65468)) or return;
    # get the opcode
    my ($opcode, $data) = unpack ("n a*", $packet);
    # check opcode
    ($opcode && $opcode < 7) or return;
    # process packet
    if ($opcode == 1) {
        $self->RRQ($data);
    }
    elsif ($opcode == 2) {
        $self->WRQ($data);
    }
    elsif ($opcode == 3) {
        $self->DATA($data);
    }
    elsif ($opcode == 4) {
        $self->ACK($data);
    }
    elsif ($opcode == 5) {
        $self->ERROR($data);
    }
    elsif ($opcode == 6) {
        # OACK
        # don't waste time with option acknowledge packets
    }
}


sub check_timeout {
    my $self = shift;
    my $client;
    my $now = time();

    foreach $client (keys %CONN) {
        my ($rhost, $rport, $request, $file, $timeout, $lastrecv, $lastsend, $retries) = ($CONN{$client}->{rhost}, $CONN{$client}->{rport}, $CONN{$client}->{request}, $CONN{$client}->{file}, $CONN{$client}->{timeout}, $CONN{$client}->{last_send}, $CONN{$client}->{last_recv}, $CONN{$client}->{retries});
        my $diffrecv = $now - $lastrecv;
        my $diffsend = $now - $lastsend;
        (defined $timeout && $timeout) or $timeout = 5;
        ($diffrecv > $timeout && $diffsend > $timeout) or next;
        if (! $retries) {
            $self->send_(pack ("n n a*", 5, 0, "Timeout\x00"));
            INetSim::Log::SubLog("[$rhost:$rport] send: ERROR : " . $ERR{0} . " : 'Timeout'", $self->{servicename}, $$);
            INetSim::Log::SubLog("[$rhost:$rport] disconnect (timeout)", $self->{servicename}, $$);
            INetSim::Log::SubLog("[$rhost:$rport] stat: 0", $self->{servicename}, $$);
            if ($request eq "WRQ") {
                # delete incomplete files from virtual filesystem
                $self->_vfs_del_file($file);
            }
            delete $CONN{$client};
        }
        else {
            $CONN{$client}->{is_retry} = 1;
            $CONN{$client}->{last_block} = $CONN{$client}->{block};
            if ($request eq "RRQ") {
                $self->send_DATA($client);
            }
            elsif ($request eq "WRQ") {
                $self->send_ACK($client);
            }
        }
    }
}


sub RRQ {
    my ($self, $data) = @_;
    my $client = $self->{server}->{client};

    # already connected ?
    (! defined $CONN{$client}) or return;
    # check for invalid packet
    (defined $data && $data) or return;
    # get mode and file name
    my ($file, $mode, $options) = split(/\x00/, $data, 3);
    # check mode argument
    (defined $mode && $mode && $mode =~ /\A(netascii|octet|mail)\z/i) or return;
    $mode = lc($mode);
    # register client
    my $rhost = $client->peerhost;
    my $rport = $client->peerport;
    $CONN{$client} = {  rhost                => $rhost,
                        rport                => $rport,
                        request                => "RRQ",
                        file                => undef,
                        mode                => undef,
                        options                => 0,
                        blksize                => undef,
                        timeout                => undef,
                        tsize                => undef,
                        expected        => undef,
                        block                => 0,
                        bytes                => 0,
                        last_send        => 0,
                        last_recv        => time(),
                        last_block        => 0,
                        is_retry        => 0,
                        retries                => 2,
                        realfile        => undef
                    };
    # i know, it's udp - but the first packet is like a connect :-)
    $self->slog_("connect");
    # check options if any
    my $opt = $self->check_options($options);
    # only for logging: replace non-printable characters in the file name with "."
    my $filtered = $file;
    $filtered =~ s/([^\x20-\x7e])/\./g;
    # log request
    if ($opt) {
        $self->slog_("recv: RRQ $filtered $mode (options: $opt)");
    }
    else {
        $self->slog_("recv: RRQ $filtered $mode (options: none)");
    }
    # option not accepted
    if (! defined $opt) {
        $self->send_ERROR(8, "Option or value not accepted");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    # mode "mail" is not yet implemented -> error
    if ($mode eq "mail") {
        $self->send_ERROR(0, "Mode 'mail' not implemented");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    $CONN{$client}->{mode} = $mode;
    # check file argument
    if (! defined $file || ! $file || $file !~ /\A([\x20-\x7E]+)\z/) {
        $self->send_ERROR(2, "Invalid file name");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    # check if file exists
    my $vfile = $self->_vfs_file_exists($file);
    if (! defined $vfile || ! $vfile) {
        $self->send_ERROR(1, "No such file");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    my ($flag, $type, $rpath) = split (/\|/, $VFS{"$vfile"});
    if (! defined $type || $type ne "f" || ! defined $rpath || ! -f $rpath || ! -r $rpath) {
        $self->send_ERROR(1, "File not found");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    $CONN{$client}->{file} = $file;
    $CONN{$client}->{realfile} = $rpath;
    if ($CONN{$client}->{options}) {
        # -> OACK -> ACK -> DATA
        $self->send_OACK();
    }
    else {
        # -> DATA
        $self->send_DATA();
    }
}


sub WRQ {
    my ($self, $data) = @_;
    my $client = $self->{server}->{client};

    # already connected ?
    (! defined $CONN{$client}) or return;
    # check for invalid packet
    (defined $data && $data) or return;
    # get mode and file name
    my ($file, $mode, $options) = split(/\x00/, $data, 3);
    # check mode argument
    (defined $mode && $mode && $mode =~ /\A(netascii|octet|mail)\z/i) or return;
    $mode = lc($mode);
    # register client
    my $rhost = $client->peerhost;
    my $rport = $client->peerport;
    $CONN{$client} = {  rhost                => $rhost,
                        rport                => $rport,
                        request                => "WRQ",
                        file                => undef,
                        mode                => undef,
                        options                => 0,
                        blksize                => undef,
                        timeout                => undef,
                        tsize                => undef,
                        expected        => undef,
                        block                => 0,
                        bytes                => 0,
                        last_send        => 0,
                        last_recv        => time(),
                        last_block        => 0,
                        is_retry        => 0,
                        retries                => 2,
                        realfile        => undef
                    };
    # i know, it's udp - but the first packet is like a connect :-)
    $self->slog_("connect");
    # check options if any
    my $opt = $self->check_options($options);
    # only for logging: replace non-printable characters in the file name with "."
    my $filtered = $file;
    $filtered =~ s/([^\x20-\x7e])/\./g;
    # log request
    if ($opt) {
        $self->slog_("recv: WRQ $filtered $mode (options: $opt)");
    }
    else {
        $self->slog_("recv: WRQ $filtered $mode (options: none)");
    }
    # option not accepted
    if (! defined $opt) {
        $self->send_ERROR(8, "Option or value not accepted");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    # mode "mail" is not yet implemented -> error
    if ($mode eq "mail") {
        $self->send_ERROR(0, "Mode 'mail' not implemented");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    $CONN{$client}->{mode} = $mode;
    # check file argument
    if (! defined $file || ! $file || $file !~ /\A([\x20-\x7E]+)\z/) {
        $self->send_ERROR(2, "Invalid file name");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    # check if file already exists
    if (! $self->{allow_overwrite}) {
        my $vfile = $self->_vfs_file_exists($file);
        if (defined $vfile && $vfile) {
            $self->send_ERROR(6, "File already exists");
            $self->slog_("disconnect");
            $self->slog_("stat: 0");
            delete $CONN{$client};
            return;
        }
    }
    $CONN{$client}->{file} = $file;

    if ($CONN{$client}->{options}) {
        # -> OACK
        $self->send_OACK();
    }
    else {
        # -> ACK
        $self->send_ACK();
    }
}


sub send_OACK {
    my $self = shift;
    my $client = $self->{server}->{client};
    my $opt;
    my $log;

    (defined $CONN{$client}) or return;
    (defined $CONN{$client}->{options} && $CONN{$client}->{options}) or return;
    $CONN{$client}->{last_send} = time();
    if ($CONN{$client}->{request} eq "RRQ") {
        $CONN{$client}->{expected} = "ACK";
        if (defined $CONN{$client}->{tsize} && -f $CONN{$client}->{realfile}) {
            $CONN{$client}->{tsize} = -s $CONN{$client}->{realfile};
        }
    }
    elsif ($CONN{$client}->{request} eq "WRQ") {
        $CONN{$client}->{expected} = "DATA";
    }
    foreach (qw/blksize timeout tsize/) {
        (defined $CONN{$client}->{$_} && $CONN{$client}->{$_}) or next;
        $opt .= "$_\x00$CONN{$client}->{$_}\x00";
        $log .= "$_ $CONN{$client}->{$_} ";
    }
    $log =~ s/\s+\z//;
    $self->slog_("send: OACK $log");
    $self->send_(pack ("n a*", 6, $opt));
}


sub DATA {
    my ($self, $raw) = @_;
    my $client = $self->{server}->{client};
    my $blocksize;

    # connected ?
    (defined $client && defined $CONN{$client}) or return;
    # check for invalid packet
    (defined $raw && $raw) or return;
    # was the initial packet a WRQ and therefore we expect a data packet ?
    ($CONN{$client}->{request} eq "WRQ" && $CONN{$client}->{expected} eq "DATA") or return;
    # get block number and data
    my ($block, $data) = unpack ("n a*", $raw);
    # block number should not be zero
    if (! $block) {
        $self->send_ERROR(4, "Invalid block number");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    $CONN{$client}->{last_recv} = time();
    # get length
    my $length = length($data);
    # check for valid block number
    ($block == int($CONN{$client}->{block} + 1)) or return;
    # set block size
    if (defined $CONN{$client}->{blksize} && $CONN{$client}->{blksize}) {
        $blocksize = $CONN{$client}->{blksize};
        # check for stupid clients (atftp) and correct the blocksize
        if ($block == 1 && $length > $CONN{$client}->{blksize}) {
            $CONN{$client}->{blksize} = $length;
            $self->slog_("w00t: The client lies about his block size, adjusted to $length :-/");
        }
    }
    else {
        $blocksize = 512;
    }
    if ($block == 1) {
        $CONN{$client}->{buffer} = $data;
    }
    else {
        $CONN{$client}->{buffer} .= $data;
    }
    $CONN{$client}->{block} = $block;
    $CONN{$client}->{bytes} += $length;
    # check maximum file size
    if ($CONN{$client}->{bytes} > $self->{max_filesize}) {
        $self->send_ERROR(3, "Maximum file size of $self->{max_filesize} bytes exceeded");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    $self->send_ACK();

    # save data and add file to virtual file system
    #
    # Note: The data field is from zero to blocksize bytes long. If it is blocksize bytes long, 
    # the block is not the last block of data; if it is from zero to blocksize-1 bytes long, it 
    # signals the end of the transfer.
    # Therefore, this is the last packet.
    if ($length < $blocksize) {
        # write data received to file
        my $filehash = Digest::SHA->new(256);
        $filehash->add($CONN{$client}->{buffer});
        my $storFileName = $self->{upload_dir} . "/" . $filehash->hexdigest;
        my $STORFILE;
        $CONN{$client}->{realfile} = $storFileName;
        if (-e $storFileName) {
            $self->slog_("info: Upload file $storFileName already exists");
        }
        elsif (! open ($STORFILE, "> $storFileName")) {
            INetSim::Log::MainLog("Error: Unable to create TFTP upload data file '$storFileName'", $self->{servicename});
            $self->send_ERROR(0, "Unable to write");
            $self->slog_("disconnect");
            $self->slog_("stat: 0");
            delete $CONN{$client};
            return;
        }
        else {
            binmode ($STORFILE);
            chmod 0660, $storFileName;
            print $STORFILE $CONN{$client}->{buffer};
            close $STORFILE;
        }
        my $result = $self->_vfs_add_file($CONN{$client}->{file}, $CONN{$client}->{realfile});
        $self->slog_("recv: DATA (blocks: $block, block size: $blocksize bytes, file size: $CONN{$client}->{bytes} bytes)");
        $self->slog_("info: Stored $CONN{$client}->{bytes} bytes of data to: $storFileName, original file name: $CONN{$client}->{file}");
        $self->slog_("disconnect");
        $self->slog_("stat: 1 request=write mode=$CONN{$client}->{mode} name=$CONN{$client}->{file}");
        delete $CONN{$client};
    }
}


sub ACK {
    my ($self, $data) = @_;
    my $client = $self->{server}->{client};

    (defined $CONN{$client}) or return;
    (defined $data && $data) or return;
    my $block = unpack ("n", $data);
    (defined $block) or return;
    ($CONN{$client}->{request} eq "RRQ" && $CONN{$client}->{block} == $block) or return;
    if ($CONN{$client}->{expected} eq "ACK") {
        if ($block == 0) {
            $self->slog_("recv: ACK block $block");
        }
        $self->send_DATA();
    }
    elsif ($CONN{$client}->{expected} eq "LASTACK") {
        $self->slog_("recv: ACK block $block");
        $self->slog_("disconnect");
        $self->slog_("stat: 1 request=read mode=$CONN{$client}->{mode} name=$CONN{$client}->{file}");
        delete $CONN{$client};
    }
}


sub ERROR {
    my ($self, $data) = @_;
    my $client = $self->{server}->{client};

    (defined $CONN{$client}) or return;
    (defined $data && $data) or return;
    my ($code, $message) = unpack ("n a*", $data);
    (defined $code && defined $message && $message) or return;
    ($code >= 0 && $code <= 8) or return;
    $message =~ s/\x00\z//;
    $message =~ s/([^\x20-\x7e])/\./g;
    $self->slog_("recv: ERROR : $ERR{$code} : '$message'");
    $self->slog_("disconnect");
    $self->slog_("stat: 0");
    if ($CONN{$client}->{request} eq "WRQ") {
        # delete incomplete file from virtual filesystem
        $self->_vfs_del_file($CONN{$client}->{file});
    }
    delete $CONN{$client};
}


sub send_DATA {
    my ($self, $client) = @_;
    (defined $client && $client) or $client = $self->{server}->{client};
    my $blocksize;

    (defined $CONN{$client}) or return;
    my $rpath = $CONN{$client}->{realfile};
    my $block;
    if ($CONN{$client}->{is_retry}) {
        $block = $CONN{$client}->{last_block};
        $CONN{$client}->{is_retry} = 0;
        $CONN{$client}->{retries}--;
    }
    else {
        $block = $CONN{$client}->{block} + 1;
        $CONN{$client}->{last_block} = $block;
    }
    # set block size
    if (defined $CONN{$client}->{blksize} && $CONN{$client}->{blksize}) {
        $blocksize = $CONN{$client}->{blksize};
    }
    else {
        $blocksize = 512;
    }
    my $size = -s $rpath;
    my $offset = ($blocksize * ($block - 1));
    my $DAT;
    if (! open($DAT, "$rpath")) {
        # should not happen
        $self->send_ERROR(0, "Internal server error");
        $self->slog_("disconnect");
        $self->slog_("stat: 0");
        delete $CONN{$client};
        return;
    }
    binmode $DAT;
    seek($DAT, $offset , 0);
    read($DAT, my $data, $blocksize);
    close $DAT;
    my $length = length($data);
    if ($block == 1) {
        $self->slog_("info: Sending file: $rpath");
    }
    if ($length == $blocksize) {
        $CONN{$client}->{expected} = "ACK";
    }
    else {
        $CONN{$client}->{expected} = "LASTACK";
        $self->slog_("send: DATA (blocks: $block, block size: $blocksize bytes, file size: $size bytes)");
    }
    $CONN{$client}->{block} = $block;
    $CONN{$client}->{last_send} = time();
    $self->send_(pack ("n n a*", 3, $block, $data));
}


sub send_ACK {
    my ($self, $client) = @_;
    (defined $client && $client) or $client = $self->{server}->{client};

    (defined $CONN{$client}) or return;
    my $block;
    if ($CONN{$client}->{is_retry}) {
        $block = $CONN{$client}->{last_block};
        $CONN{$client}->{is_retry} = 0;
        $CONN{$client}->{retries}--;
    }
    else {
        $block = $CONN{$client}->{block};
        $CONN{$client}->{last_block} = $block;
    }
    $CONN{$client}->{last_send} = time();
    if ($block == 0) {
        $CONN{$client}->{expected} = "DATA";
        $self->slog_("send: ACK block 0");
    }
    $self->send_(pack ("n n", 4, $block));
}


sub send_ERROR {
    my ($self, $code, $msg, $client) = @_;
    (defined $client && $client) or $client = $self->{server}->{client};

    (defined $client) or return;
    (defined $code) or $code = 0;
    (defined $msg) or $msg = "unknown error";
    $self->slog_("send: ERROR : " . $ERR{$code} . " : '$msg'", $client);
    $self->send_(pack ("n n a*", 5, $code, $msg . "\x00"));
}


sub check_options {
    my ($self, $options) = @_;
    my $client = $self->{server}->{client};
    my ($option, $value);
    my ($min, $max);
    my $given = "";

    (defined $options && $options) or return 0;
    my @opt = split(/\x00/, $options);
    while (1) {
        last if (@opt <= 1);
        $option = shift(@opt);
        $value = shift(@opt);
        (defined $option && $option && $option =~ /\A(blksize|timeout|tsize|multicast)\z/i) or next;
        (defined $value && ((length($value) && $value =~ /\A\d+\z/) || $option eq "multicast")) or next;
        $option = lc($option);
        $given .= "$option=$value ";
        ($self->{options}) or next;
        if ($option eq "blksize" && defined $TFTP_OPT{blksize}) {
            ($value >= 8 && $value <= 65464) or next;
            ($min, $max) = split(/\s+/, $TFTP_OPT{blksize});
            # if block size defined, but smaller than client value -> set server value
            if ($value > $max) {
                $CONN{$client}->{blksize} = $TFTP_OPT{blksize};
            }
            # do not accept values less than minimum value
            elsif ($value < $min) {
                $CONN{$client}->{blksize} = undef;
            }
            # ...else set the client value
            else {
                $CONN{$client}->{blksize} = $value;
            }
        }
        elsif ($option eq "timeout" && defined $TFTP_OPT{timeout}) {
            ($value >= 1 && $value <= 255) or next;
            ($min, $max) = split(/\s+/, $TFTP_OPT{timeout});
            # do not accept values outside our range
            if ($value > $max || $value < $min) {
                $CONN{$client}->{timeout} = undef;
            }
            # ok, set client value
            else {
                $CONN{$client}->{timeout} = $value;
            }
        }
        elsif ($option eq "tsize" && defined $TFTP_OPT{tsize}) {
            if ($CONN{$client}->{request} eq "RRQ" && $value == 0) {
                $CONN{$client}->{tsize} = 0;
            }
            elsif ($CONN{$client}->{request} eq "WRQ") {
                # requested transfer size to big
                if ($value > $TFTP_OPT{tsize}) {
                    return undef;
                }
                else {
                    $CONN{$client}->{tsize} = $value;
                }
            }
        }
    }
    (! defined $CONN{$client}->{blksize} && ! defined $CONN{$client}->{timeout} && ! defined $CONN{$client}->{tsize}) or $CONN{$client}->{options} = 1;
    $given =~ s/\s+\z//;
    return $given;
}


sub send_ {
    my ($self, $msg) = @_;
    my $sock = $self->{server}->{socket};

    (defined $msg) or return;
    $sock->send($msg);
}


sub slog_ {
    my ($self, $msg, $sock) = @_;
    (defined $sock && $sock) or $sock = $self->{server}->{client};
    my $rhost = $sock->peerhost;
    my $rport = $sock->peerport;

    (defined $msg) or return;
    $msg =~ s/[\r\n]*//;
    INetSim::Log::SubLog("[$rhost:$rport] $msg", $self->{servicename}, $$);
}


sub dlog_ {
    my ($self, $msg, $sock) = @_;
    (defined $sock && $sock) or $sock = $self->{server}->{client};
    my $rhost = $sock->peerhost;
    my $rport = $sock->peerport;

    (defined $msg) or return;
    $msg =~ s/[\r\n]*//;
    INetSim::Log::DebugLog("[$rhost:$rport] $msg", $self->{servicename}, $$);
}


### BEGIN: VFS stuff

# key = file, value = flag|dirORfile|realpath

sub init_VFS {
    my $self = shift;
    my @dirs;
    my $name;
    my $vname;
    my $mtime;
    my $dir;

    # read the session file, if exist
    $self->_read_vfs_changes;

#    # rebuild only if empty
#    return if (keys (%VFS) >= 1);

    # first, add '/' to the filesystem
    $mtime = int (INetSim::FakeTime::get_faketime() - rand(7200));
    $VFS{'/'} = "1|d|";
    $self->{current_dir} = "/";
    # now walk through the document root and add directories and files
    push (@dirs, $self->{document_root});        # push document root to the "stack"
    while (@dirs) {
        $dir = pop (@dirs);
        if (opendir (my $DIRHANDLE, $dir)) {
            while (defined ($name = readdir ($DIRHANDLE))) {
                next if $name eq '.';
                next if $name eq '..';
                $vname = "$dir/$name";
                $vname =~ s/\A$self->{document_root}//;        # chr00t ;-)
                $mtime = int (INetSim::FakeTime::get_faketime() - rand(3600));
                if (-d "$dir/$name") {
                    push (@dirs, "$dir/$name");
                    $self->_vfs_add_dir($vname, "$dir/$name");
                }
                elsif (-f "$dir/$name") {
                    $self->_vfs_add_file($vname, "$dir/$name");
                }
            }
            closedir $DIRHANDLE;
        }
    }
}


sub _vfs_add_file {
    my $self = shift;
    my $vpath = shift;  # virtual path
    my $rpath = shift;  # real path
    my $dir;

    if (defined ($vpath) && defined ($rpath)) {
        if (-f $rpath && -r $rpath) {
            # add base directory of the file
            $self->_vfs_add_dir($self->_dirname($vpath));
            # check for absolute path
            if ($vpath !~ /\A\//) {
                # build absolute virtual path name
                $vpath = "$self->{current_dir}/$vpath";
            }
            # filter virtual path name
            $vpath = $self->_filter_pathstring($vpath);
            # add file to vfs (if not empty)
            if (defined ($vpath) && $vpath ne "" && $vpath ne "/") {
                $VFS{"$vpath"} = "1|f|$rpath";
                return ($vpath);
            }
        }
    }
    return undef;
}


sub _vfs_del_file {
    my $self = shift;
    my $vpath = shift;  # virtual path

    if (defined ($vpath)) {
        # check for absolute path
        if ($vpath !~ /\A\//) {
            # build absolute virtual path name
            $vpath = "$self->{current_dir}/$vpath";
        }
        # filter virtual path name
        $vpath = $self->_filter_pathstring($vpath);
        if (defined ($vpath) && $vpath ne "" && defined ($VFS{"$vpath"}) && $VFS{"$vpath"} !~ /\Ad/) {
            delete $VFS{"$vpath"};
            return ($vpath);
        }
    }
    return undef;
}


sub _vfs_file_exists {
    my $self = shift;
    my $vpath = shift;        # virtual path

    if (defined ($vpath)) {
        # check for absolute path
        if ($vpath !~ /\A\//) {
            # build absolute virtual path name
            $vpath = "$self->{current_dir}/$vpath";
        }
        # filter virtual path name
        $vpath = $self->_filter_pathstring($vpath);
        if (defined ($vpath) && $vpath ne "" && defined ($VFS{"$vpath"}) && $VFS{"$vpath"} !~ /\Ad/) {
            return ($vpath);
        }
    }
    return undef;
}


sub _vfs_add_dir {
    my $self = shift;
    my $vpath = shift;        # virtual path

    if (defined ($vpath)) {
        # check for absolute path
        if ($vpath !~ /\A\//) {
            # build absolute virtual path name
            $vpath = "$self->{current_dir}/$vpath";
        }
        # filter virtual path name
        $vpath = $self->_filter_pathstring($vpath);
        # add directory to vfs (if not empty)
        if (defined ($vpath) && $vpath ne "" && $vpath ne "/") {
            $VFS{"$vpath"} = "1|d|";
            return ($vpath);
        }
    }
    return undef;
}


sub _vfs_dir_exists {
    my $self = shift;
    my $vpath = shift;        # virtual path

    if (defined ($vpath)) {
        # check for absolute path
        if ($vpath !~ /\A\//) {
            # build absolute virtual path name
            $vpath = "$self->{current_dir}/$vpath";
        }
        # filter virtual path name
        $vpath = $self->_filter_pathstring($vpath);
        if (defined ($vpath) && $vpath ne "" && defined ($VFS{"$vpath"}) && $VFS{"$vpath"} =~ /\Ad/) {
            return ($vpath);
        }
    }
    return undef;
}


sub _read_vfs_changes {
    my $self = shift;
    my %seen = ();
    my @raw;
    my $key;

    if (open (my $SES, "$self->{sessionfile}")) {
        chomp(@raw = <$SES>);
        close $SES;
        foreach (grep { ! $seen{ $_ }++ } @raw) {
            my ($content, $vpath) = split (/\!/, $_, 2);
            chomp($vpath);
            $VFS{"$vpath"} = $content;
        }
    }
    return;
}


sub _save_vfs_changes {
    my $self = shift;
    my %seen = ();
    my @raw;
    my $key;
    my $SES;

    while () {
        if (open ($SES, "> $self->{sessionfile}")) {
            chmod 0660, $self->{sessionfile};
            if (flock($SES, LOCK_EX)) {
                foreach $key (keys %VFS) {
                    print $SES "$VFS{$key}!$key\n";
                }
                close $SES;
                return 1;
            }
            close $SES;
        }
        sleep 1;
    }
    return;
}


sub _filter_pathstring {
    my $self = shift;
    my $path = shift;
    my @parts;

    if (defined ($path) && $path ne "") {
        @parts = split(/\/+/, $path);
        @parts = ('', '') unless @parts;
        unshift (@parts, '') unless @parts > 1;
        for (my $i = 1; $i < @parts;) {
            if ($parts[$i] eq '.') {
                splice (@parts, $i, 1);
            }
            elsif ($parts[$i] eq '..' && $i == 1) {
                splice (@parts, $i, 1);
            }
            elsif ($parts[$i] eq '..') {
                splice (@parts, ($i - 1), 2);
                $i--;
            }
            else {
                $i++;
            }
        }
        unshift (@parts, '') unless @parts > 1;
        return (join ('/', @parts));
    }
    return undef;
}


sub _basename {
    my $self = shift;
    my $path = shift;
    my @parts;

    if (defined ($path) && $path ne "") {
        if ($path eq '/') {
            return '/';
        } else {
            @parts = split (m{/}, $path);
            return (pop @parts);
        }
    }
    return undef;
}


sub _dirname {
    my $self = shift;
    my $path = shift;

    if (defined ($path) && $path ne "") {
        if ($path eq '/') {
                return '/';
        } else {
                my @parts = split (m{/}, $path);
                pop @parts;
                push (@parts, '') if @parts == 1;
                return (join ('/', @parts));
        }
    }
    return undef;
}


### BEGIN: Server stuff

sub server_close {
    my $self = shift;

    $self->{server}->{socket}->close();
    exit 0;
}


sub new {
  my $class = shift || die "Missing class";
  my $args  = @_ == 1 ? shift : {@_};
  my $self  = bless {server => { %$args }}, $class;
  return $self;
}


sub bind {
    my $self = shift;

    # evil untaint
    $self->{server}->{host} =~ /(.*)/;
    $self->{server}->{host} = $1;

    # bind to socket
    $self->{server}->{socket} = new IO::Socket::INET( LocalAddr => $self->{server}->{host},
                                                      LocalPort => $self->{server}->{port},
                                                      Proto     => $self->{server}->{proto},
                                                      Type      => $self->{server}->{type}
                                                     );
    (defined $self->{server}->{socket}) or $self->fatal_hook("$!");
    # add socket to select
    $self->{server}->{select} = new IO::Select($self->{server}->{socket});
    (defined $self->{server}->{select}) or $self->fatal_hook("$!");

    # drop root privileges
    my $uid = getpwnam($self->{server}->{user});
    my $gid = getgrnam($self->{server}->{group});
    # group
    POSIX::setgid($gid);
    my $newgid = POSIX::getgid();
    if ($newgid != $gid) {
        INetSim::Log::MainLog("failed! (Cannot switch group)", $self->{servicename});
        $self->server_close;
    }
    # user
    POSIX::setuid($uid);
    if ($< != $uid || $> != $uid) {
        $< = $> = $uid; # try again - reportedly needed by some Perl 5.8.0 Linux systems
        if ($< != $uid) {
            INetSim::Log::MainLog("failed! (Cannot switch user)", $self->{servicename});
            $self->server_close;
        }
    }

    # ignore SIG_INT, SIG_PIPE and SIG_QUIT
    $SIG{'INT'} = $SIG{'PIPE'} = $SIG{'QUIT'} = 'IGNORE';
    # only "listen" for SIG_TERM from parent process
    $SIG{'TERM'} = sub { $self->pre_server_close_hook; $self->server_close; };
}


sub run {
    my $self = ref($_[0]) ? shift() : shift->new;

    # configure this service
    $self->configure_hook;
    # open the socket and drop privilegies (set user/group)
    $self->bind;
    # just for compatibility with net::server
    $self->pre_loop_hook;
    # standard loop for: receive->process_request->check_timeout
    $self->loop;
    # just for compatibility with net::server
    $self->pre_server_close_hook;
    # shutdown socket and exit
    $self->server_close;
}


sub loop {
    my $self = shift;
    my $socket = $self->{server}->{socket};
    my $select = $self->{server}->{select};
    my $client;
    my $bytes;
    my $buffer;
    my $rhost;
    my $rport;

    while (1) {
        my @can_read = $select->can_read(0.1);
        $self->{number_of_clients} = int($select->count());
        foreach $client (@can_read) {
            $bytes = $client->recv($buffer, 65468);
            (defined $bytes) or next;
            $self->{server}->{client} = $client;
            $self->{server}->{data} = $buffer;
            $self->process_request();
        }
        my @can_write = $select->can_write(0.1);
        $self->{number_of_clients} = int($select->count());
        foreach $client (@can_write) {
            $self->{server}->{client} = $client;
            $self->check_timeout();
        }
    }
}


sub register_options {
    my $self = shift;
    my %option;

    if ($self->{options}) {
        %option = INetSim::Config::getConfigHash("TFTP_Options");
        foreach my $key (keys %option) {
            if (defined ($OPT_AVAIL{$key}) && $OPT_AVAIL{$key}) {
                if (! defined ($TFTP_OPT{$key})) {
                    $option{$key} =~ s/[\s]+\z//;
                    # parameters are allowed
                    if ($OPT_AVAIL{$key} == 2) {
                        $TFTP_OPT{$key} = $option{$key};
                    }
                    # parameters are not allowed
                    else {
                        $TFTP_OPT{$key} = "";
                    }
                }
            }
        }
        # resolve possible dependencies below...
        #
        # check range for blocksize parameters
        if (defined $TFTP_OPT{blksize}) {
            # nothing defined, set maximum range
            if (! $TFTP_OPT{blksize}) {
                $TFTP_OPT{blksize} = "8 65464";
            }
            else {
                # some values defined, check that
                my ($min, $max) = split(/[\s\t]+/, $TFTP_OPT{blksize}, 2);
                # invalid ? set to minimum value
                if (! defined $min || ! $min || $min !~ /\A\d+\z/ || $min < 8 || $min > 65464) {
                    $min = 8;
                }
                # invalid ? set to maximum
                if (! defined $max || ! $max || $max !~ /\A\d+\z/ || $max < 8 || $max > 65464) {
                    $max = 65464;
                }
                # switch min & max, if min greater max
                if ($min > $max) {
                    $TFTP_OPT{blksize} = "$max $min";
                }
                else {
                    $TFTP_OPT{blksize} = "$min $max";
                }
            }
        }
        # check range for timeout
        if (defined $TFTP_OPT{timeout}) {
            # nothing defined -> maximum range
            if (! $TFTP_OPT{timeout}) {
                $TFTP_OPT{timeout} = "1 255";
            }
            else {
                # some values defined...
                my ($min, $max) = split(/[\s\t]+/, $TFTP_OPT{timeout}, 2);
                # invalid ? set to minimum
                if (! defined $min || ! $min || $min !~ /\A\d+\z/ || $min < 1 || $min > 255) {
                    $min = 1;
                }
                # invalid ? set to maximum
                if (! defined $max || ! $max || $max !~ /\A\d+\z/ || $max < 1 || $max > 255) {
                    $max = 255;
                }
                # switch min & max, if min greater max
                if ($min > $max) {
                    $TFTP_OPT{timeout} = "$max $min";
                }
                else {
                    $TFTP_OPT{timeout} = "$min $max";
                }
            }
        }
        # check maximum transfer size
        if (defined $TFTP_OPT{tsize}) {
            # nothing defined -> maximum tsize = 10MB
            if (! $TFTP_OPT{tsize}) {
                $TFTP_OPT{tsize} = 10485760;
            }
            else {
                # defined value invalid ? then set to default
                if ($TFTP_OPT{tsize} !~ /\A\d+\z/ || $TFTP_OPT{tsize} < 1 || $TFTP_OPT{tsize} > 1073741824) {
                    $TFTP_OPT{tsize} = 10485760;
                }
            }
        }
    }
}


sub error_exit {
    my ($self, $sock, $msg) = @_;
    my $rhost = $sock->peerhost;
    my $rport = $sock->peerport;

    if (! defined $msg) {
        $msg = "Unknown error";
    }
    INetSim::Log::MainLog("$msg. Closing connection.", $self->{servicename});
    INetSim::Log::SubLog("[$rhost:$rport] error: $msg. Closing connection.", $self->{servicename}, $$);
    INetSim::Log::SubLog("[$rhost:$rport] disconnect", $self->{servicename}, $$);
    exit 1;
}


1;
#
