lib/PXElator/tftpd.pm

package tftpd;

use warnings;
use strict;

use Net::TFTPd 0.03 qw(%OPCODES);
use IO::Socket::INET;
use Data::Dump qw/dump/;

use server;

our $debug = server::debug;

our $dir  = "$server::base_dir/tftp";

sub path {
        my $glob = shift;
        my $path = (glob("$dir/$glob"))[0];
        die "can't find anything for $dir/$glob" unless $path;
        warn 'path ', $path if $debug;
        $path =~ s{^$dir}{};
        return $path;
}

use progress_bar;

sub transfer_status {
        my $request = shift;
        my $r = $request->{'_REQUEST_'} || die "no _REQUEST_ in ",dump( $request );

        if( $r->{'OPCODE'} eq $OPCODES{'RRQ'} ) {
                progress_bar::tick( $r->{FileName}, $r->{BlkSize} * $r->{LASTACK}, $r->{BlkSize} * $r->{LASTBLK} );
        } elsif ( $r->{'OPCODE'} eq $OPCODES{'WRQ'} ) {
                die "WRQ disabled";
        } else {
                warn "IGNORED: ", dump( $request );
        }
}

use config;

sub tftp_request {
        my $request = shift;

        server->refresh;

        warn 'request: ', dump( $request ) if $debug;

        config::for_ip( $request->{_REQUEST_}->{PeerAddr} );

        if ( $request->{RootDir} ne $dir ) {
                $request->{RootDir} = $dir;
                warn "new root: $dir";
        }

        my $file = $request->{'_REQUEST_'}{'FileName'};
        # received request
        print $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, " $file\n";

        progress_bar::start;

        # process the request
        if( $request->processRQ() ) {
                print "\nOK completed $file ", -s "$dir/$file", "\n";
        } else {
                print "ERROR ", Net::TFTPd->error, "\n";
                $request->processRQ();
        }

}

use server;

sub start {

        warn 'start';

        # XXX we need to setup listener ourselfs because we need Reuse
        my %params = (
                Proto => 'udp',
#               LocalAddr => $server::ip,
#               LocalAddr => '0.0.0.0',
                LocalPort => 69,
                Reuse => 1,
        );

        my $udpserver = IO::Socket::INET->new(%params);
        die "can't start server ",dump( \%params ), " $!" unless $udpserver;

        my $listener = bless {
                RootDir => $dir,

                ACKtimeout  => 4,
                ACKretries  => 4,
                Readable    => 1,
                Writable    => 0,
                Timeout => 3600,

                CallBack => \&transfer_status,
#               BlkSize => 8192,
#               BlkSize => 512,
                BlkSize => 1456,        # IBM GE seems to be picky
                Debug => 99,
                %params, # merge user parameters
                _UDPSERVER_ => $udpserver,
        }, 'Net::TFTPd';

        warn 'listener: ',dump( $listener ) if $debug;

        printf "TFTP listen %s:%d timeout: %d dir: $dir\n",
                $listener->{LocalAddr},
                $listener->{LocalPort},
                $listener->{Timeout};

        while(1) {

                # wait for any request (RRQ or WRQ)
                if(my $request = $listener->waitRQ()) {
                        tftp_request $request;
                } elsif ( my $error = Net::TFTPd->error ) {
                        warn $error;
                }

        }

}

warn "loaded";

1;
1	package tftpd;
2
3	use warnings;
4	use strict;
5
6	use Net::TFTPd 0.03 qw(%OPCODES);
7	use IO::Socket::INET;
8	use Data::Dump qw/dump/;
9
10	use server;
11
12	our $debug = server::debug;
13
14	our $dir = "$server::base_dir/tftp";
15
16	sub path {
17	my $glob = shift;
18	my $path = (glob("$dir/$glob"))[0];
19	die "can't find anything for $dir/$glob" unless $path;
20	warn 'path ', $path if $debug;
21	$path =~ s{^$dir}{};
22	return $path;
23	}
24
25	use progress_bar;
26
27	sub transfer_status {
28	my $request = shift;
29	my $r = $request->{'_REQUEST_'} \|\| die "no _REQUEST_ in ",dump( $request );
30
31	if( $r->{'OPCODE'} eq $OPCODES{'RRQ'} ) {
32	progress_bar::tick( $r->{FileName}, $r->{BlkSize} * $r->{LASTACK}, $r->{BlkSize} * $r->{LASTBLK} );
33	} elsif ( $r->{'OPCODE'} eq $OPCODES{'WRQ'} ) {
34	die "WRQ disabled";
35	} else {
36	warn "IGNORED: ", dump( $request );
37	}
38	}
39
40	use config;
41
42	sub tftp_request {
43	my $request = shift;
44
45	server->refresh;
46
47	warn 'request: ', dump( $request ) if $debug;
48
49	config::for_ip( $request->{_REQUEST_}->{PeerAddr} );
50
51	if ( $request->{RootDir} ne $dir ) {
52	$request->{RootDir} = $dir;
53	warn "new root: $dir";
54	}
55
56	my $file = $request->{'_REQUEST_'}{'FileName'};
57	# received request
58	print $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, " $file\n";
59
60	progress_bar::start;
61
62	# process the request
63	if( $request->processRQ() ) {
64	print "\nOK completed $file ", -s "$dir/$file", "\n";
65	} else {
66	print "ERROR ", Net::TFTPd->error, "\n";
67	$request->processRQ();
68	}
69
70	}
71
72	use server;
73
74	sub start {
75
76	warn 'start';
77
78	# XXX we need to setup listener ourselfs because we need Reuse
79	my %params = (
80	Proto => 'udp',
81	# LocalAddr => $server::ip,
82	# LocalAddr => '0.0.0.0',
83	LocalPort => 69,
84	Reuse => 1,
85	);
86
87	my $udpserver = IO::Socket::INET->new(%params);
88	die "can't start server ",dump( \%params ), " $!" unless $udpserver;
89
90	my $listener = bless {
91	RootDir => $dir,
92
93	ACKtimeout => 4,
94	ACKretries => 4,
95	Readable => 1,
96	Writable => 0,
97	Timeout => 3600,
98
99	CallBack => \&transfer_status,
100	# BlkSize => 8192,
101	# BlkSize => 512,
102	BlkSize => 1456, # IBM GE seems to be picky
103	Debug => 99,
104	%params, # merge user parameters
105	_UDPSERVER_ => $udpserver,
106	}, 'Net::TFTPd';
107
108	warn 'listener: ',dump( $listener ) if $debug;
109
110	printf "TFTP listen %s:%d timeout: %d dir: $dir\n",
111	$listener->{LocalAddr},
112	$listener->{LocalPort},
113	$listener->{Timeout};
114
115	while(1) {
116
117	# wait for any request (RRQ or WRQ)
118	if(my $request = $listener->waitRQ()) {
119	tftp_request $request;
120	} elsif ( my $error = Net::TFTPd->error ) {
121	warn $error;
122	}
123
124	}
125
126	}
127
128	warn "loaded";
129
130	1;