1 package PVE
::DHCPServer
;
10 use Net
::DHCP
::Constants
;
15 use Fcntl
qw(:DEFAULT :flock SEEK_END);
16 use POSIX
qw(EINTR setsid strftime);
32 our @ISA = qw(Exporter);
33 our @EXPORT = qw(run);
46 our %EXPORT_TAGS = ( constants
=> [
57 our $VERSION = '0.01';
58 our $NAME = 'PVE::DHCPServer';
61 # generic signal handler to cause daemon to stop
65 $SIG{INT
} = $SIG{TERM
} = $SIG{HUP
} = \
&signal_handler
;
67 # ignore any PIPE signal: standard behaviour is to quit process
68 $SIG{PIPE
} = 'IGNORE';
71 my ($class, %self) = @_;
74 $class = ref($class) || $class;
79 $self->{_sock_in_ip4
} = undef;
80 $self->{_sock_out_ip4
} = undef;
81 $self->{_sock_in_ip6
} = undef;
82 $self->{_sock_out_ip6
} = undef;
83 $self->{_leases
} = undef;
84 $self->{_reverse
} = undef;
85 $self->{_config
} = undef;
86 $self->{_transaction_ip4
} = 0;
87 $self->{_transaction_ip6
} = 0;
90 $self->{log_file
} ||= 'syslog';
91 $self->{lease_time
} ||= 7200;
92 $self->{subnet_mask
} ||= undef;
93 $self->{routers
} ||= undef;
94 $self->{broadcast_addr
} ||= undef;
95 $self->{domain_name
} ||= undef;
96 $self->{dns_servers
} ||= undef;
97 $self->{ntp_servers
} ||= undef;
98 $self->{LOG_LEVEL
} = ERROR
unless defined $self->{LOG_LEVEL
};
99 $self->{NODAEMON
} ||= 0;
100 $self->{DEBUG
} ||= 0;
101 $self->{timeout
} ||= 10;
102 $self->{lease_file
} ||= '/tmp/dhcpd.leases';
103 $self->{conf_file
} ||= '/tmp/dhcpd.cfg';
110 my ($sel, @ready, $socket, $res);
113 $self->read_config();
117 $self->logger($err, ERROR
);
120 $self->logger("Starting dhcpd", INFO
);
121 if ($self->{NODAEMON
} < 1) {
122 $self->logger("Entering Daemon mode");
123 chdir '/' or die "Can't chdir to /: $!";
126 open STDIN
, '/dev/null' or die "Can't read /dev/null: $!";
127 open STDOUT
, '>/dev/null' or die "Can't write to /dev/null: $!";
128 open STDERR
, '>/dev/null' or die "Can't write to /dev/null: $!";
134 $self->logger("Couldn't fork: $err", ERROR
);
135 die "Couldn't fork: $err";
136 } unless defined($pid);
138 POSIX
::setsid
() || do {
140 $self->logger("Can't start a new session: $err", ERROR
);
141 die "Can't start a new session: $err";
143 $self->logger("Now in Daemon mode", INFO
);
146 $res = $self->read_lease_file();
147 $self->logger("Starting with empty leases file '$self->{lease_file}'", INFO
) unless $res;
149 $self->logger("Initialization complete", INFO
);
151 # open listening socket
152 $self->{_sock_in_ip4
} = IO
::Socket
::IP
->new(
155 LocalAddr
=> inet_ntoa
(INADDR_ANY
),
159 $self->logger("IP4 Socket creation error: $err", ERROR
);
160 die "IP4 Socket creation error: $err\n";
162 $self->{_sock_in_ip6
} = IO
::Socket
::IP
->new(
170 $self->logger("IP6 Socket creation error: $err", ERROR
);
171 die "IP6 Socket creation error: $err\n";
174 $sel = IO
::Select
->new($self->{_sock_in_ip4
});
175 $sel->add($self->{_sock_in_ip6
});
177 until ($time_to_die) {
182 eval { # catch fatal errors
183 while (@ready = $sel->can_read) {
184 $self->logger("Waiting for incoming packet", INFO
);
185 foreach $socket (@ready) {
186 if ($socket == $self->{_sock_in_ip4
}) {
187 # receive ipv4 packet
188 $fromaddr = $self->{_sock_in_ip4
}->recv($buf, 4096)
189 || $self->logger("recv: $!", ERROR
);
190 next if ($!); # continue loop if an error occured
191 $self->{_transaction_ip4
}++; # transaction counter
195 my ($port,$addr) = unpack_sockaddr_in
($fromaddr);
196 my $ipaddr = inet_ntoa
($addr);
197 $self->logger("Got a packet tr=$self->{_transaction_ip4} src=$ipaddr:$port length=".length($buf), INFO
);
201 my $dhcpreq = new Net
::DHCP
::Packet
($buf);
202 $dhcpreq->comment($self->{_transaction_ip4
});
204 my $messagetype = $dhcpreq->getOptionValue(DHO_DHCP_MESSAGE_TYPE
());
206 if ($messagetype eq DHCPDISCOVER
()) {
207 $self->discover_ip4($dhcpreq);
208 } elsif ($messagetype eq DHCPREQUEST
()) {
209 $self->request_ip4($dhcpreq);
210 } elsif ($messagetype eq DHCPINFORM
()) {
211 $self->logger("Not implemented: DHCPINFORM", WARNING
);
212 } elsif ($messagetype eq DHCPRELEASE
()) {
213 $self->release_ip4($dhcpreq);
215 $self->logger("Packet dropped", WARNING
);
216 # bad messagetype, we drop it
219 # Receive ipv6 packet
222 $fromaddr = $self->{_sock_in_ip6
}->recv($buf, 4096)
223 || $self->logger("recv: $!", ERROR
);
224 next if ($!); # continue loop if an error occured
225 $self->{_transaction_ip6
}++; # transaction counter
226 $self->logger("recv: $buf", INFO
);
229 my ($port,$addr) = unpack_sockaddr_in6
($fromaddr);
230 $ipaddr = inet_ntop
(AF_INET6
, $addr);
231 $self->logger("Got a packet tr=$self->{_transaction_ip6} src=$ipaddr:$port length=".length($buf), INFO
);
233 $self->excuse_me_ip6($ipaddr, $buf);
237 }; # end of 'eval' blocks
239 $self->logger("Caught error in main loop: $@", ERROR
);
242 $self->{_sock_in_ip4
}->close;
243 $self->{_sock_in_ip6
}->close;
244 $self->logger("Exiting dhcpd", INFO
);
247 sub run_with_timeout
{
248 my ($self, $code, @param) = @_;
250 die "got timeout" if $self->{timeout
} <= 0;
258 local $SIG{ALRM
} = sub { $sigcount++; }; # catch alarm outside eval
261 local $SIG{ALRM
} = sub { $sigcount++; die "got timeout"; };
262 local $SIG{PIPE
} = sub { $sigcount++; die "broken pipe" };
263 local $SIG{__DIE__
}; # see SA bug 4631
265 $prev_alarm = alarm($self->{timeout
});
267 $res = &$code(@param);
269 alarm(0); # avoid race conditions
274 alarm($prev_alarm) if defined($prev_alarm);
276 die "unknown error" if $sigcount && !$err; # seems to happen sometimes
284 my ($self, $file, $shared) = @_;
286 my $mode = $shared ? LOCK_SH
: LOCK_EX
;
288 my $lock_func = sub {
289 if ($mode == LOCK_SH
) {
290 $self->{file_handle
} = new IO
::File
("<$file") ||
291 die "can't open file '$file' for read - $!";
293 $self->{file_handle
} = new IO
::File
(">$file") ||
294 die "can't open file '$file' for write - $!";
296 $self->logger("trying to aquire lock on '$file'...");
297 if (!flock ($self->{file_handle
}, $mode|LOCK_NB
)) {
300 $success = flock($self->{file_handle
}, $mode);
301 # try again on EINTR (see bug #273)
302 if ($success || ($! != EINTR
)) {
306 if ($mode == LOCK_SH
) {
307 seek($self->{file_handle
}, 0, SEEK_END
) or $success = 0;
310 $self->logger(" failed");
311 die "can't aquire lock - $!";
314 $self->logger(" OK");
321 $res = $self->run_with_timeout($lock_func);
324 $self->logger("can't lock file '$file' - $@", ERROR
);
325 $self->{file_handle
} = undef;
333 my ($self, $file) = @_;
335 return '' unless($self->{file_handle
});
336 my $unlock_func = sub {
337 $self->logger("trying to unlock '$file'...");
338 if (!flock($self->{file_handle
}, LOCK_UN
)) {
342 $success = flock($self->{file_handle
}, LOCK_UN
);
343 # try again on EINTR (see bug #273)
344 if ($success || ($! != EINTR
)) {
349 $self->logger(" failed");
350 die "can't unlock - $!";
353 $self->logger(" OK");
360 $res = $self->run_with_timeout($unlock_func);
363 $self->logger("can't lock file '$file' - $@", ERROR
);
364 $self->{file_handle
} = undef;
371 sub convert_timestamp
{
372 my ($self, $timestamp, $strtotime) = @_;
373 my ($res, $mday, $mon, $year, $hour, $min, $sec);
375 $self->logger("Timestamp: $timestamp");
377 if ($timestamp !~ /^\d{4}\/\d
{2}\
/\d{2}\s+\d{2}:\d{2}:\d{2}$/) {
378 $self->logger("$timestamp: Bad format", ERROR
);
381 ($year,$mon,$mday,$hour,$min,$sec) = split(/[\s\/:]+/, $timestamp);
382 $res = timelocal
($sec,$min,$hour,$mday,$mon-1,$year);
385 if ($timestamp !~ /^\d+$/) {
386 $self->logger("$timestamp: Bad format", ERROR
);
389 ($sec,$min,$hour,$mday,$mon,$year) = localtime($timestamp);
390 $self->logger("Timestamp: $sec,$min,$hour,$mday,$mon,$year");
391 $res = sprintf("%d/%02d/%02d %02d:%02d:%02d", ($year+1900),($mon+1),$mday,$hour,$min,$sec);
392 $self->logger("Timestamp: $res");
401 my ($self, $ip, $lease) = @_;
404 my $mac = $lease->{'hardware ethernet'};
406 $lease->{'hardware ethernet'} = $mac;
407 $ts = $self->convert_timestamp($lease->{starts
}, 1);
409 $lease->{starts
} = $ts;
410 $ts = $self->convert_timestamp($lease->{ends
}, 1);
412 $lease->{ends
} = $ts;
414 $self->{_leases
}->{$ip} = $lease;
415 $self->{_reverse
}->{$mac} = $ip;
416 $self->logger("$mac =>\n" . Dumper
($self->{_reverse
}->{$mac}));
419 #lease vvv.xxx.yyy.zzz {
420 # starts yyyy/mm/dd hh:mm:ss;
421 # ends yyyy/mm/dd hh:mm:ss;
422 # binding state active|free;
423 # hardware ethernet MAC;
424 # client-hostname "name"
426 sub read_lease_file
{
428 my ($res, $key, $lease);
431 $self->lock($self->{lease_file
}, 1);
432 if ($self->{file_handle
}) {
433 my $fh = $self->{file_handle
};
436 $self->logger("Read: $_");
437 if ($_ =~ /^\s*lease\s+([\d\.]+)\s+{\s*/) {
438 $self->add_lease($key, $lease) if $lease;
442 $self->logger("Key: $key");
445 next if ($_ =~ /^\s*}\s*/ || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
446 if ($_ =~ /^\s*(starts|ends|binding state|hardware ethernet|client-hostname)\s+(.+)\s*;/) {
448 $self->logger("Key: $1 Value: $2");
450 $key = 'UNDEF' unless $key;
451 $self->logger("$key: Bad format", ERROR
);
458 if ($lease && !$error) {
459 $self->logger("Key: $key");
460 $self->add_lease($key, $lease);
462 $self->logger("Leases data structure: \n" . Dumper
($self->{_leases
}));
463 $self->unlock($self->{lease_file
});
466 $self->logger("Could not read leases file", ERROR
);
473 sub write_lease_file
{
477 $res = $self->lock($self->{lease_file
}, 0);
478 if ($self->{file_handle
}) {
479 my $fh = $self->{file_handle
};
480 while ((my $lease, my $elems) = each $self->{_leases
}) {
481 $self->logger("Writing: $lease");
482 print $fh "lease $lease {\n";
483 while ((my $key, my $val) = each %$elems) {
484 if ($key =~ /^(starts|ends)$/) {
485 $val = $self->convert_timestamp($val, 0);
487 $self->logger("Writing: $key $val");
488 print $fh "\t$key $val;\n";
492 $self->unlock($self->{lease_file
});
495 $self->logger("Could not write leases file", ERROR
);
502 #subnet 192.168.9.0 netmask 255.255.255.0 {
503 # range 192.168.9.2 192.168.9.100;
506 # router 192.168.9.254;
507 # dns-servers 192.168.2.201;
508 # ntp-servers 192.168.9.254;
509 # broadcast 192.168.9.255;
510 # domain-name "foo.bar";
512 # allow 001cc0c33317,001cc0c33318,001cc0c33319,001cc0c33320;
513 # static 001cc0c33317 192.168.9.100,001cc0c33318 192.168.9.200;
518 my ($res, $key, $netmask, $config, $subopt);
520 $self->lock($self->{conf_file
}, 1);
521 if ($self->{file_handle
}) {
522 my $fh = $self->{file_handle
};
526 $self->logger("Read: $_");
527 if ($_ =~ /^\s*subnet\s+([\d\.]+)\s+netmask\s+([\d\.]+)\s+{\s*/) {
528 $self->{_config
}->{$key} = $config if $config;
531 $config->{netmask
} = $2;
532 $self->logger("Key: $key Netmask: $config->{netmask}");
534 next if (($_ =~ /^\s*}\s*/ && ! $subopt) || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
535 if (! $subopt && $_ =~ /^\s*(range|ttl|rttl|router|dns-servers|ntp-servers|broadcast|domain-name)\s+(.+)\s*;/) {
537 $self->logger("Key: $1 Value: $2");
538 } elsif ($subopt &&$_ =~ /^\s*}\s*/) {
540 } elsif ($subopt || $_ =~ /^\s*{\s*/) {
542 if ($_ =~ /^\s*(allow|static)\s+(.+)\s*;/) {
543 my @vals = split(/\s*,\s*/, $2);
544 $config->{$1} = [@vals];
545 $self->logger("Key: $1 Value: $2");
547 $key = 'UNDEF' unless $key;
548 my $err = "$key: 'suboptions' Bad format";
549 $self->logger($err, ERROR
);
558 $key = 'UNDEF' unless $key;
559 my $err = "$key: Bad format";
560 $self->logger($err, ERROR
);
568 $self->{_config
}->{$key} = $config;
570 $self->logger("Config data structure: \n" . Dumper
($self->{_config
}));
571 $self->unlock($self->{conf_file
});
572 if (!$self->{_config
}) {
573 die "Empty config file";
576 die "Could not read config file";
581 my ($self, $message, $level) = @_;
583 $level = DEBUG
unless ($level);
584 return unless ($level >= $self->{LOG_LEVEL
});
586 $level = "debug" if $level eq DEBUG
;
587 $level = "info" if $level eq INFO
;
588 $level = "notice" if $level eq NOTICE
;
589 $level = "warning" if $level eq WARNING
;
590 $level = "err" if $level eq ERROR
;
591 $level = "crit" if $level eq CRITICAL
;
592 $level = "alert" if $level eq ALERT
;
593 $level = "emerg" if $level eq EMERGENCY
;
595 if ($self->{DEBUG
}) {
596 print STDOUT strftime
"[%d/%b/%Y:%H:%M:%S] ", localtime;
597 print STDOUT
"$level: $message\n";
598 } elsif ($self->{log_file
} eq 'syslog') {
599 openlog
($NAME, 'ndelay,pid', 'user');
600 syslog
($level, $message);
603 my $fh = new IO
::File
;
604 if (! $fh->open("> $self->{log_file}")) {
605 croak
"$self->{log_file}: $!";
607 print $fh strftime
"[%d/%b/%Y:%H:%M:%S] ", localtime;
608 print $fh "$level: $message\n";
614 my ($self, $dhcpresp) = @_;
616 if ($self->{lease_time
}) {
617 $dhcpresp->addOptionValue(DHO_DHCP_LEASE_TIME
, $self->{lease_time
});
619 if ($self->{subnet_mask
}) {
620 $dhcpresp->addOptionValue(DHO_SUBNET_MASK
, $self->{subnet_mask
});
622 if ($self->{routers
}) {
623 $dhcpresp->addOptionValue(DHO_ROUTERS
, $self->{routers
});
625 if ($self->{broadcast_addr
}) {
626 $dhcpresp->addOptionValue(DHO_BROADCAST_ADDRESS
, $self->{broadcast_addr
});
628 if ($self->{domain_name
}) {
629 $dhcpresp->addOptionValue(DHO_DOMAIN_NAME
, $self->{domain_name
});
631 if ($self->{ntp_servers
}) {
632 $dhcpresp->addOptionValue(DHO_NTP_SERVERS
, $self->{ntp_servers
});
634 if ($self->{dns_servers
}) {
635 $dhcpresp->addOptionValue(DHO_DOMAIN_NAME_SERVERS
, $self->{dns_servers
});
640 my ($self, $dhcpreq) = @_;
641 my ($calc_ip, $req_addr, $dhcpresp);
645 $calc_ip = "192.168.9.2";
647 $self->logger("Got request\n".$dhcpreq->toString());
649 $self->{_sock_out_ip4
} = IO
::Socket
::IP
->new(
652 PeerAddr
=> inet_ntoa
(INADDR_BROADCAST
),
656 $self->logger("[discover_ip4] Socket creation error: $err", ERROR
);
657 die "[discover_ip4] Socket creation error: $err\n";
660 $req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS
());
661 $req_addr = '' unless $req_addr;
662 $self->logger("Requested IP: $req_addr", INFO
);
664 $res = $self->read_lease_file();
665 $res = $self->write_lease_file();
666 if ($res && ($req_addr =~ /^$/ || $calc_ip eq $req_addr)) {
667 $dhcpresp = new Net
::DHCP
::Packet
(
668 Comment
=> $dhcpreq->comment(),
670 Hops
=> $dhcpreq->hops(),
671 Xid
=> $dhcpreq->xid(),
672 Flags
=> $dhcpreq->flags(),
673 Ciaddr
=> $dhcpreq->ciaddr(),
675 Siaddr
=> $dhcpreq->siaddr(),
676 Giaddr
=> $dhcpreq->giaddr(),
677 Chaddr
=> $dhcpreq->chaddr(),
678 DHO_DHCP_MESSAGE_TYPE
() => DHCPOFFER
(),
679 DHO_DHCP_SERVER_IDENTIFIER
() => $self->{_sock_out_ip4
}->sockhost
681 $self->add_options($dhcpresp);
683 # bad request, we send a NAK
684 $dhcpresp = new Net
::DHCP
::Packet
(
685 Comment
=> $dhcpreq->comment(),
687 Hops
=> $dhcpreq->hops(),
688 Xid
=> $dhcpreq->xid(),
689 Flags
=> $dhcpreq->flags(),
690 Ciaddr
=> $dhcpreq->ciaddr(),
692 Siaddr
=> $dhcpreq->siaddr(),
693 Giaddr
=> $dhcpreq->giaddr(),
694 Chaddr
=> $dhcpreq->chaddr(),
695 DHO_DHCP_MESSAGE_TYPE
() => DHCPNAK
(),
696 DHO_DHCP_MESSAGE
(), "Bad request...",
700 $self->logger("Sending response to " .
701 $self->{_sock_out_ip4
}->peerhost . ':' .
702 $self->{_sock_out_ip4
}->peerport, INFO
);
704 # Socket object keeps track of whom sent last packet
705 # so we don't need to specify target address
706 $self->logger($dhcpresp->toString());
707 $self->logger("Sending OFFER tr=".$dhcpresp->comment(), INFO
);
708 $self->{_sock_out_ip4
}->send($dhcpresp->serialize()) || die "Error sending OFFER: $!\n";
712 my ($self, $dhcpreq) = @_;
713 my ($calc_ip, $dhcpresp, $peeraddr, $result);
715 $calc_ip = "192.168.9.2";
717 $peeraddr = $dhcpreq->ciaddr() ?
$dhcpreq->ciaddr() : inet_ntoa
(INADDR_BROADCAST
);
718 $self->{_sock_out_ip4
} = IO
::Socket
::IP
->new(
721 PeerAddr
=> $peeraddr,
725 $self->logger("[request_ip4] Socket creation error: $err", ERROR
);
726 die "[request_ip4] Socket creation error: $err\n";
729 # compare calculated address with requested address
730 if ($calc_ip eq $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS
())) {
731 # address is correct, we send an ACK
732 $dhcpresp = new Net
::DHCP
::Packet
(
733 Comment
=> $dhcpreq->comment(),
735 Hops
=> $dhcpreq->hops(),
736 Xid
=> $dhcpreq->xid(),
737 Flags
=> $dhcpreq->flags(),
738 Ciaddr
=> $dhcpreq->ciaddr(),
740 Siaddr
=> $dhcpreq->siaddr(),
741 Giaddr
=> $dhcpreq->giaddr(),
742 Chaddr
=> $dhcpreq->chaddr(),
743 DHO_DHCP_MESSAGE_TYPE
() => DHCPACK
(),
744 DHO_DHCP_SERVER_IDENTIFIER
() => $self->{_sock_out_ip4
}->sockhost,
746 $self->add_options($dhcpresp);
749 # bad request, we send a NAK
750 $self->write_lease_file();
751 $dhcpresp = new Net
::DHCP
::Packet
(
752 Comment
=> $dhcpreq->comment(),
754 Hops
=> $dhcpreq->hops(),
755 Xid
=> $dhcpreq->xid(),
756 Flags
=> $dhcpreq->flags(),
757 Ciaddr
=> $dhcpreq->ciaddr(),
759 Siaddr
=> $dhcpreq->siaddr(),
760 Giaddr
=> $dhcpreq->giaddr(),
761 Chaddr
=> $dhcpreq->chaddr(),
762 DHO_DHCP_MESSAGE_TYPE
() => DHCPNAK
(),
763 DHO_DHCP_MESSAGE
(), "Bad request...",
768 $self->logger("Sending response to " .
769 $self->{_sock_out_ip4
}->peerhost . ':' .
770 $self->{_sock_out_ip4
}->peerport, INFO
);
772 # Socket object keeps track of whom sent last packet
773 # so we don't need to specify target address
774 $self->logger($dhcpresp->toString());
775 $self->logger("Sending $result tr=".$dhcpresp->comment(), INFO
);
776 $self->{_sock_out_ip4
}->send($dhcpresp->serialize()) || die "Error sending ACK/NAK: $!\n";
780 my ($self, $dhcpreq) = @_;
782 $self->logger($dhcpreq->toString());
783 $self->write_lease_file();
787 my ($self, $addr, $dhcpreq) = @_;
789 $self->logger("IPv6 request from [$addr]: $dhcpreq", INFO
);
790 $self->{_sock_out_ip6
} = IO
::Socket
::IP
->new(
799 $self->logger("[excuse_me_ip6] Socket creation error: $err", ERROR
);
800 die "[excuse_me_ip6] Socket creation error: $err\n";
802 $self->logger("$addr: Not implemented here", INFO
);
803 $self->{_sock_out_ip6
}->send("Not implemented here") || die "Error sending excuse: $!\n";