DHCPServer.pm

   1 package PVE::DHCPServer;
   2
   3 use strict;
   4 use warnings;
   5 use Carp qw(croak);
   6 use Sys::Hostname;
   7 use Socket;
   8 use Socket6;
   9 use NetAddr::IP;
  10 use IO::Socket::IP;
  11 use IO::File;
  12 use IO::Select;
  13 use Sys::Syslog;
  14 use Fcntl qw(:DEFAULT :flock SEEK_END);
  15 use POSIX qw(EINTR setsid strftime);
  16 use Data::Dumper;
  17 use Time::Local;
  18
  19 use Net::DHCP::Packet;
  20 use Net::DHCP::Constants;
  21
  22 use constant {
  23         DEBUG           => 0,
  24         INFO            => 1,
  25         NOTICE          => 2,
  26         WARNING         => 3,
  27         ERROR           => 4,
  28         CRITICAL        => 5,
  29         ALERT           => 6,
  30         EMERGENCY       => 7,
  31         DHCP_OFFER      => 100,
  32         DHCP_ACK        => 101,
  33 };
  34
  35 use Exporter;
  36 our @ISA = qw(Exporter);
  37 our @EXPORT = qw(
  38         run
  39         DEBUG
  40         INFO
  41         NOTICE
  42         WARNING
  43         ERROR
  44         CRITICAL
  45         ALERT
  46         EMERGENCY
  47 );
  48
  49 our $VERSION = '0.01';
  50 our $NAME = 'PVE::DHCPServer';
  51 our $DEFAULT_LEASE = 7200;
  52 our $DEFAULT_LEASE_RENEW = 5400;
  53 my $time_to_die = 0;
  54
  55 #########################################################################
  56 # Private methods
  57 #########################################################################
  58
  59 my $logger = sub {
  60         my ($self, $message, $level) = @_;
  61
  62         $level ||= DEBUG;
  63         return unless ($level >= $self->{LOG_LEVEL});
  64
  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;
  73
  74         if ($self->{DEBUG}) {
  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);
  80                 closelog();
  81         } else {
  82                 my $fh = new IO::File;
  83                 if (! $fh->open("> $self->{log_file}")) {
  84                         croak "$self->{log_file}: $!";
  85                 }
  86                 print $fh strftime "[%d/%b/%Y:%H:%M:%S] ", localtime;
  87                 print $fh "$level: $message\n";
  88                 undef $fh;
  89         }
  90 };
  91
  92 my $run_with_timeout = sub {
  93     my ($self, $code, @param) = @_;
  94
  95     die "got timeout" if $self->{timeout} <= 0;
  96
  97     my $prev_alarm;
  98
  99     my $sigcount = 0;
 100
 101     my $res;
 102
 103     local $SIG{ALRM} = sub { $sigcount++; }; # catch alarm outside eval
 104
 105     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
 109
 110                 $prev_alarm = alarm($self->{timeout});
 111
 112                 $res = &$code(@param);
 113
 114                 alarm(0); # avoid race conditions
 115     };
 116
 117     my $err = $@;
 118
 119     alarm($prev_alarm) if defined($prev_alarm);
 120
 121     die "unknown error" if $sigcount && !$err; # seems to happen sometimes
 122
 123     die $err if $err;
 124
 125     return $res;
 126 };
 127
 128 my $lock = sub {
 129         my ($self, $file, $shared) = @_;
 130
 131         my $mode = $shared ? LOCK_SH : LOCK_EX;
 132
 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 - $!";
 137                 } else {
 138                         $self->{file_handle} = new IO::File (">$file") ||
 139                 die "can't open file '$file' for write - $!";
 140                 }
 141         $self->$logger("trying to aquire lock on '$file'...");
 142         if (!flock ($self->{file_handle}, $mode|LOCK_NB)) {
 143                         my $success;
 144                         while(1) {
 145                                 $success = flock($self->{file_handle}, $mode);
 146                                 # try again on EINTR (see bug #273)
 147                                 if ($success || ($! != EINTR)) {
 148                                         last;
 149                                 }
 150                         }
 151                         if ($mode == LOCK_SH) {
 152                                 seek($self->{file_handle}, 0, SEEK_END) or $success = 0;
 153                         }
 154                         if (!$success) {
 155                                 $self->$logger(" failed");
 156                                 die "can't aquire lock - $!";
 157                         }
 158         }
 159                 $self->$logger(" OK");
 160     };
 161
 162     my $res;
 163     my $err = undef;
 164
 165     eval {
 166                 $res = $self->$run_with_timeout($lock_func);
 167         };
 168     if ($@) {
 169                 $self->$logger("can't lock file '$file' - $@", ERROR);
 170                 $self->{file_handle} = undef;
 171                 return undef;
 172     }
 173
 174     return $res;
 175 };
 176
 177 my $unlock = sub {
 178         my ($self, $file) = @_;
 179
 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)) {
 184
 185                         my $success;
 186                         while(1) {
 187                                 $success = flock($self->{file_handle}, LOCK_UN);
 188                                 # try again on EINTR (see bug #273)
 189                                 if ($success || ($! != EINTR)) {
 190                                         last;
 191                                 }
 192                         }
 193                         if (!$success) {
 194                                 $self->$logger(" failed");
 195                                 die "can't unlock - $!";
 196                         }
 197         }
 198                 $self->$logger(" OK");
 199     };
 200
 201     my $res;
 202     my $err = undef;
 203
 204     eval {
 205                 $res = $self->$run_with_timeout($unlock_func);
 206         };
 207     if ($@) {
 208                 $self->$logger("can't lock file '$file' - $@", ERROR);
 209                 $self->{file_handle} = undef;
 210                 $res = undef;
 211     }
 212
 213     return $res;
 214 };
 215
 216 my $convert_timestamp = sub {
 217         my ($self, $timestamp, $strtotime) = @_;
 218         my ($res, $mday, $mon, $year, $hour, $min, $sec);
 219
 220         $self->$logger("Timestamp: $timestamp");
 221         if ($strtotime) {
 222                 if ($timestamp !~ /^\d{4}\/\d{2}\/\d{2}\s+\d{2}:\d{2}:\d{2}$/) {
 223                         $self->$logger("$timestamp: (strtotime) Bad format", ERROR);
 224                         $res = undef;
 225                 } else {
 226                         ($year,$mon,$mday,$hour,$min,$sec) = split(/[\s\/:]+/, $timestamp);
 227                         $res = timelocal($sec,$min,$hour,$mday,$mon-1,$year);
 228                 }
 229         } else{
 230                 $self->$logger($timestamp);
 231                 if ($timestamp !~ /^\d+$/) {
 232                         $self->$logger("$timestamp: (timetostr) Bad format", ERROR);
 233                         $res = undef;
 234                 } else {
 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");
 239                 }
 240         }
 241
 242         return $res;
 243 };
 244
 245
 246 my $add_lease = sub {
 247         my ($self, $ip, $lease) = @_;
 248         my $ts;
 249
 250         my $mac = $lease->{'hardware ethernet'};
 251         $mac =~ tr/://d;
 252         $lease->{'hardware ethernet'} = $mac;
 253         $ts = $self->$convert_timestamp($lease->{starts}, 1);
 254         return unless $ts;
 255         $lease->{starts} = $ts;
 256         $ts = $self->$convert_timestamp($lease->{ends}, 1);
 257         return unless $ts;
 258         $lease->{ends} = $ts;
 259
 260         $self->{_leases}->{$ip} = $lease;
 261         $self->$logger(Dumper($self->{_leases}->{$ip}));
 262         $self->{_reverse}->{$mac} = $ip;
 263         $self->$logger("$mac => $self->{_reverse}->{$mac}");
 264 };
 265
 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"
 272 #}
 273 my $read_lease_file = sub {
 274         my ($self) = @_;
 275         my ($res, $key, $lease);
 276         my $error = 0;
 277
 278         # Start with empty leases file?
 279         if (! -e $self->{lease_file}) {
 280                 return 0;
 281         }
 282
 283         $self->$lock($self->{lease_file}, 1);
 284         if ($self->{file_handle}) {
 285                 my $fh = $self->{file_handle};
 286                 my @lines = <$fh>;
 287                 foreach (@lines) {
 288                         $self->$logger("Read: $_");
 289                         if ($_ =~ /^\s*lease\s+([\d\.]+)\s+{\s*/) {
 290                                 $self->$add_lease($key, $lease) if $lease;
 291                                 $key = $1;
 292                                 $lease = undef;
 293                                 $error = 0;
 294                                 $self->$logger("Key: $key");
 295                         } else {
 296                                 next if $error;
 297                                 next if ($_ =~ /^\s*}\s*/ || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
 298                                 if ($_ =~ /^\s*(starts|ends|binding state|hardware ethernet|client-hostname)\s+(.+)\s*;/) {
 299                                         $lease->{$1} = $2;
 300                                         $self->$logger("Key: $1 Value: $2");
 301                                 } else {
 302                                         $key = 'UNDEF' unless $key;
 303                                         $self->$logger("$key: Bad format", ERROR);
 304                                         $key = undef;
 305                                         $lease = undef;
 306                                         $error = 1;
 307                                 }
 308                         }
 309                 }
 310                 if ($lease && !$error) {
 311                         $self->$logger("Key: $key");
 312                         $self->$add_lease($key, $lease);
 313                 }
 314                 $self->$logger("Leases data structure: \n" . Dumper($self->{_leases}));
 315                 $self->$unlock($self->{lease_file});
 316                 $res = 1;
 317         } else {
 318                 $self->$logger("Could not read leases file", INFO);
 319                 $res = 0;
 320         }
 321
 322         return $res;
 323 };
 324
 325 my $write_lease_file = sub {
 326         my ($self) = @_;
 327         my $res;
 328
 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);
 340                                         }
 341                                         $self->$logger("Writing: $key $val");
 342                                         print $fh "\t$key $val;\n";
 343                                 }
 344                                 print $fh "}\n";
 345                         }
 346                 }
 347                 $self->$unlock($self->{lease_file});
 348                 $res = 1;
 349         } else {
 350                 $self->$logger("$self->{lease_file}: Could not write leases file", ERROR);
 351                 $res = 0;
 352         }
 353
 354         return $res;
 355 };
 356
 357 #subnet 192.168.9.0 netmask 255.255.255.0 {
 358 #       range 192.168.9.2 192.168.9.100;
 359 #       ttl 7200;
 360 #       rttl 3600;
 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";
 366 #       {
 367 #               allow 001cc0c33317,001cc0c33318,001cc0c33319,001cc0c33320;
 368 #               static 001cc0c33317 192.168.9.100,001cc0c33318 192.168.9.200;
 369 #       }
 370 #}
 371 my $read_config = sub {
 372         my ($self) = @_;
 373         my ($res, $key, $netmask, $config, $subopt);
 374
 375         $self->$lock($self->{conf_file}, 1);
 376         if ($self->{file_handle}) {
 377                 my $fh = $self->{file_handle};
 378                 my @lines = <$fh>;
 379                 $subopt = 0;
 380                 foreach (@lines) {
 381                         $self->$logger("Read: $_");
 382                         if ($_ =~ /^\s*subnet\s+([\d\.]+)\s+netmask\s+([\d\.]+)\s+{\s*/) {
 383                                 $self->{_config}->{$key} = $config if $config;
 384                                 $key = $1;
 385                                 $config = undef;
 386                                 $config->{netmask} = $2;
 387                                 $self->$logger("Key: $key Netmask: $config->{netmask}");
 388                         } else {
 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*;/) {
 391                                         $config->{$1} = $2;
 392                                         $self->$logger("Key: $1 Value: $2");
 393                                 } elsif ($subopt &&$_ =~ /^\s*}\s*/) {
 394                                         $subopt = 0;
 395                                 } elsif ($subopt || $_ =~ /^\s*{\s*/) {
 396                                         if ($subopt) {
 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");
 401                                                 } else {
 402                                                         $key = 'UNDEF' unless $key;
 403                                                         my $err = "$key: 'suboptions' Bad format";
 404                                                         $self->$logger($err, ERROR);
 405                                                         $key = undef;
 406                                                         $config = undef;
 407                                                         die $err;
 408                                                 }
 409                                         } else {
 410                                                 $subopt = 1;
 411                                         }
 412                                 } else {
 413                                         $key = 'UNDEF' unless $key;
 414                                         my $err = "$key: Bad format";
 415                                         $self->$logger($err, ERROR);
 416                                         $key = undef;
 417                                         $config = undef;
 418                                         die $err;
 419                                 }
 420                         }
 421                 }
 422                 if ($config) {
 423                         $self->{_config}->{$key} = $config;
 424                 }
 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";
 429                 }
 430         } else {
 431                 die "Could not read config file";
 432         }
 433 };
 434
 435 my $cleanup_leases = sub {
 436         my ($self, $last_run) = @_;
 437         my ($current, $last, $lease, $dirty);
 438
 439     $self->{INTERVAL} = 5 if $self->{INTERVAL} <= 0;
 440     $current = time;
 441     $last = $last_run + ($self->{INTERVAL} * 60);
 442
 443         $self->$logger("Run 'cleanup_leases' $last < $current", INFO);
 444
 445         if ($last < $current) {
 446                 $last_run = $current;
 447                 my $leases = $self->{_leases};
 448                 $dirty = 0;
 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';
 456                                         $dirty = 1;
 457                                 }
 458                         }
 459                 }
 460                 if ($dirty) {
 461                         my $res = $self->$write_lease_file();
 462                         if ($res) {
 463                                 $self->$logger("Updated lease file", INFO);
 464                         }
 465                 }
 466         }
 467
 468         return $last_run;
 469 };
 470
 471 #########################################################################
 472 #  Private methods which handle DHCP4 requests
 473 #########################################################################
 474
 475 my $get_mac_ip4 = sub {
 476         my ($self, $req) = @_;
 477         my $mac;
 478
 479         $mac = $req->chaddr();
 480         $mac =~ s/0+$//;
 481
 482         return $mac;
 483 };
 484
 485 my $can_client_use_net_ip4 = sub {
 486         my ($self, $req, $network) = @_;
 487         my ($found);
 488
 489         # Is client allowed to request IP?
 490         $found = 0;
 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)) {
 495                                 $found = 1;
 496                                 last;
 497                         }
 498                 }
 499         } else {
 500                 $found = 1;
 501         }
 502
 503         return $found;
 504 };
 505
 506 my $add_options_ip4 = sub {
 507         my ($self, $resp) = @_;
 508
 509         if ($self->{lease_time}) {
 510                 $resp->addOptionValue(DHO_DHCP_LEASE_TIME, $self->{lease_time});
 511         }
 512         if ($self->{lease_time_renew}) {
 513                 $resp->addOptionValue(DHO_DHCP_RENEWAL_TIME, $self->{lease_time_renew});
 514         }
 515         if ($self->{subnet_mask}) {
 516                 $resp->addOptionValue(DHO_SUBNET_MASK, $self->{subnet_mask});
 517         }
 518         if ($self->{routers}) {
 519                 $resp->addOptionValue(DHO_ROUTERS, $self->{routers});
 520         }
 521         if ($self->{broadcast_addr}) {
 522                 $resp->addOptionValue(DHO_BROADCAST_ADDRESS, $self->{broadcast_addr});
 523         }
 524         if ($self->{domain_name}) {
 525                 $resp->addOptionValue(DHO_DOMAIN_NAME, $self->{domain_name});
 526         }
 527         if ($self->{ntp_servers}) {
 528                 $resp->addOptionValue(DHO_NTP_SERVERS, $self->{ntp_servers});
 529         }
 530         if ($self->{dns_servers}) {
 531                 $resp->addOptionValue(DHO_DOMAIN_NAME_SERVERS, $self->{dns_servers});
 532         }
 533 };
 534
 535 my $send_nak = sub {
 536         my ($self, $req, $message) = @_;
 537
 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);
 541
 542         my $sock = IO::Socket::IP->new(
 543                 Broadcast => 1,
 544                 PeerPort => 68,
 545                 PeerAddr => $peeraddr,
 546                 Proto    => 'udp'
 547         ) || do {
 548                 my $err = $@;
 549                 $self->$logger("[discover_ip4] Socket creation error: $err", ERROR);
 550                 die "[discover_ip4] Socket creation error: $err\n";
 551         };
 552
 553         my $resp = new Net::DHCP::Packet(
 554                 Comment => $req->comment(),
 555                 Op => BOOTREPLY(),
 556                 Hops => $req->hops(),
 557                 Xid => $req->xid(),
 558                 Flags => $req->flags(),
 559                 Ciaddr => $req->ciaddr(),
 560                 Yiaddr => "0.0.0.0",
 561                 Siaddr => $req->siaddr(),
 562                 Giaddr => $req->giaddr(),
 563                 Chaddr => $req->chaddr(),
 564                 DHO_DHCP_MESSAGE_TYPE() => DHCPNAK(),
 565                 DHO_DHCP_MESSAGE(), $message,
 566         );
 567
 568         $self->$logger("Sending NAK to " .      $sock->peerhost . ':' . $sock->peerport .
 569                 "\nReason: $message", INFO);
 570         $self->$logger($resp->toString());
 571
 572         my $xid = $req->xid() ? $req->xid() : 'Missing';
 573         $self->$logger("Sending OFFER tr=$xid", INFO);
 574
 575         $sock->send($resp->serialize()) || die "Error sending OFFER: $!\n";
 576         $sock->close;
 577 };
 578
 579 my $send_accept = sub {
 580         my ($self, $req, $calc_ip, $reply) = @_;
 581         my $msg;
 582
 583         my $peeraddr = ($req->ciaddr() && $req->ciaddr() ne inet_ntoa(INADDR_ANY)) ?
 584                 $req->ciaddr() : inet_ntoa(INADDR_BROADCAST);
 585
 586         if ($reply == DHCP_OFFER) {
 587                 $reply = DHCPOFFER();
 588                 $msg = 'DHCP_OFFER';
 589         } elsif ($reply == DHCP_ACK) {
 590                 $reply = DHCPACK();
 591                 $msg = 'DHCP_ACK';
 592         } else {
 593                 my $err = "$reply: Unknown reply";
 594                 $self->$logger($err, ERROR);
 595                 die $err;
 596         }
 597
 598         my $sock = IO::Socket::IP->new(
 599                 Broadcast => 1,
 600                 PeerPort => 68,
 601                 PeerAddr => $peeraddr,
 602                 Proto    => 'udp'
 603         ) || do {
 604                 my $err = $@;
 605                 $self->$logger("[discover_ip4] Socket creation error: $err", ERROR);
 606                 die "[discover_ip4] Socket creation error: $err\n";
 607         };
 608
 609         my $resp = new Net::DHCP::Packet(
 610                 Comment => $req->comment(),
 611                 Op => BOOTREPLY(),
 612                 Hops => $req->hops(),
 613                 Xid => $req->xid(),
 614                 Flags => $req->flags(),
 615                 Ciaddr => $req->ciaddr(),
 616                 Yiaddr => $calc_ip,
 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
 622         );
 623         $self->$add_options_ip4($resp);
 624         my $xid = $req->xid();
 625         $self->{_transaction}->{$xid}->{me} = $sock->sockhost;
 626
 627         $self->$logger("Sending $msg to " .     $sock->peerhost . ':' . $sock->peerport, INFO);
 628         $self->$logger($resp->toString());
 629
 630         $self->$logger("Sending OFFER tr=".$req->xid(), INFO);
 631
 632         $sock->send($resp->serialize()) || die "Error sending $msg: $!\n";
 633         $sock->close;
 634 };
 635
 636 my $update_transaction = sub {
 637         my ($self, $req, $tx) = @_;
 638         my ($res, $xid, $offer);
 639
 640         $xid = $req->xid();
 641         return -1 unless $xid;
 642
 643         if ($tx) {
 644                 $self->{_transaction}->{$xid} = $tx;
 645                 $res = 0;
 646         } else {
 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};
 651                         if ($me) {
 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();
 658                                         $res = 1;
 659                                 } else {
 660                                         $self->$logger("Offer '$offer' accepted by client xid=$xid", INFO);
 661                                         $res = 0;
 662                                 }
 663                         } else {
 664                                 # Caught request for other DHCP server
 665                         }
 666                 } else {
 667                         if ($self->{_transaction}->{$xid}) {
 668                                 $offer = $self->{_transaction}->{$xid}->{offer_ip};
 669                                 $self->$logger("Offer '$offer' wait approval from client xid=$xid", INFO);
 670                                 $res = 0;
 671                         }
 672                 }
 673         }
 674
 675         return $res;
 676 };
 677
 678 my $create_new_lease_ip4 = sub {
 679         my ($self, $req, $network) = @_;
 680         my $lease;
 681
 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';
 686         my $start = time;
 687         my $end = $start + $self->{_config}->{$network}->{ttl};
 688         $lease->{starts} = $self->$convert_timestamp($start, 0);
 689         $lease->{ends} = $self->$convert_timestamp($end, 0);
 690
 691         return $lease;
 692 };
 693
 694 my $add_lease_ip4 = sub {
 695         my ($self, $req, $network, $ip) = @_;
 696
 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};
 702         }
 703         $self->{lease_time_renew} = $DEFAULT_LEASE_RENEW;
 704         if ($self->{_config}->{$network}->{rttl}) {
 705                 $self->{lease_time_renew} = $self->{_config}->{$network}->{rttl};
 706         }
 707         if ($self->{_config}->{$network}->{netmask}) {
 708                 $self->{subnet_mask} = $self->{_config}->{$network}->{netmask};
 709         }
 710         if ($self->{_config}->{$network}->{router}) {
 711                 $self->{routers} = $self->{_config}->{$network}->{router};
 712         }
 713         if ($self->{_config}->{$network}->{broadcast}) {
 714                 $self->{broadcast_addr} = $self->{_config}->{$network}->{broadcast};
 715         }
 716         if ($self->{_config}->{$network}->{'domain-name'}) {
 717                 $self->{domain_name} = $self->{_config}->{$network}->{'domain-name'};
 718         }
 719         if ($self->{_config}->{$network}->{'dns-servers'}) {
 720                 $self->{dns_servers} = $self->{_config}->{$network}->{'dns-servers'};
 721         }
 722         if ($self->{_config}->{$network}->{'ntp-servers'}) {
 723                 $self->{ntp_servers} = $self->{_config}->{$network}->{'ntp-servers'};
 724         }
 725 };
 726
 727 my $find_ip_ip4 = sub {
 728         my ($self, $req, $network, $reqaddr) = @_;
 729         my ($start, $end, $ip);
 730
 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));
 736
 737         if ($reqaddr) {
 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) {
 746                                         $ip = $cip;
 747                                 }
 748                         } else {
 749                                 $ip = $cip;
 750                         }
 751                 }
 752         } else {
 753                 my $free = undef;
 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) {
 761                                         $ip = $cip;
 762                                 } elsif ($lease->{'binding state'} eq 'free') {
 763                                         $free = $cip;
 764                                 }
 765                         } else {
 766                                 $ip = $cip;
 767                         }
 768                         last if $ip;
 769                 }
 770                 if (! $ip && $free) {
 771                         $ip = $free;
 772                 }
 773         }
 774
 775         $self->$logger("[find_ip_ip4] IP: " . ($ip ? $ip : 'None'), INFO);
 776
 777         return $ip;
 778 };
 779
 780 my $calculate_net_ip4 = sub {
 781         my ($self, $req, $req_addr) = @_;
 782         my ($network, $net, $ip);
 783
 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));
 789                 if ($network) {
 790                         if ($req_addr) {
 791                                 $ip = $self->$find_ip_ip4($req, $network, $req_addr);
 792                         } else {
 793                                 $ip = $self->$find_ip_ip4($req, $network);
 794                         }
 795                         last if $ip;
 796                         $network = undef;
 797                 }
 798         }
 799         $self->$logger("Network: " . ($network ? $network : 'None') . " IP: " . ($ip ? $ip : 'None'), INFO);
 800
 801         return ($network, $ip);
 802 };
 803
 804 my $calculate_ip_ip4 = sub {
 805         my ($self, $req, $state, $reqaddr) = @_;
 806         my ($network, $ip);
 807
 808         if ($state == DHCP_OFFER) {
 809                 if ($reqaddr) {
 810                         ($network, $ip) = $self->$calculate_net_ip4($req, $reqaddr);
 811                 } else {
 812                         ($network, $ip) = $self->$calculate_net_ip4($req);
 813                 }
 814         } elsif ($state == DHCP_ACK) {
 815                 # If no $reqaddr then client fail
 816                 if ($reqaddr) {
 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}
 823                                 }
 824                                 delete($self->{_transaction}->{$xid});
 825                         } else {
 826                                 # No prior discovery. We maintain transaction
 827                                 ($network, $ip) = $self->$calculate_net_ip4($req, $reqaddr);
 828                         }
 829                 }
 830         } else {
 831         }
 832
 833         return ($network, $ip);
 834 };
 835
 836 my $discover_ip4 = sub {
 837         my ($self, $req) = @_;
 838         my ($tx, $res, $resp, $network, $calc_ip, $req_addr);
 839
 840         $self->$logger("Got ip4 discover request: \n" . $req->toString(), INFO);
 841
 842         $res = $self->$update_transaction($req);
 843         if ($res) {
 844                 my $err = "Missing transaction ID";
 845                 $self->$send_nak($req, $err);
 846                 $self->$logger($err, ERROR);
 847                 die $err;
 848         }
 849
 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;
 853
 854
 855         if ($self->{LOG_LEVEL} <= INFO) {
 856                 if ($req_addr) {
 857                         $self->$logger("[D] Requested IP: $req_addr", INFO);
 858                 } else {
 859                         $self->$logger("[D] Requested IP: None", INFO);
 860                 }
 861         }
 862
 863         $tx->{req_ip} = $req_addr ? $req_addr : 'None';
 864
 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';
 868
 869         $self->$logger("Offer: $tx->{offer_ip}");
 870
 871         if ($network && $calc_ip) {
 872                 $self->$logger("Creating lease for $calc_ip", INFO);
 873                 $res = $self->$update_transaction($req, $tx);
 874                 if ($res) {
 875                                 my $err = "Could not create transaction";
 876                                 $self->$logger($err, ERROR);
 877                                 $self->$send_nak($req, $err);
 878                 } else {
 879                         $self->$add_lease_ip4($req, $network, $calc_ip);
 880                         $res = $self->$write_lease_file();
 881                         if (! $res) {
 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);
 887                         } else {
 888                                 $self->$send_accept($req, $calc_ip, DHCP_OFFER);
 889                         }
 890                 }
 891         } else {
 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);
 896         }
 897
 898         $self->$logger("Transaction:\n".Dumper($self->{_transaction}), INFO);
 899 };
 900
 901 my $request_ip4 = sub {
 902         my ($self, $req) = @_;
 903         my ($calc_ip, $network, $res);
 904
 905         $self->$logger("Got request\n".$req->toString());
 906
 907         $res = $self->$update_transaction($req);
 908         if ($res) {
 909                 if ($res < 0) {
 910                         my $err = "Missing transaction ID";
 911                         $self->$send_nak($req, $err);
 912                         $self->$logger($err, ERROR);
 913                         die $err;
 914                 } else {
 915                         return;
 916                 }
 917         }
 918
 919         my $req_addr = $req->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
 920         if ($self->{LOG_LEVEL} <= INFO) {
 921                 if ($req_addr) {
 922                         $self->$logger("[R] Requested IP: $req_addr", INFO);
 923                 } else {
 924                         $self->$logger("[R] Requested IP: None", INFO);
 925                 }
 926         }
 927
 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();
 933                 if (! $res) {
 934                         my $err = "Could not write lease file. Bailing";
 935                         $self->$logger($err, ERROR);
 936                         $self->$send_nak($req, $err);
 937                 } else {
 938                         $self->$send_accept($req, $calc_ip, DHCP_ACK);
 939                 }
 940         } else {
 941                 # bad request, we send a NAK
 942                 $self->$send_nak($req);
 943         }
 944
 945         # This transaction is finished with either NAK or ACK
 946         my $xid = $req->xid();
 947         delete($self->{_transaction}->{$xid});
 948
 949         $self->$logger("Transaction:\n".Dumper($self->{_transaction}), INFO);
 950 };
 951
 952 my $release_ip4 = sub {
 953         my ($self, $req) = @_;
 954         my ($ip, $mac);
 955
 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);
 960
 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();
 967                 }
 968         }
 969         $self->$logger("Transaction:\n".Dumper($self->{_transaction}), INFO);
 970 };
 971
 972 #########################################################################
 973 #  Private methods which handle DHCP6 requests
 974 #########################################################################
 975
 976 my $excuse_me_ip6 = sub {
 977         my ($self, $addr, $req) = @_;
 978
 979         $self->$logger("IPv6 request from [$addr]: $req", INFO);
 980         my $sock = IO::Socket::IP->new(
 981                 Domain    => PF_INET6,
 982                 V6Only    => 1,
 983                 Broadcast => 1,
 984                 PeerPort  => 546,
 985                 PeerAddr  => $addr,
 986                 Proto     => 'udp',
 987         ) || do {
 988                 my $err = $@;
 989                 $self->$logger("[excuse_me_ip6] Socket creation error: $err", ERROR);
 990                 die "[excuse_me_ip6] Socket creation error: $err\n";
 991         };
 992         $self->$logger("$addr: Not implemented here", INFO);
 993         $sock->send("Not implemented here") || die "Error sending excuse: $!\n";
 994         $sock->close;
 995 };
 996
 997 #########################################################################
 998 # Public methods
 999 #########################################################################
1000
1001 # generic signal handler to cause daemon to stop
1002 sub signal_handler {
1003     $time_to_die = 1;
1004 }
1005 $SIG{INT} = $SIG{TERM} = $SIG{HUP} = \&signal_handler;
1006
1007 # ignore any PIPE signal: standard behaviour is to quit process
1008 $SIG{PIPE} = 'IGNORE';
1009
1010 sub new {
1011     my ($class, %self) = @_;
1012
1013     # OOP stuff
1014     $class = ref($class) || $class;
1015     my $self = \%self;
1016     bless $self, $class;
1017
1018         # private
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}           = ();
1026
1027         # public
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;
1044
1045     return $self;
1046 }
1047
1048 sub run {
1049         my ($self) = @_;
1050         my ($sel, @ready, $socket, $res);
1051
1052         eval {
1053                 $self->$read_config();
1054         };
1055         if ($@) {
1056                 my $err = $@;
1057                 $self->$logger($err, ERROR);
1058                 die $err;
1059         }
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 /: $!";
1064                 umask 0;
1065
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: $!";
1069
1070                 my $pid = fork;
1071                 exit if $pid;
1072                 do {
1073                         my $err = $!;
1074                         $self->$logger("Couldn't fork: $err", ERROR);
1075                         die "Couldn't fork: $err";
1076                 } unless defined($pid);
1077
1078                 POSIX::setsid() || do {
1079                         my $err = $!;
1080                         $self->$logger("Can't start a new session: $err", ERROR);
1081                         die "Can't start a new session: $err";
1082                 };
1083                 $self->$logger("Now in Daemon mode", INFO);
1084         }
1085
1086         $res = $self->$read_lease_file();
1087         $self->$logger("Starting with empty leases file '$self->{lease_file}'", INFO)
1088                 if (! $res || ! $self->{_leases});
1089
1090         $self->$logger("Initialization complete", INFO);
1091
1092         # open listening socket
1093         $self->{_sock_in_ip4} = IO::Socket::IP->new(
1094                 Domain          => PF_INET,
1095                 LocalPort       => 67,
1096                 LocalAddr       => inet_ntoa(INADDR_ANY),
1097                 Proto           => 'udp'
1098         ) || do {
1099                 my $err = $@;
1100                 $self->$logger("IP4 Socket creation error: $err", ERROR);
1101                 die "IP4 Socket creation error: $err\n";
1102         };
1103         $self->{_sock_in_ip6} = IO::Socket::IP->new(
1104                 Domain          => PF_INET6,
1105                 V6Only          => 1,
1106                 LocalPort       => 547,
1107                 LocalAddr       => '::',
1108                 Proto           => 'udp'
1109         ) || do {
1110                 my $err = $@;
1111                 $self->$logger("IP6 Socket creation error: $err", ERROR);
1112                 die "IP6 Socket creation error: $err\n";
1113         };
1114
1115         $sel = IO::Select->new($self->{_sock_in_ip4});
1116         $sel->add($self->{_sock_in_ip6});
1117
1118         my $last_run = time;
1119
1120         until ($time_to_die) {
1121                 my $buf = undef;
1122                 my $fromaddr;
1123                 my $req;
1124
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
1135
1136                                                 $req = new Net::DHCP::Packet($buf);
1137
1138                                                 {
1139                                                         use bytes;
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);
1145                                                 }
1146
1147                                                 my $messagetype = $req->getOptionValue(DHO_DHCP_MESSAGE_TYPE());
1148
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);
1157                                                 } else {
1158                                                         $self->$logger("$messagetype: Packet dropped since unknown message type", WARNING);
1159                                                         # bad messagetype, we drop it
1160                                                 }
1161                                         } else {
1162                                                 # Receive ipv6 packet
1163                                                 my $myaddr = $socket->sockhost;
1164
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);
1169                                                 {
1170                                                         use bytes;
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);
1174                                                 }
1175                                                 $self->$excuse_me_ip6($myaddr, $buf);
1176                                         }
1177                                 }
1178                         }
1179                 };      # end of 'eval' blocks
1180                 if ($@) {
1181                         $self->$logger("Caught error in main loop: $@", ERROR);
1182                 }
1183         }
1184         $self->{_sock_in_ip4}->close;
1185         $self->{_sock_in_ip6}->close;
1186         $self->$logger("Exiting dhcpd", INFO);
1187 }
1188
1189 1;