1 package PVE
::DHCPServer
;
14 use Fcntl
qw(:DEFAULT :flock SEEK_END);
15 use POSIX
qw(EINTR setsid strftime);
19 use Net
::DHCP
::Packet
;
20 use Net
::DHCP
::Constants
;
36 our @ISA = qw(Exporter);
49 our $VERSION = '0.01';
50 our $NAME = 'PVE::DHCPServer';
51 our $DEFAULT_LEASE = 7200;
52 our $DEFAULT_LEASE_RENEW = 5400;
55 #########################################################################
57 #########################################################################
60 my ($self, $message, $level) = @_;
63 return unless ($level >= $self->{LOG_LEVEL
});
65 $level = "debug" if $level eq DEBUG
;
66 $level = "info" if $level eq INFO
;
67 $level = "notice" if $level eq NOTICE
;
68 $level = "warning" if $level eq WARNING
;
69 $level = "err" if $level eq ERROR
;
70 $level = "crit" if $level eq CRITICAL
;
71 $level = "alert" if $level eq ALERT
;
72 $level = "emerg" if $level eq EMERGENCY
;
75 print STDOUT strftime
"[%d/%b/%Y:%H:%M:%S] ", localtime;
76 print STDOUT
"$level: " . ($message ?
$message : 'No message') . "\n";
77 } elsif ($self->{log_file
} eq 'syslog') {
78 openlog
($NAME, 'ndelay,pid', 'user');
79 syslog
($level, $message);
82 my $fh = new IO
::File
;
83 if (! $fh->open("> $self->{log_file}")) {
84 croak
"$self->{log_file}: $!";
86 print $fh strftime
"[%d/%b/%Y:%H:%M:%S] ", localtime;
87 print $fh "$level: $message\n";
92 my $run_with_timeout = sub {
93 my ($self, $code, @param) = @_;
95 die "got timeout" if $self->{timeout
} <= 0;
103 local $SIG{ALRM
} = sub { $sigcount++; }; # catch alarm outside eval
106 local $SIG{ALRM
} = sub { $sigcount++; die "got timeout"; };
107 local $SIG{PIPE
} = sub { $sigcount++; die "broken pipe" };
108 local $SIG{__DIE__
}; # see SA bug 4631
110 $prev_alarm = alarm($self->{timeout
});
112 $res = &$code(@param);
114 alarm(0); # avoid race conditions
119 alarm($prev_alarm) if defined($prev_alarm);
121 die "unknown error" if $sigcount && !$err; # seems to happen sometimes
129 my ($self, $file, $shared) = @_;
131 my $mode = $shared ? LOCK_SH
: LOCK_EX
;
133 my $lock_func = sub {
134 if ($mode == LOCK_SH
) {
135 $self->{file_handle
} = new IO
::File
("<$file") ||
136 die "can't open file '$file' for read - $!";
138 $self->{file_handle
} = new IO
::File
(">$file") ||
139 die "can't open file '$file' for write - $!";
141 $self->$logger("trying to aquire lock on '$file'...");
142 if (!flock ($self->{file_handle
}, $mode|LOCK_NB
)) {
145 $success = flock($self->{file_handle
}, $mode);
146 # try again on EINTR (see bug #273)
147 if ($success || ($! != EINTR
)) {
151 if ($mode == LOCK_SH
) {
152 seek($self->{file_handle
}, 0, SEEK_END
) or $success = 0;
155 $self->$logger(" failed");
156 die "can't aquire lock - $!";
159 $self->$logger(" OK");
166 $res = $self->$run_with_timeout($lock_func);
169 $self->$logger("can't lock file '$file' - $@", ERROR
);
170 $self->{file_handle
} = undef;
178 my ($self, $file) = @_;
180 return '' unless($self->{file_handle
});
181 my $unlock_func = sub {
182 $self->$logger("trying to unlock '$file'...");
183 if (!flock($self->{file_handle
}, LOCK_UN
)) {
187 $success = flock($self->{file_handle
}, LOCK_UN
);
188 # try again on EINTR (see bug #273)
189 if ($success || ($! != EINTR
)) {
194 $self->$logger(" failed");
195 die "can't unlock - $!";
198 $self->$logger(" OK");
205 $res = $self->$run_with_timeout($unlock_func);
208 $self->$logger("can't lock file '$file' - $@", ERROR
);
209 $self->{file_handle
} = undef;
216 my $convert_timestamp = sub {
217 my ($self, $timestamp, $strtotime) = @_;
218 my ($res, $mday, $mon, $year, $hour, $min, $sec);
220 $self->$logger("Timestamp: $timestamp");
222 if ($timestamp !~ /^\d{4}\/\d
{2}\
/\d{2}\s+\d{2}:\d{2}:\d{2}$/) {
223 $self->$logger("$timestamp: (strtotime) Bad format", ERROR
);
226 ($year,$mon,$mday,$hour,$min,$sec) = split(/[\s\/:]+/, $timestamp);
227 $res = timelocal
($sec,$min,$hour,$mday,$mon-1,$year);
230 $self->$logger($timestamp);
231 if ($timestamp !~ /^\d+$/) {
232 $self->$logger("$timestamp: (timetostr) Bad format", ERROR
);
235 ($sec,$min,$hour,$mday,$mon,$year) = localtime($timestamp);
236 $self->$logger("Timestamp: $sec,$min,$hour,$mday,$mon,$year");
237 $res = sprintf("%d/%02d/%02d %02d:%02d:%02d", ($year+1900),($mon+1),$mday,$hour,$min,$sec);
238 $self->$logger("Timestamp: $res");
246 my $add_lease = sub {
247 my ($self, $ip, $lease) = @_;
250 my $mac = $lease->{'hardware ethernet'};
252 $lease->{'hardware ethernet'} = $mac;
253 $ts = $self->$convert_timestamp($lease->{starts
}, 1);
255 $lease->{starts
} = $ts;
256 $ts = $self->$convert_timestamp($lease->{ends
}, 1);
258 $lease->{ends
} = $ts;
260 $self->{_leases
}->{$ip} = $lease;
261 $self->$logger(Dumper
($self->{_leases
}->{$ip}));
262 $self->{_reverse
}->{$mac} = $ip;
263 $self->$logger("$mac => $self->{_reverse}->{$mac}");
266 #lease vvv.xxx.yyy.zzz {
267 # starts yyyy/mm/dd hh:mm:ss;
268 # ends yyyy/mm/dd hh:mm:ss;
269 # binding state active|free;
270 # hardware ethernet MAC;
271 # client-hostname "name"
273 my $read_lease_file = sub {
275 my ($res, $key, $lease);
278 # Start with empty leases file?
279 if (! -e
$self->{lease_file
}) {
283 $self->$lock($self->{lease_file
}, 1);
284 if ($self->{file_handle
}) {
285 my $fh = $self->{file_handle
};
288 $self->$logger("Read: $_");
289 if ($_ =~ /^\s*lease\s+([\d\.]+)\s+{\s*/) {
290 $self->$add_lease($key, $lease) if $lease;
294 $self->$logger("Key: $key");
297 next if ($_ =~ /^\s*}\s*/ || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
298 if ($_ =~ /^\s*(starts|ends|binding state|hardware ethernet|client-hostname)\s+(.+)\s*;/) {
300 $self->$logger("Key: $1 Value: $2");
302 $key = 'UNDEF' unless $key;
303 $self->$logger("$key: Bad format", ERROR
);
310 if ($lease && !$error) {
311 $self->$logger("Key: $key");
312 $self->$add_lease($key, $lease);
314 $self->$logger("Leases data structure: \n" . Dumper
($self->{_leases
}));
315 $self->$unlock($self->{lease_file
});
318 $self->$logger("Could not read leases file", INFO
);
325 my $write_lease_file = sub {
329 $res = $self->$lock($self->{lease_file
}, 0);
330 if ($self->{file_handle
}) {
331 if ($self->{_leases
}) {
332 my $fh = $self->{file_handle
};
333 my $leases = $self->{_leases
};
334 while ((my $lease, my $elems) = each (%$leases)) {
335 $self->$logger("Writing: $lease");
336 print $fh "lease $lease {\n";
337 while ((my $key, my $val) = each %$elems) {
338 if ($key =~ /^(starts|ends)$/) {
339 $val = $self->$convert_timestamp($val, 0);
341 $self->$logger("Writing: $key $val");
342 print $fh "\t$key $val;\n";
347 $self->$unlock($self->{lease_file
});
350 $self->$logger("$self->{lease_file}: Could not write leases file", ERROR
);
357 #subnet 192.168.9.0 netmask 255.255.255.0 {
358 # range 192.168.9.2 192.168.9.100;
361 # router 192.168.9.254;
362 # dns-servers 192.168.2.201;
363 # ntp-servers 192.168.9.254;
364 # broadcast 192.168.9.255;
365 # domain-name "foo.bar";
367 # allow 001cc0c33317,001cc0c33318,001cc0c33319,001cc0c33320;
368 # static 001cc0c33317 192.168.9.100,001cc0c33318 192.168.9.200;
371 my $read_config = sub {
373 my ($res, $key, $netmask, $config, $subopt);
375 $self->$lock($self->{conf_file
}, 1);
376 if ($self->{file_handle
}) {
377 my $fh = $self->{file_handle
};
381 $self->$logger("Read: $_");
382 if ($_ =~ /^\s*subnet\s+([\d\.]+)\s+netmask\s+([\d\.]+)\s+{\s*/) {
383 $self->{_config
}->{$key} = $config if $config;
386 $config->{netmask
} = $2;
387 $self->$logger("Key: $key Netmask: $config->{netmask}");
389 next if (($_ =~ /^\s*}\s*/ && ! $subopt) || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
390 if (! $subopt && $_ =~ /^\s*(range|ttl|rttl|router|dns-servers|ntp-servers|broadcast|domain-name)\s+(.+)\s*;/) {
392 $self->$logger("Key: $1 Value: $2");
393 } elsif ($subopt &&$_ =~ /^\s*}\s*/) {
395 } elsif ($subopt || $_ =~ /^\s*{\s*/) {
397 if ($_ =~ /^\s*(allow|static)\s+(.+)\s*;/) {
398 my @vals = split(/\s*,\s*/, $2);
399 $config->{$1} = [@vals];
400 $self->$logger("Key: $1 Value: $2");
402 $key = 'UNDEF' unless $key;
403 my $err = "$key: 'suboptions' Bad format";
404 $self->$logger($err, ERROR
);
413 $key = 'UNDEF' unless $key;
414 my $err = "$key: Bad format";
415 $self->$logger($err, ERROR
);
423 $self->{_config
}->{$key} = $config;
425 $self->$logger("Config data structure: \n" . Dumper
($self->{_config
}));
426 $self->$unlock($self->{conf_file
});
427 if (!$self->{_config
}) {
428 die "Empty config file";
431 die "Could not read config file";
435 my $cleanup_leases = sub {
436 my ($self, $last_run) = @_;
437 my ($current, $last, $lease, $dirty);
439 $self->{INTERVAL
} = 5 if $self->{INTERVAL
} <= 0;
441 $last = $last_run + ($self->{INTERVAL
} * 60);
443 $self->$logger("Run 'cleanup_leases' $last < $current", INFO
);
445 if ($last < $current) {
446 $last_run = $current;
447 my $leases = $self->{_leases
};
449 while ((my $lease, my $elems) = each (%$leases)) {
450 $self->$logger("Clean up lease: $lease\n". Dumper
($elems));
451 if ($elems->{ends
} < $last_run) {
452 $self->$logger("Considering $lease for clean up: $elems->{ends} < $last_run\n". Dumper
($elems));
453 if ($elems->{'binding state'} eq 'active') {
454 $self->$logger("Setting $lease 'binding state' to free", INFO
);
455 $elems->{'binding state'} = 'free';
461 my $res = $self->$write_lease_file();
463 $self->$logger("Updated lease file", INFO
);
471 #########################################################################
472 # Private methods which handle DHCP4 requests
473 #########################################################################
475 my $get_mac_ip4 = sub {
476 my ($self, $req) = @_;
479 $mac = $req->chaddr();
485 my $can_client_use_net_ip4 = sub {
486 my ($self, $req, $network) = @_;
489 # Is client allowed to request IP?
491 if ($self->{_config
}->{$network}->{allow
}) {
492 $self->$logger("Allow: " . Dumper
($self->{_config
}->{$network}->{allow
}));
493 foreach (@
{$self->{_config
}->{$network}->{allow
}}) {
494 if ($_ eq $self->$get_mac_ip4($req)) {
506 my $add_options_ip4 = sub {
507 my ($self, $resp) = @_;
509 if ($self->{lease_time
}) {
510 $resp->addOptionValue(DHO_DHCP_LEASE_TIME
, $self->{lease_time
});
512 if ($self->{lease_time_renew
}) {
513 $resp->addOptionValue(DHO_DHCP_RENEWAL_TIME
, $self->{lease_time_renew
});
515 if ($self->{subnet_mask
}) {
516 $resp->addOptionValue(DHO_SUBNET_MASK
, $self->{subnet_mask
});
518 if ($self->{routers
}) {
519 $resp->addOptionValue(DHO_ROUTERS
, $self->{routers
});
521 if ($self->{broadcast_addr
}) {
522 $resp->addOptionValue(DHO_BROADCAST_ADDRESS
, $self->{broadcast_addr
});
524 if ($self->{domain_name
}) {
525 $resp->addOptionValue(DHO_DOMAIN_NAME
, $self->{domain_name
});
527 if ($self->{ntp_servers
}) {
528 $resp->addOptionValue(DHO_NTP_SERVERS
, $self->{ntp_servers
});
530 if ($self->{dns_servers
}) {
531 $resp->addOptionValue(DHO_DOMAIN_NAME_SERVERS
, $self->{dns_servers
});
536 my ($self, $req, $message) = @_;
538 $message = 'Bad request' unless $message;
539 my $peeraddr = ($req->ciaddr() && $req->ciaddr() ne inet_ntoa
(INADDR_ANY
)) ?
540 $req->ciaddr() : inet_ntoa
(INADDR_BROADCAST
);
542 my $sock = IO
::Socket
::IP
->new(
545 PeerAddr
=> $peeraddr,
549 $self->$logger("[discover_ip4] Socket creation error: $err", ERROR
);
550 die "[discover_ip4] Socket creation error: $err\n";
553 my $resp = new Net
::DHCP
::Packet
(
554 Comment
=> $req->comment(),
556 Hops
=> $req->hops(),
558 Flags
=> $req->flags(),
559 Ciaddr
=> $req->ciaddr(),
561 Siaddr
=> $req->siaddr(),
562 Giaddr
=> $req->giaddr(),
563 Chaddr
=> $req->chaddr(),
564 DHO_DHCP_MESSAGE_TYPE
() => DHCPNAK
(),
565 DHO_DHCP_MESSAGE
(), $message,
568 $self->$logger("Sending NAK to " . $sock->peerhost . ':' . $sock->peerport .
569 "\nReason: $message", INFO
);
570 $self->$logger($resp->toString());
572 my $xid = $req->xid() ?
$req->xid() : 'Missing';
573 $self->$logger("Sending OFFER tr=$xid", INFO
);
575 $sock->send($resp->serialize()) || die "Error sending OFFER: $!\n";
579 my $send_accept = sub {
580 my ($self, $req, $calc_ip, $reply) = @_;
583 my $peeraddr = ($req->ciaddr() && $req->ciaddr() ne inet_ntoa
(INADDR_ANY
)) ?
584 $req->ciaddr() : inet_ntoa
(INADDR_BROADCAST
);
586 if ($reply == DHCP_OFFER
) {
587 $reply = DHCPOFFER
();
589 } elsif ($reply == DHCP_ACK
) {
593 my $err = "$reply: Unknown reply";
594 $self->$logger($err, ERROR
);
598 my $sock = IO
::Socket
::IP
->new(
601 PeerAddr
=> $peeraddr,
605 $self->$logger("[discover_ip4] Socket creation error: $err", ERROR
);
606 die "[discover_ip4] Socket creation error: $err\n";
609 my $resp = new Net
::DHCP
::Packet
(
610 Comment
=> $req->comment(),
612 Hops
=> $req->hops(),
614 Flags
=> $req->flags(),
615 Ciaddr
=> $req->ciaddr(),
617 Siaddr
=> $req->siaddr(),
618 Giaddr
=> $req->giaddr(),
619 Chaddr
=> $req->chaddr(),
620 DHO_DHCP_MESSAGE_TYPE
() => $reply,
621 DHO_DHCP_SERVER_IDENTIFIER
() => $sock->sockhost
623 $self->$add_options_ip4($resp);
624 my $xid = $req->xid();
625 $self->{_transaction
}->{$xid}->{me
} = $sock->sockhost;
627 $self->$logger("Sending $msg to " . $sock->peerhost . ':' . $sock->peerport, INFO
);
628 $self->$logger($resp->toString());
630 $self->$logger("Sending OFFER tr=".$req->xid(), INFO
);
632 $sock->send($resp->serialize()) || die "Error sending $msg: $!\n";
636 my $update_transaction = sub {
637 my ($self, $req, $tx) = @_;
638 my ($res, $xid, $offer);
641 return -1 unless $xid;
644 $self->{_transaction
}->{$xid} = $tx;
647 if ($self->{_transaction
}->{$xid} && $self->{_transaction
}->{$xid}->{me
}) {
648 my $me = $req->getOptionValue(DHO_DHCP_SERVER_IDENTIFIER
());
649 $me = $req->ciaddr() unless $me;
650 $offer = $self->{_transaction
}->{$xid}->{offer_ip
};
652 if ($me ne $self->{_transaction
}->{$xid}->{me
}) {
653 # Another DHCP server is chosen by client
654 $self->$logger("$me: Offer '".($offer?
$offer : 'None')."' refused by client xid=$xid", INFO
);
655 delete($self->{_transaction
}->{$xid});
656 delete($self->{_leases
}->{$offer}) if $offer;
657 $self->$write_lease_file();
660 $self->$logger("Offer '$offer' accepted by client xid=$xid", INFO
);
664 # Caught request for other DHCP server
667 if ($self->{_transaction
}->{$xid}) {
668 $offer = $self->{_transaction
}->{$xid}->{offer_ip
};
669 $self->$logger("Offer '$offer' wait approval from client xid=$xid", INFO
);
678 my $create_new_lease_ip4 = sub {
679 my ($self, $req, $network) = @_;
682 $lease->{'hardware ethernet'} = $self->$get_mac_ip4($req);
683 my $client = $req->getOptionValue(DHO_HOST_NAME
());
684 $lease->{'client-hostname'} = $client ?
$client : $self->$get_mac_ip4($req);
685 $lease->{'binding state'} = 'active';
687 my $end = $start + $self->{_config
}->{$network}->{ttl
};
688 $lease->{starts
} = $self->$convert_timestamp($start, 0);
689 $lease->{ends
} = $self->$convert_timestamp($end, 0);
694 my $add_lease_ip4 = sub {
695 my ($self, $req, $network, $ip) = @_;
697 my $lease = $self->$create_new_lease_ip4($req, $network);
698 $self->$add_lease($ip, $lease);
699 $self->{lease_time
} = $DEFAULT_LEASE;
700 if ($self->{_config
}->{$network}->{ttl
}) {
701 $self->{lease_time
} = $self->{_config
}->{$network}->{ttl
};
703 $self->{lease_time_renew
} = $DEFAULT_LEASE_RENEW;
704 if ($self->{_config
}->{$network}->{rttl
}) {
705 $self->{lease_time_renew
} = $self->{_config
}->{$network}->{rttl
};
707 if ($self->{_config
}->{$network}->{netmask
}) {
708 $self->{subnet_mask
} = $self->{_config
}->{$network}->{netmask
};
710 if ($self->{_config
}->{$network}->{router
}) {
711 $self->{routers
} = $self->{_config
}->{$network}->{router
};
713 if ($self->{_config
}->{$network}->{broadcast
}) {
714 $self->{broadcast_addr
} = $self->{_config
}->{$network}->{broadcast
};
716 if ($self->{_config
}->{$network}->{'domain-name'}) {
717 $self->{domain_name
} = $self->{_config
}->{$network}->{'domain-name'};
719 if ($self->{_config
}->{$network}->{'dns-servers'}) {
720 $self->{dns_servers
} = $self->{_config
}->{$network}->{'dns-servers'};
722 if ($self->{_config
}->{$network}->{'ntp-servers'}) {
723 $self->{ntp_servers
} = $self->{_config
}->{$network}->{'ntp-servers'};
727 my $find_ip_ip4 = sub {
728 my ($self, $req, $network, $reqaddr) = @_;
729 my ($start, $end, $ip);
731 my @range_str = split(/\s+/, $self->{_config
}->{$network}->{range
});
732 $self->$logger("Range: " . $range_str[0] . " - " . $range_str[1], INFO
);
733 $start = NetAddr
::IP
->new($range_str[0].'/'.$self->{_config
}->{$network}->{netmask
});
734 $end = NetAddr
::IP
->new($range_str[1].'/'.$self->{_config
}->{$network}->{netmask
});
735 $self->$logger(Dumper
($start) . Dumper
($end));
738 my $request = NetAddr
::IP
->new($reqaddr);
739 if ($start->numeric() <= $request->numeric() && $request->numeric() <= $start->numeric()) {
740 my $cip = $request->addr();
741 $self->$logger("[find_ip_ip4] reqaddr: $reqaddr IP: $cip", INFO
);
742 if ($self->{_leases
}->{$cip}) {
743 my $lease = $self->{_leases
}->{$cip};
744 my $mac = $self->$get_mac_ip4($req);
745 if ($lease->{'hardware ethernet'} eq $mac) {
754 for (; $start <= $end; $start = $start + 1) {
755 my $cip = $start->addr();
756 $self->$logger("[find_ip_ip4] IP: $cip");
757 if ($self->{_leases
}->{$cip} && ! $free) {
758 my $lease = $self->{_leases
}->{$cip};
759 my $mac = $self->$get_mac_ip4($req);
760 if ($lease->{'hardware ethernet'} eq $mac) {
762 } elsif ($lease->{'binding state'} eq 'free') {
770 if (! $ip && $free) {
775 $self->$logger("[find_ip_ip4] IP: " . ($ip ?
$ip : 'None'), INFO
);
780 my $calculate_net_ip4 = sub {
781 my ($self, $req, $req_addr) = @_;
782 my ($network, $net, $ip);
784 $self->$logger("Req IP: " . ($req_addr ?
$req_addr : 'None'), INFO
);
785 foreach $net (keys %{$self->{_config
}}) {
786 my $opt = $self->{_config
}->{$net};
787 $self->$logger("Network: $net/$opt->{netmask}\n" . Dumper
($opt), INFO
);
788 $network = $net if ($self->$can_client_use_net_ip4($req, $net));
791 $ip = $self->$find_ip_ip4($req, $network, $req_addr);
793 $ip = $self->$find_ip_ip4($req, $network);
799 $self->$logger("Network: " . ($network ?
$network : 'None') . " IP: " . ($ip ?
$ip : 'None'), INFO
);
801 return ($network, $ip);
804 my $calculate_ip_ip4 = sub {
805 my ($self, $req, $state, $reqaddr) = @_;
808 if ($state == DHCP_OFFER
) {
810 ($network, $ip) = $self->$calculate_net_ip4($req, $reqaddr);
812 ($network, $ip) = $self->$calculate_net_ip4($req);
814 } elsif ($state == DHCP_ACK
) {
815 # If no $reqaddr then client fail
817 my $xid = $req->xid();
818 if ($self->{_transaction
}->{$xid}) {
819 my $offer = $self->{_transaction
}->{$xid}->{offer_ip
};
820 if ($offer eq $reqaddr) {
821 $network = $self->{_transaction
}->{$xid}->{network
};
822 $ip = $self->{_transaction
}->{$xid}->{offer_ip
}
824 delete($self->{_transaction
}->{$xid});
826 # No prior discovery. We maintain transaction
827 ($network, $ip) = $self->$calculate_net_ip4($req, $reqaddr);
833 return ($network, $ip);
836 my $discover_ip4 = sub {
837 my ($self, $req) = @_;
838 my ($tx, $res, $resp, $network, $calc_ip, $req_addr);
840 $self->$logger("Got ip4 discover request: \n" . $req->toString(), INFO
);
842 $res = $self->$update_transaction($req);
844 my $err = "Missing transaction ID";
845 $self->$send_nak($req, $err);
846 $self->$logger($err, ERROR
);
850 $req_addr = $req->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS
());
851 $res = $self->$read_lease_file();
852 $self->$logger("Starting with empty lease file", INFO
) unless $res;
855 if ($self->{LOG_LEVEL
} <= INFO
) {
857 $self->$logger("[D] Requested IP: $req_addr", INFO
);
859 $self->$logger("[D] Requested IP: None", INFO
);
863 $tx->{req_ip
} = $req_addr ?
$req_addr : 'None';
865 ($network, $calc_ip) = $self->$calculate_ip_ip4($req, DHCP_OFFER
, $req_addr);
866 $tx->{offer_ip
} = $calc_ip ?
$calc_ip : 'None';
867 $tx->{network
} = $network ?
$network : 'None';
869 $self->$logger("Offer: $tx->{offer_ip}");
871 if ($network && $calc_ip) {
872 $self->$logger("Creating lease for $calc_ip", INFO
);
873 $res = $self->$update_transaction($req, $tx);
875 my $err = "Could not create transaction";
876 $self->$logger($err, ERROR
);
877 $self->$send_nak($req, $err);
879 $self->$add_lease_ip4($req, $network, $calc_ip);
880 $res = $self->$write_lease_file();
882 my $err = "Could not write lease file. Bailing";
883 $self->$logger($err, ERROR
);
884 my $xid = $req->xid();
885 delete($self->{_transaction
}->{$xid});
886 $self->$send_nak($req, $err);
888 $self->$send_accept($req, $calc_ip, DHCP_OFFER
);
892 # bad request, we send a NAK
893 my $err = "$req_addr: Not available";
894 $self->$logger($err, INFO
);
895 $self->$send_nak($req, $err);
898 $self->$logger("Transaction:\n".Dumper
($self->{_transaction
}), INFO
);
901 my $request_ip4 = sub {
902 my ($self, $req) = @_;
903 my ($calc_ip, $network, $res);
905 $self->$logger("Got request\n".$req->toString());
907 $res = $self->$update_transaction($req);
910 my $err = "Missing transaction ID";
911 $self->$send_nak($req, $err);
912 $self->$logger($err, ERROR
);
919 my $req_addr = $req->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS
());
920 if ($self->{LOG_LEVEL
} <= INFO
) {
922 $self->$logger("[R] Requested IP: $req_addr", INFO
);
924 $self->$logger("[R] Requested IP: None", INFO
);
928 ($network, $calc_ip) = $self->$calculate_ip_ip4($req, DHCP_ACK
, $req_addr);
929 if ($network && $calc_ip) {
930 $self->$logger("Creating lease for $calc_ip", INFO
);
931 $self->$add_lease_ip4($req, $network, $calc_ip);
932 $res = $self->$write_lease_file();
934 my $err = "Could not write lease file. Bailing";
935 $self->$logger($err, ERROR
);
936 $self->$send_nak($req, $err);
938 $self->$send_accept($req, $calc_ip, DHCP_ACK
);
941 # bad request, we send a NAK
942 $self->$send_nak($req);
945 # This transaction is finished with either NAK or ACK
946 my $xid = $req->xid();
947 delete($self->{_transaction
}->{$xid});
949 $self->$logger("Transaction:\n".Dumper
($self->{_transaction
}), INFO
);
952 my $release_ip4 = sub {
953 my ($self, $req) = @_;
956 $self->$logger($req->toString());
957 $ip = $req->ciaddr();
958 $mac = $self->$get_mac_ip4($req);
959 $self->$logger("Release request for IP: $ip MAC: $mac", INFO
);
961 if ($self->{_leases
}->{$ip}) {
962 my $lease = $self->{_leases
}->{$ip};
963 if ($lease->{'hardware ethernet'} eq $mac) {
964 $self->$logger("Set binding state free IP: $ip MAC: $mac", INFO
);
965 $lease->{'binding state'} = 'free';
966 $self->$write_lease_file();
969 $self->$logger("Transaction:\n".Dumper
($self->{_transaction
}), INFO
);
972 #########################################################################
973 # Private methods which handle DHCP6 requests
974 #########################################################################
976 my $excuse_me_ip6 = sub {
977 my ($self, $addr, $req) = @_;
979 $self->$logger("IPv6 request from [$addr]: $req", INFO
);
980 my $sock = IO
::Socket
::IP
->new(
989 $self->$logger("[excuse_me_ip6] Socket creation error: $err", ERROR
);
990 die "[excuse_me_ip6] Socket creation error: $err\n";
992 $self->$logger("$addr: Not implemented here", INFO
);
993 $sock->send("Not implemented here") || die "Error sending excuse: $!\n";
997 #########################################################################
999 #########################################################################
1001 # generic signal handler to cause daemon to stop
1002 sub signal_handler
{
1005 $SIG{INT
} = $SIG{TERM
} = $SIG{HUP
} = \
&signal_handler
;
1007 # ignore any PIPE signal: standard behaviour is to quit process
1008 $SIG{PIPE
} = 'IGNORE';
1011 my ($class, %self) = @_;
1014 $class = ref($class) || $class;
1016 bless $self, $class;
1019 $self->{_sock_in_ip4
} = undef;
1020 $self->{_sock_in_ip6
} = undef;
1021 $self->{_leases
} = undef;
1022 $self->{_reverse
} = undef;
1023 $self->{_config
} = undef;
1024 $self->{_dhpcp_ip4
} = undef;
1025 $self->{_transaction
} = ();
1028 $self->{log_file
} ||= 'syslog';
1029 $self->{lease_time
} ||= $DEFAULT_LEASE;
1030 $self->{lease_time_renew
} ||= $DEFAULT_LEASE_RENEW;
1031 $self->{subnet_mask
} ||= undef;
1032 $self->{routers
} ||= undef;
1033 $self->{broadcast_addr
} ||= undef;
1034 $self->{domain_name
} ||= undef;
1035 $self->{dns_servers
} ||= undef;
1036 $self->{ntp_servers
} ||= undef;
1037 $self->{LOG_LEVEL
} = ERROR
unless defined $self->{LOG_LEVEL
};
1038 $self->{NODAEMON
} ||= 0;
1039 $self->{DEBUG
} ||= 0;
1040 $self->{timeout
} ||= 10;
1041 $self->{lease_file
} ||= '/tmp/dhcpd.leases';
1042 $self->{conf_file
} ||= '/tmp/dhcpd.cfg';
1043 $self->{INTERVAL
} ||= 5;
1050 my ($sel, @ready, $socket, $res);
1053 $self->$read_config();
1057 $self->$logger($err, ERROR
);
1060 $self->$logger("Starting dhcpd", INFO
);
1061 if ($self->{NODAEMON
} < 1) {
1062 $self->$logger("Entering Daemon mode");
1063 chdir '/' or die "Can't chdir to /: $!";
1066 open STDIN
, '/dev/null' or die "Can't read /dev/null: $!";
1067 open STDOUT
, '>/dev/null' or die "Can't write to /dev/null: $!";
1068 open STDERR
, '>/dev/null' or die "Can't write to /dev/null: $!";
1074 $self->$logger("Couldn't fork: $err", ERROR
);
1075 die "Couldn't fork: $err";
1076 } unless defined($pid);
1078 POSIX
::setsid
() || do {
1080 $self->$logger("Can't start a new session: $err", ERROR
);
1081 die "Can't start a new session: $err";
1083 $self->$logger("Now in Daemon mode", INFO
);
1086 $res = $self->$read_lease_file();
1087 $self->$logger("Starting with empty leases file '$self->{lease_file}'", INFO
)
1088 if (! $res || ! $self->{_leases
});
1090 $self->$logger("Initialization complete", INFO
);
1092 # open listening socket
1093 $self->{_sock_in_ip4
} = IO
::Socket
::IP
->new(
1096 LocalAddr
=> inet_ntoa
(INADDR_ANY
),
1100 $self->$logger("IP4 Socket creation error: $err", ERROR
);
1101 die "IP4 Socket creation error: $err\n";
1103 $self->{_sock_in_ip6
} = IO
::Socket
::IP
->new(
1111 $self->$logger("IP6 Socket creation error: $err", ERROR
);
1112 die "IP6 Socket creation error: $err\n";
1115 $sel = IO
::Select
->new($self->{_sock_in_ip4
});
1116 $sel->add($self->{_sock_in_ip6
});
1118 my $last_run = time;
1120 until ($time_to_die) {
1125 eval { # catch fatal errors
1126 while (@ready = $sel->can_read) {
1127 $self->$logger("Waiting for incoming packet", INFO
);
1128 $last_run = $self->$cleanup_leases($last_run);
1129 foreach $socket (@ready) {
1130 if ($socket == $self->{_sock_in_ip4
}) {
1131 # receive ipv4 packet
1132 $fromaddr = $socket->recv($buf, 4096)
1133 || $self->$logger("recv: $!", ERROR
);
1134 next if ($!); # continue loop if an error occured
1136 $req = new Net
::DHCP
::Packet
($buf);
1140 my $xid = $req->xid();
1141 $xid = $xid ?
$xid : 'None';
1142 my ($port,$addr) = unpack_sockaddr_in
($fromaddr);
1143 my $ipaddr = inet_ntoa
($addr);
1144 $self->$logger("Got a packet tr=$xid src=$ipaddr:$port length=".length($buf), INFO
);
1147 my $messagetype = $req->getOptionValue(DHO_DHCP_MESSAGE_TYPE
());
1149 if ($messagetype eq DHCPDISCOVER
()) {
1150 $self->$discover_ip4($req);
1151 } elsif ($messagetype eq DHCPREQUEST
()) {
1152 $self->$request_ip4($req);
1153 } elsif ($messagetype eq DHCPINFORM
()) {
1154 $self->$logger("Not implemented: DHCPINFORM", WARNING
);
1155 } elsif ($messagetype eq DHCPRELEASE
()) {
1156 $self->$release_ip4($req);
1158 $self->$logger("$messagetype: Packet dropped since unknown message type", WARNING
);
1159 # bad messagetype, we drop it
1162 # Receive ipv6 packet
1163 my $myaddr = $socket->sockhost;
1165 $fromaddr = $socket->recv($buf, 4096)
1166 || $self->$logger("recv: $!", ERROR
);
1167 next if ($!); # continue loop if an error occured
1168 $self->$logger("recv: $buf", INFO
);
1171 my ($port,$addr) = unpack_sockaddr_in6
($fromaddr);
1172 my $ipaddr = inet_ntop
(AF_INET6
, $addr);
1173 $self->$logger("Got a packet tr=$self->{_transaction_ip6} src=$ipaddr:$port length=".length($buf), INFO
);
1175 $self->$excuse_me_ip6($myaddr, $buf);
1179 }; # end of 'eval' blocks
1181 $self->$logger("Caught error in main loop: $@", ERROR
);
1184 $self->{_sock_in_ip4
}->close;
1185 $self->{_sock_in_ip6
}->close;
1186 $self->$logger("Exiting dhcpd", INFO
);