File Coverage

blib/lib/Mojo/TFTPd.pm

Criterion	Covered	Total	%
statement	92	126	73.0
branch	36	56	64.2
condition	24	30	80.0
subroutine	17	21	80.9
pod	1	2	50.0
total	170	235	72.3

package Mojo::TFTPd;

=head1 NAME

Mojo::TFTPd - Trivial File Transfer Protocol daemon

=head1 VERSION

0.03

=head1 SYNOPSIS

    use Mojo::TFTPd;
    my $tftpd = Mojo::TFTPd->new;

    $tftpd->on(error => sub {
        warn "TFTPd: $_[1]\n";
    });

    $tftpd->on(rrq => sub {
        my($tftpd, $c) = @_;
        open my $FH, '<', $c->file;
        $c->filehandle($FH);
        $c->filesize(-s $c->file);
    });

    $tftpd->on(wrq => sub {
        my($tftpd, $c) = @_;
        open my $FH, '>', '/dev/null';
        $c->filehandle($FH);
    });

    $tftpd->on(finish => sub {
        my($tftpd, $c, $error) = @_;
        warn "Connection: $error\n" if $error;
    });

    $tftpd->start;
    $tftpd->ioloop->start unless $tftpd->ioloop->is_running;

=head1 DESCRIPTION

This module implements a server for the
L.

From Wikipedia:

    Trivial File Transfer Protocol (TFTP) is a file transfer protocol notable
    for its simplicity. It is generally used for automated transfer of
    configuration or boot files between machines in a local environment.

The connection ($c) which is referred to in this document is an instance of
L.

=cut

use Mojo::Base 'Mojo::EventEmitter';
use Mojo::IOLoop;
use Mojo::TFTPd::Connection;
use constant OPCODE_RRQ => 1;
use constant OPCODE_WRQ => 2;
use constant OPCODE_DATA => 3;
use constant OPCODE_ACK => 4;
use constant OPCODE_ERROR => 5;
use constant OPCODE_OACK => 6;
use constant CHECK_INACTIVE_INTERVAL => $ENV{MOJO_TFTPD_CHECK_INACTIVE_INTERVAL} || 3;
use constant MIN_BLOCK_SIZE => 8;
use constant MAX_BLOCK_SIZE => 65464; # From RFC 2348
use constant DEBUG => $ENV{MOJO_TFTPD_DEBUG} ? 1 : 0;

our $VERSION = '0.03';

=head1 EVENTS

=head2 error

    $self->on(error => sub {
        my($self, $str) = @_;
    });

This event is emitted when something goes wrong: Fail to L to socket,
read from socket or other internal errors.

=head2 finish

    $self->on(finish => sub {
        my($self, $c, $error) = @_;
    });

This event is emitted when the client finish, either successfully or due to an
error. C<$error> will be an empty string on success.

=head2 rrq

    $self->on(rrq => sub {
        my($self, $c) = @_;
    });

This event is emitted when a new read request arrives from a client. The
callback should set L or the connection
will be dropped.

=head2 wrq

    $self->on(wrq => sub {
        my($self, $c) = @_;
    });

This event is emitted when a new write request arrives from a client. The
callback should set L or the connection
will be dropped.

=head1 ATTRIBUTES

=head2 ioloop

Holds an instance of L.

=cut

has ioloop => sub { Mojo::IOLoop->singleton };

=head2 listen

    $str = $self->server;
    $self->server("127.0.0.1:69");
    $self->server("tftp://*:69"); # any interface

The bind address for this server.

=cut

has listen => 'tftp://*:69';

=head2 max_connections

How many concurrent connections this server can handle. Default to 1000.

=cut

has max_connections => 1000;

=head2 retries

How many times the server should try to send ACK or DATA to the client before
dropping the L.

=cut

has retries => 1;

=head2 inactive_timeout

How long a L can stay idle before
being dropped.

=cut

has inactive_timeout => 15;

=head1 METHODS

=head2 start

Starts listening to the address and port set in L. The L
event will be emitted if the server fail to start.

=cut

sub start {
    my $self = shift;
    my $reactor = $self->ioloop->reactor;
    my $socket;

    $self->{connections} and return $self;
    $self->{connections} = {};

    # split $self->listen into host and port
    my ($host, $port) = $self->_parse_listen;

    warn "[Mojo::TFTPd] Listen to $host:$port\n" if DEBUG;

    $socket = IO::Socket::INET->new(
                  LocalAddr => $host,
                  LocalPort => $port,
                  Proto => 'udp',
              );

    if(!$socket) {
        delete $self->{connections};
        return $self->emit(error => "Can't create listen socket: $!");
    };

    Scalar::Util::weaken($self);

    $socket->blocking(0);
    $reactor->io($socket, sub { $self->_incoming });
    $reactor->watch($socket, 1, 0); # watch read events
    $self->{socket} = $socket;
    $self->{checker}
        = $self->ioloop->recurring(CHECK_INACTIVE_INTERVAL || 3, sub {
            my $time = time;
            for my $c (values %{ $self->{connections} }) {
                next if $time - $c->timeout < $c->{timestamp};
                $c->error('Inactive timeout');
                $self->_delete_connection($c);
            }
        });

    return $self;
}

sub _incoming {
    my $self = shift;
    my $socket = $self->{socket};
    my $read = $socket->recv(my $datagram, MAX_BLOCK_SIZE + 4); # Add 4 Bytes of Opcode + Block#
    my($opcode, $connection);

    if(!defined $read) {
        return $self->emit(error => "Read: $!");
    }

    $opcode = unpack 'n', substr $datagram, 0, 2, '';

    # new connection
    if($opcode eq OPCODE_RRQ) {
        return $self->_new_request(rrq => $datagram);
    }
    elsif($opcode eq OPCODE_WRQ) {
        return $self->_new_request(wrq => $datagram);
    }

    # existing connection
    $connection = $self->{connections}{$socket->peername};

    if(!$connection) {
        return $self->emit(error => "@{[$socket->peerhost]} has no connection");
    }
    elsif($opcode == OPCODE_ACK) {
        return if $connection->receive_ack($datagram) and $connection->send_data;
    }
    elsif($opcode == OPCODE_DATA) {
        return if $connection->receive_data($datagram) and $connection->send_ack;
    }
    elsif($opcode == OPCODE_ERROR) {
        my($code, $msg) = unpack 'nZ*', $datagram;
        $connection->error("($code) $msg");
    }
    else {
        $connection->error("Unknown opcode");
    }

    # if something goes wrong or finish with connection
    $self->_delete_connection($connection);
}

sub _new_request {
    my($self, $type, $datagram) = @_;
    my($file, $mode, @rfc) = split "\0", $datagram;
    my $socket = $self->{socket};
    my $connection;

    warn "[Mojo::TFTPd] <<< @{[$socket->peerhost]} $type $file $mode @rfc\n" if DEBUG;

    if(!$self->has_subscribers($type)) {
        $self->emit(error => "Cannot handle $type requests");
        return;
    }
    if($self->max_connections <= keys %{ $self->{connections} }) {
        $self->emit(error => "Max connections ($self->{max_connections}) reached");
        return;
    }

    my %rfc = @rfc;
    $connection = Mojo::TFTPd::Connection->new(
                        type => $type,
                        file => $file,
                        mode => $mode,
                        peerhost => $socket->peerhost,
                        peername => $socket->peername,
                        retries => $self->retries,
                        timeout => $self->inactive_timeout,
                        rfc => \%rfc,
                        socket => $socket,
                    );

    if ($rfc{blksize}) {
        $rfc{blksize} = MIN_BLOCK_SIZE if $rfc{blksize} < MIN_BLOCK_SIZE;
        $rfc{blksize} = MAX_BLOCK_SIZE if $rfc{blksize} > MAX_BLOCK_SIZE;
        $connection->blocksize($rfc{blksize});
    }
    if ($rfc{timeout} and $rfc{timeout} >= 0 and $rfc{timeout} <= 255) {
        $connection->timeout($rfc{timeout});
    }
    if ($type eq 'wrq' and $rfc{tsize}) {
        $connection->filesize($rfc{tsize});
    }

    $self->emit($type => $connection);

    if (!$connection->filehandle) {
        $connection->send_error(file_not_found => $connection->error // 'No filehandle');
        $self->{connections}{$connection->peername} = $connection;
    }
    elsif ((%rfc and $connection->send_oack)
        or $type eq 'rrq' ? $connection->send_data : $connection->send_ack) {
        $self->{connections}{$connection->peername} = $connection;
    }
    else {
        $self->emit(finish => $connection, $connection->error);
    }
}

sub _parse_listen {
    my $self = shift;

    my ($scheme, $host, $port) = $self->listen =~ m!
      (?: ([^:/]+) :// )?   # part before ://
      ([^:]*)               # everyting until a :
      (?: : (\d+) )?        # any digits after the :
    !xms;

    # if scheme is set but no port, use scheme
    $port = getservbyname($scheme, '') if $scheme && !defined $port;

    # use port 69 as fallback
    $port //= 69;

    # if host == '*', replace it with '0.0.0.0'
    $host = '0.0.0.0' if $host eq '*';

    return ($host, $port);
}

sub _delete_connection {
    my($self, $connection) = @_;
    delete $self->{connections}{$connection->peername};
    $self->emit(finish => $connection, $connection->error);
}

sub DEMOLISH {
    my $self = shift;
    my $reactor = eval { $self->ioloop->reactor } or return; # may be undef during global destruction

    $reactor->remove($self->{checker}) if $self->{checker};
    $reactor->remove($self->{socket}) if $self->{socket};
}

=head1 AUTHOR

Svetoslav Naydenov

Jan Henning Thorsen - C

=cut

1;