git.rot13.org Git - pxelator/blob - lib/PXElator/tftpd.pm

   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;