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

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;

        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,
                file => $file,
                state => 'start',
        };
        CouchDB::audit( $opcode, $audit );

        progress_bar::start;

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

        CouchDB::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()) {
                        tftp_request $request;
                } elsif ( my $error = Net::TFTPd->error ) {
                        warn $error;
                }

        }

}

warn "loaded";

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