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*;/) {
544 @vals = split(/\s*,\s*/, $2);
545 $config->{$1} = [@vals];
546 $self->logger("Key: $1 Value: $2");
548 $key = 'UNDEF' unless $key;
549 my $err = "$key: 'suboptions' Bad format";
550 $self->logger($err, ERROR
);
559 $key = 'UNDEF' unless $key;
560 my $err = "$key: Bad format";
561 $self->logger($err, ERROR
);
569 $self->{_config
}->{$key} = $config;
571 $self->logger("Config data structure: \n" . Dumper
($self->{_config
}));
572 $self->unlock($self->{conf_file
});
573 if (!$self->{_config
}) {
574 die "Empty config file";
577 die "Could not read config file";
582 my ($self, $message, $level) = @_;
584 $level = DEBUG
unless ($level);
585 return unless ($level >= $self->{LOG_LEVEL
});
587 $level = "debug" if $level eq DEBUG
;
588 $level = "info" if $level eq INFO
;
589 $level = "notice" if $level eq NOTICE
;
590 $level = "warning" if $level eq WARNING
;
591 $level = "err" if $level eq ERROR
;
592 $level = "crit" if $level eq CRITICAL
;
593 $level = "alert" if $level eq ALERT
;
594 $level = "emerg" if $level eq EMERGENCY
;
596 if ($self->{DEBUG
}) {
597 print STDOUT strftime
"[%d/%b/%Y:%H:%M:%S] ", localtime;
598 print STDOUT
"$level: $message\n";
599 } elsif ($self->{log_file
} eq 'syslog') {
600 openlog
($NAME, 'ndelay,pid', 'user');
601 syslog
($level, $message);
604 my $fh = new IO
::File
;
605 if (! $fh->open("> $self->{log_file}")) {
606 croak
"$self->{log_file}: $!";
608 print $fh strftime
"[%d/%b/%Y:%H:%M:%S] ", localtime;
609 print $fh "$level: $message\n";
615 my ($self, $dhcpresp) = @_;
617 if ($self->{lease_time
}) {
618 $dhcpresp->addOptionValue(DHO_DHCP_LEASE_TIME
, $self->{lease_time
});
620 if ($self->{subnet_mask
}) {
621 $dhcpresp->addOptionValue(DHO_SUBNET_MASK
, $self->{subnet_mask
});
623 if ($self->{routers
}) {
624 $dhcpresp->addOptionValue(DHO_ROUTERS
, $self->{routers
});
626 if ($self->{broadcast_addr
}) {
627 $dhcpresp->addOptionValue(DHO_BROADCAST_ADDRESS
, $self->{broadcast_addr
});
629 if ($self->{domain_name
}) {
630 $dhcpresp->addOptionValue(DHO_DOMAIN_NAME
, $self->{domain_name
});
632 if ($self->{ntp_servers
}) {
633 $dhcpresp->addOptionValue(DHO_NTP_SERVERS
, $self->{ntp_servers
});
635 if ($self->{dns_servers
}) {
636 $dhcpresp->addOptionValue(DHO_DOMAIN_NAME_SERVERS
, $self->{dns_servers
});
641 my ($self, $dhcpreq) = @_;
642 my ($calc_ip, $req_addr, $dhcpresp);
646 $calc_ip = "192.168.9.2";
648 $self->logger("Got request\n".$dhcpreq->toString());
650 $self->{_sock_out_ip4
} = IO
::Socket
::IP
->new(
653 PeerAddr
=> inet_ntoa
(INADDR_BROADCAST
),
657 $self->logger("[discover_ip4] Socket creation error: $err", ERROR
);
658 die "[discover_ip4] Socket creation error: $err\n";
661 $req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS
());
662 $req_addr = '' unless $req_addr;
663 $self->logger("Requested IP: $req_addr", INFO
);
665 $res = $self->read_lease_file();
666 $res = $self->write_lease_file();
667 if ($res && ($req_addr =~ /^$/ || $calc_ip eq $req_addr)) {
668 $dhcpresp = new Net
::DHCP
::Packet
(
669 Comment
=> $dhcpreq->comment(),
671 Hops
=> $dhcpreq->hops(),
672 Xid
=> $dhcpreq->xid(),
673 Flags
=> $dhcpreq->flags(),
674 Ciaddr
=> $dhcpreq->ciaddr(),
676 Siaddr
=> $dhcpreq->siaddr(),
677 Giaddr
=> $dhcpreq->giaddr(),
678 Chaddr
=> $dhcpreq->chaddr(),
679 DHO_DHCP_MESSAGE_TYPE
() => DHCPOFFER
(),
680 DHO_DHCP_SERVER_IDENTIFIER
() => $self->{_sock_out_ip4
}->sockhost
682 $self->add_options($dhcpresp);
684 # bad request, we send a NAK
685 $dhcpresp = new Net
::DHCP
::Packet
(
686 Comment
=> $dhcpreq->comment(),
688 Hops
=> $dhcpreq->hops(),
689 Xid
=> $dhcpreq->xid(),
690 Flags
=> $dhcpreq->flags(),
691 Ciaddr
=> $dhcpreq->ciaddr(),
693 Siaddr
=> $dhcpreq->siaddr(),
694 Giaddr
=> $dhcpreq->giaddr(),
695 Chaddr
=> $dhcpreq->chaddr(),
696 DHO_DHCP_MESSAGE_TYPE
() => DHCPNAK
(),
697 DHO_DHCP_MESSAGE
(), "Bad request...",
701 $self->logger("Sending response to " .
702 $self->{_sock_out_ip4
}->peerhost . ':' .
703 $self->{_sock_out_ip4
}->peerport, INFO
);
705 # Socket object keeps track of whom sent last packet
706 # so we don't need to specify target address
707 $self->logger($dhcpresp->toString());
708 $self->logger("Sending OFFER tr=".$dhcpresp->comment(), INFO
);
709 $self->{_sock_out_ip4
}->send($dhcpresp->serialize()) || die "Error sending OFFER: $!\n";
713 my ($self, $dhcpreq) = @_;
714 my ($calc_ip, $dhcpresp, $peeraddr, $result);
716 $calc_ip = "192.168.9.2";
718 $peeraddr = $dhcpreq->ciaddr() ?
$dhcpreq->ciaddr() : inet_ntoa
(INADDR_BROADCAST
);
719 $self->{_sock_out_ip4
} = IO
::Socket
::IP
->new(
722 PeerAddr
=> $peeraddr,
726 $self->logger("[request_ip4] Socket creation error: $err", ERROR
);
727 die "[request_ip4] Socket creation error: $err\n";
730 # compare calculated address with requested address
731 if ($calc_ip eq $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS
())) {
732 # address is correct, we send an ACK
733 $dhcpresp = new Net
::DHCP
::Packet
(
734 Comment
=> $dhcpreq->comment(),
736 Hops
=> $dhcpreq->hops(),
737 Xid
=> $dhcpreq->xid(),
738 Flags
=> $dhcpreq->flags(),
739 Ciaddr
=> $dhcpreq->ciaddr(),
741 Siaddr
=> $dhcpreq->siaddr(),
742 Giaddr
=> $dhcpreq->giaddr(),
743 Chaddr
=> $dhcpreq->chaddr(),
744 DHO_DHCP_MESSAGE_TYPE
() => DHCPACK
(),
745 DHO_DHCP_SERVER_IDENTIFIER
() => $self->{_sock_out_ip4
}->sockhost,
747 $self->add_options($dhcpresp);
750 # bad request, we send a NAK
751 $self->write_lease_file();
752 $dhcpresp = new Net
::DHCP
::Packet
(
753 Comment
=> $dhcpreq->comment(),
755 Hops
=> $dhcpreq->hops(),
756 Xid
=> $dhcpreq->xid(),
757 Flags
=> $dhcpreq->flags(),
758 Ciaddr
=> $dhcpreq->ciaddr(),
760 Siaddr
=> $dhcpreq->siaddr(),
761 Giaddr
=> $dhcpreq->giaddr(),
762 Chaddr
=> $dhcpreq->chaddr(),
763 DHO_DHCP_MESSAGE_TYPE
() => DHCPNAK
(),
764 DHO_DHCP_MESSAGE
(), "Bad request...",
769 $self->logger("Sending response to " .
770 $self->{_sock_out_ip4
}->peerhost . ':' .
771 $self->{_sock_out_ip4
}->peerport, INFO
);
773 # Socket object keeps track of whom sent last packet
774 # so we don't need to specify target address
775 $self->logger($dhcpresp->toString());
776 $self->logger("Sending $result tr=".$dhcpresp->comment(), INFO
);
777 $self->{_sock_out_ip4
}->send($dhcpresp->serialize()) || die "Error sending ACK/NAK: $!\n";
781 my ($self, $dhcpreq) = @_;
783 $self->logger($dhcpreq->toString());
784 $self->write_lease_file();
788 my ($self, $addr, $dhcpreq) = @_;
790 $self->logger("IPv6 request from [$addr]: $dhcpreq", INFO
);
791 $self->{_sock_out_ip6
} = IO
::Socket
::IP
->new(
800 $self->logger("[excuse_me_ip6] Socket creation error: $err", ERROR
);
801 die "[excuse_me_ip6] Socket creation error: $err\n";
803 $self->logger("$addr: Not implemented here", INFO
);
804 $self->{_sock_out_ip6
}->send("Not implemented here") || die "Error sending excuse: $!\n";