package AnyEvent::TFTPd;

=head1 NAME

AnyEvent::TFTPd - Trivial File Transfer Protocol daemon

=head1 VERSION

0.10

=head1 DESCRIPTION

This module handles TFTP request in an L<AnyEvent> environment.

=head1 SYNOPSIS

 package My::AnyEvent::Connection;
 use Moose;
 extends 'AnyEvent::TFTPd::Connection';

 sub _build_filehandle {
    my $self = shift;
    my $file = $self->file;

    # ...

    return $filehandle;
 }

 1;

 package main;

 my $tftpd = AnyEvent::TFTPd->new(
                 address => 'localhost',
                 port => 69,
                 connection_class => 'My::AnyEvent::Connection',
                 max_connections => 100,
             )->setup or die $@;

=cut

use Moose;
use AnyEvent::Handle::UDP;
use AnyEvent::TFTPd::Connection;
use IO::Socket::INET;

use constant MIN_BLKSIZE => 512;
use constant MAX_BLKSIZE => 1428;
use constant MIN_TIMEOUT => 1;
use constant MAX_TIMEOUT => 60;
use constant DEFAULT_PORT => 69;
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;

our $VERSION = '0.10';
our $DEBUG = 0;

=head1 ATTRIBUTES

=head2 address

Holds the address this server should bind to. Default is "127.0.0.1".

=cut

has address => (
    is => 'ro',
    isa => 'Str',
    default => '127.0.0.1',
);

=head2 port

Holds the default port this server should listen to. Default is 69.

=cut

has port => (
    is => 'ro',
    isa => 'Str',
    default => sub { DEFAULT_PORT },
);

=head2 connection_class

This string holds the classname where the connection objects should
be constructed from. The default L<AnyEvent::TFTPd::Connection> class
is quite useless without subclassing it. See L</SYNOPSIS> for more details.

=cut

has connection_class => (
    is => 'ro',
    isa => 'Str',
    default => 'AnyEvent::TFTPd::Connection',
);

=head2 max_connections

The max concurrent connections this object can handle. Used inside
L</on_connect()> to decide if a new connection should be establised or
not.

Setting this to zero (the default) means that the server should handle
unlimited connections.

=cut

has max_connections => (
    is => 'ro',
    isa => 'Int',
    default => 0,
);

=head2 _connections

 $connection_obj = $self->get_connection(peername);
 $connection_obj = $self->add_connection($connection_obj);
 @connections = $self->get_all_connections;

This attribute holds a hash-ref, where the keys are C<peername()> of the
connections, and the values point to L<AnyEvent::TFTPd::Connection> objects.
Use the delegated methods listed above to access this attribute.

=cut

has _connections => (
    is => 'ro',
    isa => 'HashRef',
    traits => ['Hash'],
    default => sub { {} },
    handles => {
        get_connection => 'get',
        get_all_connections => 'values',
        delete_connection => 'delete',
    },
);

__PACKAGE__->meta->add_method(_clear_connections => sub {
    %{ $_[0]->_connections } = ();
});
__PACKAGE__->meta->add_method(add_connection => sub {
    return $_[0]->_connections->{"$_[1]"} = $_[1];
});

=head2 _handle

 $io_socket_inet = $self->socket;
 $packed = $self->peername;

This attribute holds an instance of L<AnyEvent::Handle::UDP>, which
handles the methods listed above.

=cut

has _handle => (
    is => 'ro',
    isa => 'AnyEvent::Handle::UDP',
    lazy_build => 1,
    handles => [qw/ socket peername /],
);

sub _build__handle {
    my $self = shift;
    
    return AnyEvent::Handle::UDP->new(
        listen => join(':', $self->address, $self->port),
        read_size => MAX_BLKSIZE,
        on_error => sub { $self->on_error(@_) },
        on_read => sub { $self->on_read(@_) },
    );
}

=head1 METHODS

=head2 setup

This method will prepare the handle/socket for incoming connections.
It will return c<$self> on success and 0 on failure. Check C<$@> for
a full error message on failure.

Return value C<$self> allows you to chain C<new()> and C<setup()>.

=cut

sub setup {
    my $self = shift;

    eval {
        $self->_handle;
    } or do {
        return 0;
    };

    return $self;
}

=head2 on_read

This hook is called each time data is received from a peer host.
It will parse the datagram received and act accordingly.

=cut

sub on_read {
    my $self = shift;
    my $handle = shift;
    my $datagram = $handle->rbuf;
    my $opcode = unpack 'n', substr $datagram, 0, 2, '';
    my $connection;

    $handle->{'rbuf'} = ''; # clear buffer

    # ===============
    # Init connection

    if($opcode == OPCODE_RRQ) {
        if($connection = $self->on_connect($opcode, $datagram)) {
            $connection->send_packet;
            return 1;
        }
        return 0;
    }
    elsif($opcode == OPCODE_WRQ) {
        if($connection = $self->on_connect($opcode, $datagram)) {
            $connection->send_ack;
            return 1;
        }
        return 0;
    }

    # ======================
    # Connection in progress

    $connection = $self->get_connection($handle->peername);

    if(!$connection) {
        $connection = $self->connection_class->new(
                          opcode => $opcode,
                          peername => $handle->peername,
                          server => $self,
                      );

        $connection->logf(warn => 'Connection is not established');
        $connection->send_error('no_connection');

        return 0;
    }

    if($opcode == OPCODE_ACK) {
        if($connection->receive_ack($datagram) == -1) {
            $self->delete_connection($connection);
            return -1;
        }
    }
    elsif($opcode == OPCODE_DATA) {
        if($connection->receive_packet($datagram) == -1) {
            $self->delete_connection($connection);
            return -1;
        }
    }
    elsif($opcode == OPCODE_ERROR) {
        my($code, $msg) = unpack 'nZ*', $datagram;
        $connection->logf(error => 'Error from client: %s/%s', $code, $msg);
    }
    else {
        $connection->logf(error => 'Unknown opcode: %i', $opcode);
        $connection->send_error('unknown_opcode');
        return 0;
    }

    return 1;
}

=head2 on_connect

This method returns a new L<AnyEvent::TFTPd::Connection> object for
a new connection. This method is called when either a RRQ/WRQ opcode
is received in L</on_read()>.

This method might skip these steps if no more connections are
available. This is computed by comparing the number of connections
and L</max_connections>.

=cut

sub on_connect {
    my $self = shift;
    my $opcode = shift;
    my $datagram = shift;
    my $max_connections = $self->max_connections;
    my($file, $mode, @rfc) = split "\0", $datagram;
    my $connection;

    $connection = $self->connection_class->new(
                      opcode => $opcode,
                      peername => $self->peername,
                      server => $self,
                      file => $file,
                      mode => lc($mode),
                      rfc => \@rfc,
                  );

    if(0 < $max_connections and $max_connections <= $self->get_all_connections) {
        $connection->logf(debug => 'Max connection limit reached');
        return;
    }
    else {
        $connection->logf(debug => 'Connection established');
        return $self->add_connection($connection);
    }
}

=head2 on_error

This hook is called from the handler, when something unexpected has
happened. See L<AnyEvent::Handle> for details.

=cut

sub on_error {
    my $self = shift;
    my $handle = shift;
    my $fatal = shift;
    my $message = shift;

    warn $message if $DEBUG;

    if($fatal) {
        # rebuild handle
        $self->_clear_connections;
        $self->_clear_handle;
        $self->_handle;
    }

    return 1;
}

=head1 COPYRIGHT & LICENSE

Copyright 2007 Jan Henning Thorsen, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 AUTHOR

Jan Henning Thorsen C<< jhthorsen at cpan.org >>

=cut

1;
