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 #########################################################################
 436 #  Private methods which handle DHCP4 requests
 437 #########################################################################
 438
 439 my $get_mac_ip4 = sub {
 440         my ($self, $req) = @_;
 441         my $mac;
 442
 443         $mac = $req->chaddr();
 444         $mac =~ s/0+$//;
 445
 446         return $mac;
 447 };
 448
 449 my $can_client_use_net_ip4 = sub {
 450         my ($self, $req, $network) = @_;
 451         my ($found);
 452
 453         # Is client allowed to request IP?
 454         $found = 0;
 455         if ($self->{_config}->{$network}->{allow}) {
 456                 $self->$logger("Allow: " . Dumper($self->{_config}->{$network}->{allow}));
 457                 foreach (@{$self->{_config}->{$network}->{allow}}) {
 458                         if ($_ eq $self->$get_mac_ip4($req)) {
 459                                 $found = 1;
 460                                 last;
 461                         }
 462                 }
 463         } else {
 464                 $found = 1;
 465         }
 466
 467         return $found;
 468 };
 469
 470 my $add_options_ip4 = sub {
 471         my ($self, $resp) = @_;
 472
 473         if ($self->{lease_time}) {
 474                 $resp->addOptionValue(DHO_DHCP_LEASE_TIME, $self->{lease_time});
 475         }
 476         if ($self->{lease_time_renew}) {
 477                 $resp->addOptionValue(DHO_DHCP_RENEWAL_TIME, $self->{lease_time_renew});
 478         }
 479         if ($self->{subnet_mask}) {
 480                 $resp->addOptionValue(DHO_SUBNET_MASK, $self->{subnet_mask});
 481         }
 482         if ($self->{routers}) {
 483                 $resp->addOptionValue(DHO_ROUTERS, $self->{routers});
 484         }
 485         if ($self->{broadcast_addr}) {
 486                 $resp->addOptionValue(DHO_BROADCAST_ADDRESS, $self->{broadcast_addr});
 487         }
 488         if ($self->{domain_name}) {
 489                 $resp->addOptionValue(DHO_DOMAIN_NAME, $self->{domain_name});
 490         }
 491         if ($self->{ntp_servers}) {
 492                 $resp->addOptionValue(DHO_NTP_SERVERS, $self->{ntp_servers});
 493         }
 494         if ($self->{dns_servers}) {
 495                 $resp->addOptionValue(DHO_DOMAIN_NAME_SERVERS, $self->{dns_servers});
 496         }
 497 };
 498
 499 my $send_nak = sub {
 500         my ($self, $req, $message) = @_;
 501
 502         $message = 'Bad request' unless $message;
 503         my $peeraddr = ($req->ciaddr() && $req->ciaddr() ne inet_ntoa(INADDR_ANY)) ?
 504                 $req->ciaddr() : inet_ntoa(INADDR_BROADCAST);
 505
 506         my $sock = IO::Socket::IP->new(
 507                 Broadcast => 1,
 508                 PeerPort => 68,
 509                 PeerAddr => $peeraddr,
 510                 Proto    => 'udp'
 511         ) || do {
 512                 my $err = $@;
 513                 $self->$logger("[discover_ip4] Socket creation error: $err", ERROR);
 514                 die "[discover_ip4] Socket creation error: $err\n";
 515         };
 516
 517         my $resp = new Net::DHCP::Packet(
 518                 Comment => $req->comment(),
 519                 Op => BOOTREPLY(),
 520                 Hops => $req->hops(),
 521                 Xid => $req->xid(),
 522                 Flags => $req->flags(),
 523                 Ciaddr => $req->ciaddr(),
 524                 Yiaddr => "0.0.0.0",
 525                 Siaddr => $req->siaddr(),
 526                 Giaddr => $req->giaddr(),
 527                 Chaddr => $req->chaddr(),
 528                 DHO_DHCP_MESSAGE_TYPE() => DHCPNAK(),
 529                 DHO_DHCP_MESSAGE(), $message,
 530         );
 531
 532         $self->$logger("Sending NAK to " .      $sock->peerhost . ':' . $sock->peerport .
 533                 "\nReason: $message", INFO);
 534         $self->$logger($resp->toString());
 535
 536         my $xid = $req->xid() ? $req->xid() : 'Missing';
 537         $self->$logger("Sending OFFER tr=$xid", INFO);
 538
 539         $sock->send($resp->serialize()) || die "Error sending OFFER: $!\n";
 540         $sock->close;
 541 };
 542
 543 my $send_accept = sub {
 544         my ($self, $req, $calc_ip, $reply) = @_;
 545         my $msg;
 546
 547         my $peeraddr = ($req->ciaddr() && $req->ciaddr() ne inet_ntoa(INADDR_ANY)) ?
 548                 $req->ciaddr() : inet_ntoa(INADDR_BROADCAST);
 549
 550         if ($reply == DHCP_OFFER) {
 551                 $reply = DHCPOFFER();
 552                 $msg = 'DHCP_OFFER';
 553         } elsif ($reply == DHCP_ACK) {
 554                 $reply = DHCPACK();
 555                 $msg = 'DHCP_ACK';
 556         } else {
 557                 my $err = "$reply: Unknown reply";
 558                 $self->$logger($err, ERROR);
 559                 die $err;
 560         }
 561
 562         my $sock = IO::Socket::IP->new(
 563                 Broadcast => 1,
 564                 PeerPort => 68,
 565                 PeerAddr => $peeraddr,
 566                 Proto    => 'udp'
 567         ) || do {
 568                 my $err = $@;
 569                 $self->$logger("[discover_ip4] Socket creation error: $err", ERROR);
 570                 die "[discover_ip4] Socket creation error: $err\n";
 571         };
 572
 573         my $resp = new Net::DHCP::Packet(
 574                 Comment => $req->comment(),
 575                 Op => BOOTREPLY(),
 576                 Hops => $req->hops(),
 577                 Xid => $req->xid(),
 578                 Flags => $req->flags(),
 579                 Ciaddr => $req->ciaddr(),
 580                 Yiaddr => $calc_ip,
 581                 Siaddr => $req->siaddr(),
 582                 Giaddr => $req->giaddr(),
 583                 Chaddr => $req->chaddr(),
 584                 DHO_DHCP_MESSAGE_TYPE() => $reply,
 585                 DHO_DHCP_SERVER_IDENTIFIER() => $sock->sockhost
 586         );
 587         $self->$add_options_ip4($resp);
 588         my $xid = $req->xid();
 589         $self->{_transaction}->{$xid}->{me} = $sock->sockhost;
 590
 591         $self->$logger("Sending $msg to " .     $sock->peerhost . ':' . $sock->peerport, INFO);
 592         $self->$logger($resp->toString());
 593
 594         $self->$logger("Sending OFFER tr=".$req->xid(), INFO);
 595
 596         $sock->send($resp->serialize()) || die "Error sending $msg: $!\n";
 597         $sock->close;
 598 };
 599
 600 my $update_transaction = sub {
 601         my ($self, $req, $tx) = @_;
 602         my ($res, $xid, $offer);
 603
 604         $xid = $req->xid();
 605         return -1 unless $xid;
 606
 607         if ($tx) {
 608                 $self->{_transaction}->{$xid} = $tx;
 609                 $res = 0;
 610         } else {
 611                 if ($self->{_transaction}->{$xid} && $self->{_transaction}->{$xid}->{me}) {
 612                         my $me = $req->getOptionValue(DHO_DHCP_SERVER_IDENTIFIER());
 613                         $me = $req->ciaddr() unless $me;
 614                         $offer = $self->{_transaction}->{$xid}->{offer_ip};
 615                         if ($me) {
 616                                 if ($me ne $self->{_transaction}->{$xid}->{me}) {
 617                                         # Another DHCP server is chosen by client
 618                                         $self->$logger("$me: Offer '".($offer? $offer : 'None')."' refused by client xid=$xid", INFO);
 619                                         delete($self->{_transaction}->{$xid});
 620                                         delete($self->{_leases}->{$offer}) if $offer;
 621                                         $self->$write_lease_file();
 622                                         $res = 1;
 623                                 } else {
 624                                         $self->$logger("Offer '$offer' accepted by client xid=$xid", INFO);
 625                                         $res = 0;
 626                                 }
 627                         } else {
 628                                 # Caught request for other DHCP server
 629                         }
 630                 } else {
 631                         if ($self->{_transaction}->{$xid}) {
 632                                 $offer = $self->{_transaction}->{$xid}->{offer_ip};
 633                                 $self->$logger("Offer '$offer' wait approval from client xid=$xid", INFO);
 634                                 $res = 0;
 635                         }
 636                 }
 637         }
 638
 639         return $res;
 640 };
 641
 642 my $create_new_lease_ip4 = sub {
 643         my ($self, $req, $network) = @_;
 644         my $lease;
 645
 646         $lease->{'hardware ethernet'} = $self->$get_mac_ip4($req);
 647         my $client = $req->getOptionValue(DHO_HOST_NAME());
 648         $lease->{'client-hostname'} = $client ? $client : $self->$get_mac_ip4($req);
 649         $lease->{'binding state'} = 'active';
 650         my $start = time;
 651         my $end = $start + $self->{_config}->{$network}->{ttl};
 652         $lease->{starts} = $self->$convert_timestamp($start, 0);
 653         $lease->{ends} = $self->$convert_timestamp($end, 0);
 654
 655         return $lease;
 656 };
 657
 658 my $add_lease_ip4 = sub {
 659         my ($self, $req, $network, $ip) = @_;
 660
 661         my $lease = $self->$create_new_lease_ip4($req, $network);
 662         $self->$add_lease($ip, $lease);
 663         $self->{lease_time} = $DEFAULT_LEASE;
 664         if ($self->{_config}->{$network}->{ttl}) {
 665                 $self->{lease_time}     = $self->{_config}->{$network}->{ttl};
 666         }
 667         $self->{lease_time_renew} = $DEFAULT_LEASE_RENEW;
 668         if ($self->{_config}->{$network}->{rttl}) {
 669                 $self->{lease_time_renew} = $self->{_config}->{$network}->{rttl};
 670         }
 671         if ($self->{_config}->{$network}->{netmask}) {
 672                 $self->{subnet_mask} = $self->{_config}->{$network}->{netmask};
 673         }
 674         if ($self->{_config}->{$network}->{router}) {
 675                 $self->{routers} = $self->{_config}->{$network}->{router};
 676         }
 677         if ($self->{_config}->{$network}->{broadcast}) {
 678                 $self->{broadcast_addr} = $self->{_config}->{$network}->{broadcast};
 679         }
 680         if ($self->{_config}->{$network}->{'domain-name'}) {
 681                 $self->{domain_name} = $self->{_config}->{$network}->{'domain-name'};
 682         }
 683         if ($self->{_config}->{$network}->{'dns-servers'}) {
 684                 $self->{dns_servers} = $self->{_config}->{$network}->{'dns-servers'};
 685         }
 686         if ($self->{_config}->{$network}->{'ntp-servers'}) {
 687                 $self->{ntp_servers} = $self->{_config}->{$network}->{'ntp-servers'};
 688         }
 689 };
 690
 691 my $find_ip_ip4 = sub {
 692         my ($self, $req, $network, $reqaddr) = @_;
 693         my ($start, $end, $ip);
 694
 695         my @range_str = split(/\s+/, $self->{_config}->{$network}->{range});
 696         $self->$logger("Range: " . $range_str[0] . " - " . $range_str[1], INFO);
 697         $start = NetAddr::IP->new($range_str[0].'/'.$self->{_config}->{$network}->{netmask});
 698         $end = NetAddr::IP->new($range_str[1].'/'.$self->{_config}->{$network}->{netmask});
 699         $self->$logger(Dumper($start) . Dumper($end));
 700
 701         if ($reqaddr) {
 702                 my $request = NetAddr::IP->new($reqaddr);
 703                 if ($start->numeric() <= $request->numeric() && $request->numeric() <= $start->numeric()) {
 704                         my $cip = $request->addr();
 705                         $self->$logger("[find_ip_ip4] reqaddr: $reqaddr IP: $cip", INFO);
 706                         if ($self->{_leases}->{$cip}) {
 707                                 my $lease = $self->{_leases}->{$cip};
 708                                 my $mac = $self->$get_mac_ip4($req);
 709                                 if ($lease->{'hardware ethernet'} eq $mac) {
 710                                         $ip = $cip;
 711                                 }
 712                         } else {
 713                                 $ip = $cip;
 714                         }
 715                 }
 716         } else {
 717                 my $free = undef;
 718                 for (; $start <= $end; $start = $start + 1) {
 719                         my $cip = $start->addr();
 720                         $self->$logger("[find_ip_ip4] IP: $cip");
 721                         if ($self->{_leases}->{$cip} && ! $free) {
 722                                 my $lease = $self->{_leases}->{$cip};
 723                                 my $mac = $self->$get_mac_ip4($req);
 724                                 if ($lease->{'hardware ethernet'} eq $mac) {
 725                                         $ip = $cip;
 726                                 } elsif ($lease->{'binding state'} eq 'free') {
 727                                         $free = $cip;
 728                                 }
 729                         } else {
 730                                 $ip = $cip;
 731                         }
 732                         last if $ip;
 733                 }
 734                 if (! $ip && $free) {
 735                         $ip = $free;
 736                 }
 737         }
 738
 739         $self->$logger("[find_ip_ip4] IP: " . ($ip ? $ip : 'None'), INFO);
 740
 741         return $ip;
 742 };
 743
 744 my $calculate_net_ip4 = sub {
 745         my ($self, $req, $req_addr) = @_;
 746         my ($network, $net, $ip);
 747
 748         $self->$logger("Req IP: " . ($req_addr ? $req_addr : 'None'), INFO);
 749         foreach $net (keys %{$self->{_config}}) {
 750                 my $opt = $self->{_config}->{$net};
 751                 $self->$logger("Network: $net/$opt->{netmask}\n" . Dumper($opt), INFO);
 752                 $network = $net if ($self->$can_client_use_net_ip4($req, $net));
 753                 if ($network) {
 754                         if ($req_addr) {
 755                                 $ip = $self->$find_ip_ip4($req, $network, $req_addr);
 756                         } else {
 757                                 $ip = $self->$find_ip_ip4($req, $network);
 758                         }
 759                         last if $ip;
 760                         $network = undef;
 761                 }
 762         }
 763         $self->$logger("Network: " . ($network ? $network : 'None') . " IP: " . ($ip ? $ip : 'None'), INFO);
 764
 765         return ($network, $ip);
 766 };
 767
 768 my $calculate_ip_ip4 = sub {
 769         my ($self, $req, $state, $reqaddr) = @_;
 770         my ($network, $ip);
 771
 772         if ($state == DHCP_OFFER) {
 773                 if ($reqaddr) {
 774                         ($network, $ip) = $self->$calculate_net_ip4($req, $reqaddr);
 775                 } else {
 776                         ($network, $ip) = $self->$calculate_net_ip4($req);
 777                 }
 778         } elsif ($state == DHCP_ACK) {
 779                 # If no $reqaddr then client fail
 780                 if ($reqaddr) {
 781                         my $xid = $req->xid();
 782                         if ($self->{_transaction}->{$xid}) {
 783                                 my $offer = $self->{_transaction}->{$xid}->{offer_ip};
 784                                 if ($offer eq $reqaddr) {
 785                                         $network = $self->{_transaction}->{$xid}->{network};
 786                                         $ip = $self->{_transaction}->{$xid}->{offer_ip}
 787                                 }
 788                                 delete($self->{_transaction}->{$xid});
 789                         } else {
 790                                 # No prior discovery. We maintain transaction
 791                                 ($network, $ip) = $self->$calculate_net_ip4($req, $reqaddr);
 792                         }
 793                 }
 794         } else {
 795         }
 796
 797         return ($network, $ip);
 798 };
 799
 800 my $discover_ip4 = sub {
 801         my ($self, $req) = @_;
 802         my ($tx, $res, $resp, $network, $calc_ip, $req_addr);
 803
 804         $self->$logger("Got ip4 discover request: \n" . $req->toString(), INFO);
 805
 806         $res = $self->$update_transaction($req);
 807         if ($res) {
 808                 my $err = "Missing transaction ID";
 809                 $self->$send_nak($req, $err);
 810                 $self->$logger($err, ERROR);
 811                 die $err;
 812         }
 813
 814         $req_addr = $req->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
 815         $res = $self->$read_lease_file();
 816         $self->$logger("Starting with empty lease file", INFO) unless $res;
 817
 818
 819         if ($self->{LOG_LEVEL} <= INFO) {
 820                 if ($req_addr) {
 821                         $self->$logger("[D] Requested IP: $req_addr", INFO);
 822                 } else {
 823                         $self->$logger("[D] Requested IP: None", INFO);
 824                 }
 825         }
 826
 827         $tx->{req_ip} = $req_addr ? $req_addr : 'None';
 828
 829         ($network, $calc_ip) = $self->$calculate_ip_ip4($req, DHCP_OFFER, $req_addr);
 830         $tx->{offer_ip} = $calc_ip ? $calc_ip : 'None';
 831         $tx->{network} = $network ? $network : 'None';
 832
 833         $self->$logger("Offer: $tx->{offer_ip}");
 834
 835         if ($network && $calc_ip) {
 836                 $self->$logger("Creating lease for $calc_ip", INFO);
 837                 $res = $self->$update_transaction($req, $tx);
 838                 if ($res) {
 839                                 my $err = "Could not create transaction";
 840                                 $self->$logger($err, ERROR);
 841                                 $self->$send_nak($req, $err);
 842                 } else {
 843                         $self->$add_lease_ip4($req, $network, $calc_ip);
 844                         $res = $self->$write_lease_file();
 845                         if (! $res) {
 846                                 my $err = "Could not write lease file. Bailing";
 847                                 $self->$logger($err, ERROR);
 848                                 my $xid = $req->xid();
 849                                 delete($self->{_transaction}->{$xid});
 850                                 $self->$send_nak($req, $err);
 851                         } else {
 852                                 $self->$send_accept($req, $calc_ip, DHCP_OFFER);
 853                         }
 854                 }
 855         } else {
 856                 # bad request, we send a NAK
 857                 my $err = "$req_addr: Not available";
 858                 $self->$logger($err, INFO);
 859                 $self->$send_nak($req, $err);
 860         }
 861
 862         $self->$logger("Transaction:\n".Dumper($self->{_transaction}), INFO);
 863 };
 864
 865 my $request_ip4 = sub {
 866         my ($self, $req) = @_;
 867         my ($calc_ip, $network, $res);
 868
 869         $self->$logger("Got request\n".$req->toString());
 870
 871         $res = $self->$update_transaction($req);
 872         if ($res) {
 873                 if ($res < 0) {
 874                         my $err = "Missing transaction ID";
 875                         $self->$send_nak($req, $err);
 876                         $self->$logger($err, ERROR);
 877                         die $err;
 878                 } else {
 879                         return;
 880                 }
 881         }
 882
 883         my $req_addr = $req->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
 884         if ($self->{LOG_LEVEL} <= INFO) {
 885                 if ($req_addr) {
 886                         $self->$logger("[R] Requested IP: $req_addr", INFO);
 887                 } else {
 888                         $self->$logger("[R] Requested IP: None", INFO);
 889                 }
 890         }
 891
 892         ($network, $calc_ip) = $self->$calculate_ip_ip4($req, DHCP_ACK, $req_addr);
 893         if ($network && $calc_ip) {
 894                 $self->$logger("Creating lease for $calc_ip", INFO);
 895                 $self->$add_lease_ip4($req, $network, $calc_ip);
 896                 $res = $self->$write_lease_file();
 897                 if (! $res) {
 898                         my $err = "Could not write lease file. Bailing";
 899                         $self->$logger($err, ERROR);
 900                         $self->$send_nak($req, $err);
 901                 } else {
 902                         $self->$send_accept($req, $calc_ip, DHCP_ACK);
 903                 }
 904         } else {
 905                 # bad request, we send a NAK
 906                 $self->$send_nak($req);
 907         }
 908
 909         # This transaction is finished with either NAK or ACK
 910         my $xid = $req->xid();
 911         delete($self->{_transaction}->{$xid});
 912
 913         $self->$logger("Transaction:\n".Dumper($self->{_transaction}), INFO);
 914 };
 915
 916 my $release_ip4 = sub {
 917         my ($self, $req) = @_;
 918         my ($ip, $mac);
 919
 920         $self->$logger($req->toString());
 921         $ip = $req->ciaddr();
 922         $mac = $self->$get_mac_ip4($req);
 923         $self->$logger("Release request for IP: $ip MAC: $mac", INFO);
 924
 925         if ($self->{_leases}->{$ip}) {
 926                 my $lease = $self->{_leases}->{$ip};
 927                 if ($lease->{'hardware ethernet'} eq $mac) {
 928                         $self->$logger("Set binding state free IP: $ip MAC: $mac", INFO);
 929                         $lease->{'binding state'} = 'free';
 930                         $self->$write_lease_file();
 931                 }
 932         }
 933         $self->$logger("Transaction:\n".Dumper($self->{_transaction}), INFO);
 934 };
 935
 936 #########################################################################
 937 #  Private methods which handle DHCP6 requests
 938 #########################################################################
 939
 940 my $excuse_me_ip6 = sub {
 941         my ($self, $addr, $req) = @_;
 942
 943         $self->$logger("IPv6 request from [$addr]: $req", INFO);
 944         my $sock = IO::Socket::IP->new(
 945                 Domain    => PF_INET6,
 946                 V6Only    => 1,
 947                 Broadcast => 1,
 948                 PeerPort  => 546,
 949                 PeerAddr  => $addr,
 950                 Proto     => 'udp',
 951         ) || do {
 952                 my $err = $@;
 953                 $self->$logger("[excuse_me_ip6] Socket creation error: $err", ERROR);
 954                 die "[excuse_me_ip6] Socket creation error: $err\n";
 955         };
 956         $self->$logger("$addr: Not implemented here", INFO);
 957         $sock->send("Not implemented here") || die "Error sending excuse: $!\n";
 958         $sock->close;
 959 };
 960
 961 #########################################################################
 962 # Public methods
 963 #########################################################################
 964
 965 # generic signal handler to cause daemon to stop
 966 sub signal_handler {
 967     $time_to_die = 1;
 968 }
 969 $SIG{INT} = $SIG{TERM} = $SIG{HUP} = \&signal_handler;
 970
 971 # ignore any PIPE signal: standard behaviour is to quit process
 972 $SIG{PIPE} = 'IGNORE';
 973
 974 sub new {
 975     my ($class, %self) = @_;
 976
 977     # OOP stuff
 978     $class = ref($class) || $class;
 979     my $self = \%self;
 980     bless $self, $class;
 981
 982         # private
 983     $self->{_sock_in_ip4}               = undef;
 984     $self->{_sock_in_ip6}               = undef;
 985     $self->{_leases}                    = undef;
 986     $self->{_reverse}                   = undef;
 987     $self->{_config}                    = undef;
 988         $self->{_dhpcp_ip4}                     = undef;
 989         $self->{_transaction}           = ();
 990
 991         # public
 992         $self->{log_file}                       ||= 'syslog';
 993     $self->{lease_time}                 ||= $DEFAULT_LEASE;
 994     $self->{lease_time_renew}   ||= $DEFAULT_LEASE_RENEW;
 995     $self->{subnet_mask}                ||= undef;
 996     $self->{routers}                    ||= undef;
 997     $self->{broadcast_addr}             ||= undef;
 998     $self->{domain_name}                ||= undef;
 999     $self->{dns_servers}                ||= undef;
1000         $self->{ntp_servers}            ||= undef;
1001         $self->{LOG_LEVEL}                      = ERROR unless defined $self->{LOG_LEVEL};
1002         $self->{NODAEMON}                       ||= 0;
1003         $self->{DEBUG}                          ||= 0;
1004         $self->{timeout}                        ||= 10;
1005         $self->{lease_file}                     ||= '/tmp/dhcpd.leases';
1006         $self->{conf_file}                      ||= '/tmp/dhcpd.cfg';
1007
1008     return $self;
1009 }
1010
1011 sub run {
1012         my ($self) = @_;
1013         my ($sel, @ready, $socket, $res);
1014
1015         eval {
1016                 $self->$read_config();
1017         };
1018         if ($@) {
1019                 my $err = $@;
1020                 $self->$logger($err, ERROR);
1021                 die $err;
1022         }
1023         $self->$logger("Starting dhcpd", INFO);
1024         if ($self->{NODAEMON} < 1) {
1025                 $self->$logger("Entering Daemon mode");
1026                 chdir '/'                 or die "Can't chdir to /: $!";
1027                 umask 0;
1028
1029                 open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
1030                 open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
1031                 open STDERR, '>/dev/null' or die "Can't write to /dev/null: $!";
1032
1033                 my $pid = fork;
1034                 exit if $pid;
1035                 do {
1036                         my $err = $!;
1037                         $self->$logger("Couldn't fork: $err", ERROR);
1038                         die "Couldn't fork: $err";
1039                 } unless defined($pid);
1040
1041                 POSIX::setsid() || do {
1042                         my $err = $!;
1043                         $self->$logger("Can't start a new session: $err", ERROR);
1044                         die "Can't start a new session: $err";
1045                 };
1046                 $self->$logger("Now in Daemon mode", INFO);
1047         }
1048
1049         $res = $self->$read_lease_file();
1050         $self->$logger("Starting with empty leases file '$self->{lease_file}'", INFO)
1051                 if (! $res || ! $self->{_leases});
1052
1053         $self->$logger("Initialization complete", INFO);
1054
1055         # open listening socket
1056         $self->{_sock_in_ip4} = IO::Socket::IP->new(
1057                 Domain          => PF_INET,
1058                 LocalPort       => 67,
1059                 LocalAddr       => inet_ntoa(INADDR_ANY),
1060                 Proto           => 'udp'
1061         ) || do {
1062                 my $err = $@;
1063                 $self->$logger("IP4 Socket creation error: $err", ERROR);
1064                 die "IP4 Socket creation error: $err\n";
1065         };
1066         $self->{_sock_in_ip6} = IO::Socket::IP->new(
1067                 Domain          => PF_INET6,
1068                 V6Only          => 1,
1069                 LocalPort       => 547,
1070                 LocalAddr       => '::',
1071                 Proto           => 'udp'
1072         ) || do {
1073                 my $err = $@;
1074                 $self->$logger("IP6 Socket creation error: $err", ERROR);
1075                 die "IP6 Socket creation error: $err\n";
1076         };
1077
1078         $sel = IO::Select->new($self->{_sock_in_ip4});
1079         $sel->add($self->{_sock_in_ip6});
1080
1081         until ($time_to_die) {
1082                 my $buf = undef;
1083                 my $fromaddr;
1084                 my $req;
1085
1086                 eval {  # catch fatal errors
1087                         while (@ready = $sel->can_read) {
1088                                 $self->$logger("Waiting for incoming packet", INFO);
1089                                 foreach $socket (@ready) {
1090                                         if ($socket == $self->{_sock_in_ip4}) {
1091                                                 # receive ipv4 packet
1092                                                 $fromaddr = $socket->recv($buf, 4096)
1093                                                         || $self->$logger("recv: $!", ERROR);
1094                                                 next if ($!);   # continue loop if an error occured
1095
1096                                                 $req = new Net::DHCP::Packet($buf);
1097
1098                                                 {
1099                                                         use bytes;
1100                                                         my $xid = $req->xid();
1101                                                         $xid = $xid ? $xid : 'None';
1102                                                         my ($port,$addr) = unpack_sockaddr_in($fromaddr);
1103                                                         my $ipaddr = inet_ntoa($addr);
1104                                                         $self->$logger("Got a packet tr=$xid src=$ipaddr:$port length=".length($buf), INFO);
1105                                                 }
1106
1107                                                 my $messagetype = $req->getOptionValue(DHO_DHCP_MESSAGE_TYPE());
1108
1109                                                 if ($messagetype eq DHCPDISCOVER()) {
1110                                                                 $self->$discover_ip4($req);
1111                                                 } elsif ($messagetype eq DHCPREQUEST()) {
1112                                                                 $self->$request_ip4($req);
1113                                                 } elsif ($messagetype eq DHCPINFORM()) {
1114                                                         $self->$logger("Not implemented: DHCPINFORM", WARNING);
1115                                                 } elsif ($messagetype eq DHCPRELEASE()) {
1116                                                                 $self->$release_ip4($req);
1117                                                 } else {
1118                                                         $self->$logger("$messagetype: Packet dropped since unknown message type", WARNING);
1119                                                         # bad messagetype, we drop it
1120                                                 }
1121                                         } else {
1122                                                 # Receive ipv6 packet
1123                                                 my $myaddr = $socket->sockhost;
1124
1125                                                 $fromaddr = $socket->recv($buf, 4096)
1126                                                         || $self->$logger("recv: $!", ERROR);
1127                                                 next if ($!);   # continue loop if an error occured
1128                                                 $self->$logger("recv: $buf", INFO);
1129                                                 {
1130                                                         use bytes;
1131                                                         my ($port,$addr) = unpack_sockaddr_in6($fromaddr);
1132                                                         my $ipaddr = inet_ntop(AF_INET6, $addr);
1133                                                         $self->$logger("Got a packet tr=$self->{_transaction_ip6} src=$ipaddr:$port length=".length($buf), INFO);
1134                                                 }
1135                                                 $self->$excuse_me_ip6($myaddr, $buf);
1136                                         }
1137                                 }
1138                         }
1139                 };      # end of 'eval' blocks
1140                 if ($@) {
1141                         $self->$logger("Caught error in main loop: $@", ERROR);
1142                 }
1143         }
1144         $self->{_sock_in_ip4}->close;
1145         $self->{_sock_in_ip6}->close;
1146         $self->$logger("Exiting dhcpd", INFO);
1147 }
1148
1149 1;