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 store;

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;

$SIG{CHLD}='IGNORE';

sub tftp_request {
        my $request = shift;

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

        if ( my $pid = fork ) {
                # parent
                warn "# forked $pid\n";
                return;
        }


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

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

        my $file = $request->{'_REQUEST_'}{'FileName'};
        my $opcode = $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}};

        my $audit = {
                ip => $ip,
                opcode => $opcode,
                path => $file,
                state => 'start',
        };
        store::audit( $opcode, $audit );

        progress_bar::start;

        # process the request
        if( $request->processRQ() ) {
                my $size = -s "$dir/$file";
                $audit->{state} = 'finish';
                $audit->{size} = $size;
                store::audit( $opcode, $audit );
        } else {
                $audit->{state} = 'error';
                $audit->{error} = Net::TFTPd->error;
                store::audit( $opcode, $audit );
        }

        exit 0;
}

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  => 1, # 4
                ACKretries  => 2, # 4
                Readable    => 1,
                Writable    => 0,
                Timeout => 3600,

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

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

        store::audit( 'start', {
                addr => $listener->{LocalAddr},
                port => $listener->{LocalPort},
                timeout => $listener->{Timeout},
                params => { %params },
        });

        while(1) {

                # wait for any request (RRQ or WRQ)
                if(my $request = $listener->waitRQ()) {
                        server->refresh;
                        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	use store;
10
11	use server;
12
13	our $debug = server::debug;
14
15	our $dir = "$server::base_dir/tftp";
16
17	sub path {
18	my $glob = shift;
19	my $path = (glob("$dir/$glob"))[0];
20	die "can't find anything for $dir/$glob" unless $path;
21	warn 'path ', $path if $debug;
22	$path =~ s{^$dir}{};
23	return $path;
24	}
25
26	use progress_bar;
27
28	sub transfer_status {
29	my $request = shift;
30	my $r = $request->{'_REQUEST_'} \|\| die "no _REQUEST_ in ",dump( $request );
31
32	if( $r->{'OPCODE'} eq $OPCODES{'RRQ'} ) {
33	progress_bar::tick( $r->{FileName}, $r->{BlkSize} * $r->{LASTACK}, $r->{BlkSize} * $r->{LASTBLK} );
34	} elsif ( $r->{'OPCODE'} eq $OPCODES{'WRQ'} ) {
35	die "WRQ disabled";
36	} else {
37	warn "IGNORED: ", dump( $request );
38	}
39	}
40
41	use config;
42
43	$SIG{CHLD}='IGNORE';
44
45	sub tftp_request {
46	my $request = shift;
47
48	warn 'request: ', dump( $request ) if $debug;
49
50	if ( my $pid = fork ) {
51	# parent
52	warn "# forked $pid\n";
53	return;
54	}
55
56
57	my $ip = $request->{_REQUEST_}->{PeerAddr};
58	config::for_ip( $ip );
59
60	if ( $request->{RootDir} ne $dir ) {
61	$request->{RootDir} = $dir;
62	warn "new root: $dir";
63	}
64
65	my $file = $request->{'_REQUEST_'}{'FileName'};
66	my $opcode = $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}};
67
68	my $audit = {
69	ip => $ip,
70	opcode => $opcode,
71	path => $file,
72	state => 'start',
73	};
74	store::audit( $opcode, $audit );
75
76	progress_bar::start;
77
78	# process the request
79	if( $request->processRQ() ) {
80	my $size = -s "$dir/$file";
81	$audit->{state} = 'finish';
82	$audit->{size} = $size;
83	store::audit( $opcode, $audit );
84	} else {
85	$audit->{state} = 'error';
86	$audit->{error} = Net::TFTPd->error;
87	store::audit( $opcode, $audit );
88	}
89
90	exit 0;
91	}
92
93	use server;
94
95	sub start {
96
97	warn 'start';
98
99	# XXX we need to setup listener ourselfs because we need Reuse
100	my %params = (
101	Proto => 'udp',
102	# LocalAddr => $server::ip,
103	# LocalAddr => '0.0.0.0',
104	LocalPort => 69,
105	Reuse => 1,
106	);
107
108	my $udpserver = IO::Socket::INET->new(%params);
109	die "can't start server ",dump( \%params ), " $!" unless $udpserver;
110
111	my $listener = bless {
112	RootDir => $dir,
113
114	ACKtimeout => 1, # 4
115	ACKretries => 2, # 4
116	Readable => 1,
117	Writable => 0,
118	Timeout => 3600,
119
120	CallBack => \&transfer_status,
121	# BlkSize => 8192,
122	BlkSize => 512, # Dell's RAC doesn't like bigger packets
123	# BlkSize => 1456, # IBM GE seems to be picky
124	Debug => 99,
125	%params, # merge user parameters
126	_UDPSERVER_ => $udpserver,
127	}, 'Net::TFTPd';
128
129	warn 'listener: ',dump( $listener ) if $debug;
130
131	store::audit( 'start', {
132	addr => $listener->{LocalAddr},
133	port => $listener->{LocalPort},
134	timeout => $listener->{Timeout},
135	params => { %params },
136	});
137
138	while(1) {
139
140	# wait for any request (RRQ or WRQ)
141	if(my $request = $listener->waitRQ()) {
142	server->refresh;
143	tftp_request $request;
144	} elsif ( my $error = Net::TFTPd->error ) {
145	warn $error;
146	}
147
148	}
149
150	}
151
152	warn "loaded";
153
154	1;