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 };
  32
  33 use Exporter;
  34 our @ISA = qw(Exporter);
  35 our @EXPORT = qw(
  36         run
  37         DEBUG
  38         INFO
  39         NOTICE
  40         WARNING
  41         ERROR
  42         CRITICAL
  43         ALERT
  44         EMERGENCY
  45 );
  46
  47 our $VERSION = '0.01';
  48 our $NAME = 'PVE::DHCPServer';
  49 our $DEFAULT_LEASE = 7200;
  50 our $DEFAULT_LEASE_RENEW = 5400;
  51 my $time_to_die = 0;
  52
  53 #########################################################################
  54 # Private methods
  55 #########################################################################
  56
  57 my $logger = sub {
  58         my ($self, $message, $level) = @_;
  59
  60         $level ||= DEBUG;
  61         return unless ($level >= $self->{LOG_LEVEL});
  62
  63         $level = "debug" if $level eq DEBUG;
  64         $level = "info" if $level eq INFO;
  65         $level = "notice" if $level eq NOTICE;
  66         $level = "warning" if $level eq WARNING;
  67         $level = "err" if $level eq ERROR;
  68         $level = "crit" if $level eq CRITICAL;
  69         $level = "alert" if $level eq ALERT;
  70         $level = "emerg" if $level eq EMERGENCY;
  71
  72         if ($self->{DEBUG}) {
  73                 print STDOUT strftime "[%d/%b/%Y:%H:%M:%S] ", localtime;
  74                 print STDOUT "$level: " . ($message ? $message : 'No message') . "\n";
  75         } elsif ($self->{log_file} eq 'syslog') {
  76                 openlog($NAME, 'ndelay,pid', 'user');
  77                 syslog($level, $message);
  78                 closelog();
  79         } else {
  80                 my $fh = new IO::File;
  81                 if (! $fh->open("> $self->{log_file}")) {
  82                         croak "$self->{log_file}: $!";
  83                 }
  84                 print $fh strftime "[%d/%b/%Y:%H:%M:%S] ", localtime;
  85                 print $fh "$level: $message\n";
  86                 undef $fh;
  87         }
  88 };
  89
  90 my $run_with_timeout = sub {
  91     my ($self, $code, @param) = @_;
  92
  93     die "got timeout" if $self->{timeout} <= 0;
  94
  95     my $prev_alarm;
  96
  97     my $sigcount = 0;
  98
  99     my $res;
 100
 101     local $SIG{ALRM} = sub { $sigcount++; }; # catch alarm outside eval
 102
 103     eval {
 104                 local $SIG{ALRM} = sub { $sigcount++; die "got timeout"; };
 105                 local $SIG{PIPE} = sub { $sigcount++; die "broken pipe" };
 106                 local $SIG{__DIE__};   # see SA bug 4631
 107
 108                 $prev_alarm = alarm($self->{timeout});
 109
 110                 $res = &$code(@param);
 111
 112                 alarm(0); # avoid race conditions
 113     };
 114
 115     my $err = $@;
 116
 117     alarm($prev_alarm) if defined($prev_alarm);
 118
 119     die "unknown error" if $sigcount && !$err; # seems to happen sometimes
 120
 121     die $err if $err;
 122
 123     return $res;
 124 };
 125
 126 my $lock = sub {
 127         my ($self, $file, $shared) = @_;
 128
 129         my $mode = $shared ? LOCK_SH : LOCK_EX;
 130
 131         my $lock_func = sub {
 132                 if ($mode == LOCK_SH) {
 133                         $self->{file_handle} = new IO::File ("<$file") ||
 134                 die "can't open file '$file' for read - $!";
 135                 } else {
 136                         $self->{file_handle} = new IO::File (">$file") ||
 137                 die "can't open file '$file' for write - $!";
 138                 }
 139         $self->$logger("trying to aquire lock on '$file'...");
 140         if (!flock ($self->{file_handle}, $mode|LOCK_NB)) {
 141                         my $success;
 142                         while(1) {
 143                                 $success = flock($self->{file_handle}, $mode);
 144                                 # try again on EINTR (see bug #273)
 145                                 if ($success || ($! != EINTR)) {
 146                                         last;
 147                                 }
 148                         }
 149                         if ($mode == LOCK_SH) {
 150                                 seek($self->{file_handle}, 0, SEEK_END) or $success = 0;
 151                         }
 152                         if (!$success) {
 153                                 $self->$logger(" failed");
 154                                 die "can't aquire lock - $!";
 155                         }
 156         }
 157                 $self->$logger(" OK");
 158     };
 159
 160     my $res;
 161     my $err = undef;
 162
 163     eval {
 164                 $res = $self->$run_with_timeout($lock_func);
 165         };
 166     if ($@) {
 167                 $self->$logger("can't lock file '$file' - $@", ERROR);
 168                 $self->{file_handle} = undef;
 169                 return undef;
 170     }
 171
 172     return $res;
 173 };
 174
 175 my $unlock = sub {
 176         my ($self, $file) = @_;
 177
 178         return '' unless($self->{file_handle});
 179         my $unlock_func = sub {
 180         $self->$logger("trying to unlock '$file'...");
 181         if (!flock($self->{file_handle}, LOCK_UN)) {
 182
 183                         my $success;
 184                         while(1) {
 185                                 $success = flock($self->{file_handle}, LOCK_UN);
 186                                 # try again on EINTR (see bug #273)
 187                                 if ($success || ($! != EINTR)) {
 188                                         last;
 189                                 }
 190                         }
 191                         if (!$success) {
 192                                 $self->$logger(" failed");
 193                                 die "can't unlock - $!";
 194                         }
 195         }
 196                 $self->$logger(" OK");
 197     };
 198
 199     my $res;
 200     my $err = undef;
 201
 202     eval {
 203                 $res = $self->$run_with_timeout($unlock_func);
 204         };
 205     if ($@) {
 206                 $self->$logger("can't lock file '$file' - $@", ERROR);
 207                 $self->{file_handle} = undef;
 208                 $res = undef;
 209     }
 210
 211     return $res;
 212 };
 213
 214 my $convert_timestamp = sub {
 215         my ($self, $timestamp, $strtotime) = @_;
 216         my ($res, $mday, $mon, $year, $hour, $min, $sec);
 217
 218         $self->$logger("Timestamp: $timestamp");
 219         if ($strtotime) {
 220                 if ($timestamp !~ /^\d{4}\/\d{2}\/\d{2}\s+\d{2}:\d{2}:\d{2}$/) {
 221                         $self->$logger("$timestamp: (strtotime) Bad format", ERROR);
 222                         $res = undef;
 223                 } else {
 224                         ($year,$mon,$mday,$hour,$min,$sec) = split(/[\s\/:]+/, $timestamp);
 225                         $res = timelocal($sec,$min,$hour,$mday,$mon-1,$year);
 226                 }
 227         } else{
 228                 $self->$logger($timestamp);
 229                 if ($timestamp !~ /^\d+$/) {
 230                         $self->$logger("$timestamp: (timetostr) Bad format", ERROR);
 231                         $res = undef;
 232                 } else {
 233                         ($sec,$min,$hour,$mday,$mon,$year) = localtime($timestamp);
 234                         $self->$logger("Timestamp: $sec,$min,$hour,$mday,$mon,$year");
 235                         $res = sprintf("%d/%02d/%02d %02d:%02d:%02d", ($year+1900),($mon+1),$mday,$hour,$min,$sec);
 236                         $self->$logger("Timestamp: $res");
 237                 }
 238         }
 239
 240         return $res;
 241 };
 242
 243
 244 my $add_lease = sub {
 245         my ($self, $ip, $lease) = @_;
 246         my $ts;
 247
 248         my $mac = $lease->{'hardware ethernet'};
 249         $mac =~ tr/://d;
 250         $lease->{'hardware ethernet'} = $mac;
 251         $ts = $self->$convert_timestamp($lease->{starts}, 1);
 252         return unless $ts;
 253         $lease->{starts} = $ts;
 254         $ts = $self->$convert_timestamp($lease->{ends}, 1);
 255         return unless $ts;
 256         $lease->{ends} = $ts;
 257
 258         $self->{_leases}->{$ip} = $lease;
 259         $self->$logger(Dumper($self->{_leases}->{$ip}));
 260         $self->{_reverse}->{$mac} = $ip;
 261         $self->$logger("$mac => $self->{_reverse}->{$mac}");
 262 };
 263
 264 #lease vvv.xxx.yyy.zzz {
 265 #       starts yyyy/mm/dd hh:mm:ss;
 266 #       ends yyyy/mm/dd hh:mm:ss;
 267 #       binding state active|free;
 268 #       hardware ethernet MAC;
 269 #       client-hostname "name"
 270 #}
 271 my $read_lease_file = sub {
 272         my ($self) = @_;
 273         my ($res, $key, $lease);
 274         my $error = 0;
 275
 276         # Start with empty leases file?
 277         if (! -e $self->{lease_file}) {
 278                 return 0;
 279         }
 280
 281         $self->$lock($self->{lease_file}, 1);
 282         if ($self->{file_handle}) {
 283                 my $fh = $self->{file_handle};
 284                 my @lines = <$fh>;
 285                 foreach (@lines) {
 286                         $self->$logger("Read: $_");
 287                         if ($_ =~ /^\s*lease\s+([\d\.]+)\s+{\s*/) {
 288                                 $self->$add_lease($key, $lease) if $lease;
 289                                 $key = $1;
 290                                 $lease = undef;
 291                                 $error = 0;
 292                                 $self->$logger("Key: $key");
 293                         } else {
 294                                 next if $error;
 295                                 next if ($_ =~ /^\s*}\s*/ || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
 296                                 if ($_ =~ /^\s*(starts|ends|binding state|hardware ethernet|client-hostname)\s+(.+)\s*;/) {
 297                                         $lease->{$1} = $2;
 298                                         $self->$logger("Key: $1 Value: $2");
 299                                 } else {
 300                                         $key = 'UNDEF' unless $key;
 301                                         $self->$logger("$key: Bad format", ERROR);
 302                                         $key = undef;
 303                                         $lease = undef;
 304                                         $error = 1;
 305                                 }
 306                         }
 307                 }
 308                 if ($lease && !$error) {
 309                         $self->$logger("Key: $key");
 310                         $self->$add_lease($key, $lease);
 311                 }
 312                 $self->$logger("Leases data structure: \n" . Dumper($self->{_leases}));
 313                 $self->$unlock($self->{lease_file});
 314                 $res = 1;
 315         } else {
 316                 $self->$logger("Could not read leases file", ERROR);
 317                 $res = 0;
 318         }
 319
 320         return $res;
 321 };
 322
 323 my $write_lease_file = sub {
 324         my ($self) = @_;
 325         my $res;
 326
 327         $res = $self->$lock($self->{lease_file}, 0);
 328         if ($self->{file_handle}) {
 329                 if ($self->{_leases}) {
 330                         my $fh = $self->{file_handle};
 331                         my %leases = %{$self->{_leases}};
 332                         while ((my $lease, my $elems) = each (%leases)) {
 333                                 $self->$logger("Writing: $lease");
 334                                 print $fh "lease $lease {\n";
 335                                 while ((my $key, my $val) = each %$elems) {
 336                                         if ($key =~ /^(starts|ends)$/) {
 337                                                 $val = $self->$convert_timestamp($val, 0);
 338                                         }
 339                                         $self->$logger("Writing: $key $val");
 340                                         print $fh "\t$key $val;\n";
 341                                 }
 342                                 print $fh "}\n";
 343                         }
 344                 }
 345                 $self->$unlock($self->{lease_file});
 346                 $res = 1;
 347         } else {
 348                 $self->$logger("Could not write leases file", ERROR);
 349                 $res = 0;
 350         }
 351
 352         return $res;
 353 };
 354
 355 #subnet 192.168.9.0 netmask 255.255.255.0 {
 356 #       range 192.168.9.2 192.168.9.100;
 357 #       ttl 7200;
 358 #       rttl 3600;
 359 #       router 192.168.9.254;
 360 #       dns-servers 192.168.2.201;
 361 #       ntp-servers 192.168.9.254;
 362 #       broadcast 192.168.9.255;
 363 #       domain-name "foo.bar";
 364 #       {
 365 #               allow 001cc0c33317,001cc0c33318,001cc0c33319,001cc0c33320;
 366 #               static 001cc0c33317 192.168.9.100,001cc0c33318 192.168.9.200;
 367 #       }
 368 #}
 369 my $read_config = sub {
 370         my ($self) = @_;
 371         my ($res, $key, $netmask, $config, $subopt);
 372
 373         $self->$lock($self->{conf_file}, 1);
 374         if ($self->{file_handle}) {
 375                 my $fh = $self->{file_handle};
 376                 my @lines = <$fh>;
 377                 $subopt = 0;
 378                 foreach (@lines) {
 379                         $self->$logger("Read: $_");
 380                         if ($_ =~ /^\s*subnet\s+([\d\.]+)\s+netmask\s+([\d\.]+)\s+{\s*/) {
 381                                 $self->{_config}->{$key} = $config if $config;
 382                                 $key = $1;
 383                                 $config = undef;
 384                                 $config->{netmask} = $2;
 385                                 $self->$logger("Key: $key Netmask: $config->{netmask}");
 386                         } else {
 387                                 next if (($_ =~ /^\s*}\s*/ && ! $subopt) || $_ =~ /^\s*$/ || $_ =~ /^\s*#.*/);
 388                                 if (! $subopt && $_ =~ /^\s*(range|ttl|rttl|router|dns-servers|ntp-servers|broadcast|domain-name)\s+(.+)\s*;/) {
 389                                         $config->{$1} = $2;
 390                                         $self->$logger("Key: $1 Value: $2");
 391                                 } elsif ($subopt &&$_ =~ /^\s*}\s*/) {
 392                                         $subopt = 0;
 393                                 } elsif ($subopt || $_ =~ /^\s*{\s*/) {
 394                                         if ($subopt) {
 395                                                 if ($_ =~ /^\s*(allow|static)\s+(.+)\s*;/) {
 396                                                         my @vals = split(/\s*,\s*/, $2);
 397                                                         $config->{$1} = [@vals];
 398                                                         $self->$logger("Key: $1 Value: $2");
 399                                                 } else {
 400                                                         $key = 'UNDEF' unless $key;
 401                                                         my $err = "$key: 'suboptions' Bad format";
 402                                                         $self->$logger($err, ERROR);
 403                                                         $key = undef;
 404                                                         $config = undef;
 405                                                         die $err;
 406                                                 }
 407                                         } else {
 408                                                 $subopt = 1;
 409                                         }
 410                                 } else {
 411                                         $key = 'UNDEF' unless $key;
 412                                         my $err = "$key: Bad format";
 413                                         $self->$logger($err, ERROR);
 414                                         $key = undef;
 415                                         $config = undef;
 416                                         die $err;
 417                                 }
 418                         }
 419                 }
 420                 if ($config) {
 421                         $self->{_config}->{$key} = $config;
 422                 }
 423                 $self->$logger("Config data structure: \n" . Dumper($self->{_config}));
 424                 $self->$unlock($self->{conf_file});
 425                 if (!$self->{_config}) {
 426                         die "Empty config file";
 427                 }
 428         } else {
 429                 die "Could not read config file";
 430         }
 431 };
 432
 433 #########################################################################
 434 #  Private methods which handle DHCP4 requests
 435 #########################################################################
 436
 437 my $get_mac_ip4 = sub {
 438         my ($self, $dhcpreq) = @_;
 439         my $mac;
 440
 441         $mac = $dhcpreq->chaddr();
 442         $mac =~ s/0+$//;
 443
 444         return $mac;
 445 };
 446
 447 my $can_client_use_net_ip4 = sub {
 448         my ($self, $dhcpreq, $network) = @_;
 449         my (@allow, $found);
 450
 451         # Is client allowed to request IP?
 452         $found = 0;
 453         if ($self->{_config}->{$network}->{allow}) {
 454                 @allow = $self->{_config}->{$network}->{allow};
 455                 $self->$logger("Allow: " . Dumper(@allow));
 456                 foreach (@allow) {
 457                         if ($_ eq $self->$get_mac_ip4($dhcpreq)) {
 458                                 $found = 1;
 459                                 last;
 460                         }
 461                 }
 462         } else {
 463                 $found = 1;
 464         }
 465
 466         return $found;
 467 };
 468
 469 my $create_new_lease_ip4 = sub {
 470         my ($self, $dhcpreq, $network, $lease) = @_;
 471
 472         if (! $lease) {
 473                 $lease = ();
 474                 $lease->{'hardware ethernet'} = $self->$get_mac_ip4($dhcpreq);
 475         }
 476         my $client = $dhcpreq->getOptionValue(DHO_HOST_NAME());
 477         $lease->{'client-hostname'} = $client ? $client : $self->$get_mac_ip4($dhcpreq);
 478         $lease->{'binding state'} = 'active';
 479         my $start = time;
 480         my $end = $start + $self->{_config}->{$network}->{ttl};
 481         $lease->{starts} = $self->$convert_timestamp($start, 0);
 482         $lease->{ends} = $self->$convert_timestamp($end, 0);
 483
 484         return $lease;
 485 };
 486
 487 my $add_options_ip4 = sub {
 488         my ($self, $dhcpreq) = @_;
 489
 490         if ($self->{lease_time}) {
 491                 $dhcpreq->addOptionValue(DHO_DHCP_LEASE_TIME, $self->{lease_time});
 492         }
 493         if ($self->{lease_time_renew}) {
 494                 $dhcpreq->addOptionValue(DHO_DHCP_RENEWAL_TIME, $self->{lease_time_renew});
 495         }
 496         if ($self->{subnet_mask}) {
 497                 $dhcpreq->addOptionValue(DHO_SUBNET_MASK, $self->{subnet_mask});
 498         }
 499         if ($self->{routers}) {
 500                 $dhcpreq->addOptionValue(DHO_ROUTERS, $self->{routers});
 501         }
 502         if ($self->{broadcast_addr}) {
 503                 $dhcpreq->addOptionValue(DHO_BROADCAST_ADDRESS, $self->{broadcast_addr});
 504         }
 505         if ($self->{domain_name}) {
 506                 $dhcpreq->addOptionValue(DHO_DOMAIN_NAME, $self->{domain_name});
 507         }
 508         if ($self->{ntp_servers}) {
 509                 $dhcpreq->addOptionValue(DHO_NTP_SERVERS, $self->{ntp_servers});
 510         }
 511         if ($self->{dns_servers}) {
 512                 $dhcpreq->addOptionValue(DHO_DOMAIN_NAME_SERVERS, $self->{dns_servers});
 513         }
 514 };
 515
 516 my $calculate_net_ip4 = sub {
 517         my ($self, $dhcpreq) = @_;
 518         my ($req_addr, $network);
 519
 520         $req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
 521         $self->$logger("Req IP: " . ($req_addr ? $req_addr : 'None'));
 522         if ($req_addr) {
 523                 my ($space, $test);
 524                 my %config = %{$self->{_config}};
 525                 while (my ($net, $opt) = each (%config)) {
 526                         $self->$logger("Network: $net/$opt->{netmask}\n" . Dumper($opt));
 527                         $space = NetAddr::IP->new($net, $opt->{netmask});
 528                         $test = NetAddr::IP->new($req_addr);
 529                         if ($space->contains($test)) {
 530                                 $network = $net if ($self->$can_client_use_net_ip4($dhcpreq, $net));
 531                                 last;
 532                         }
 533                 }
 534         } else {
 535                 my ($space, $test);
 536                 my %config = %{$self->{_config}};
 537                 while (my ($net, $opt) = each (%config)) {
 538                         $self->$logger("Network: $net/$opt->{netmask}\n" . Dumper($opt));
 539                         my $can = $self->$can_client_use_net_ip4($dhcpreq, $net);
 540                         $self->$logger("Network usable: $can");
 541                         if ($can) {
 542                                 $network = $net;
 543                                 last;
 544                         }
 545                 }
 546         }
 547
 548         $self->$logger("Network: " . ($network ? $network : 'None'));
 549
 550         return $network;
 551 };
 552
 553 my $renew_lease_ip4 = sub {
 554         my ($self, $dhcpreq, $network, $req_addr) = @_;
 555         my ($start, $end, $test, $ip, $lease);
 556
 557         my $find_ip_and_lease = sub {
 558                 my ($reqaddr) = @_;
 559
 560                 my @range_str = split(/\s+/, $self->{_config}->{$network}->{range});
 561                 $self->$logger("Range: " . $range_str[0] . " - " . $range_str[1]);
 562                 $start = NetAddr::IP->new($range_str[0]);
 563                 $end = NetAddr::IP->new($range_str[1]);
 564                 $self->$logger(Dumper($start) . Dumper($end));
 565
 566                 if ($reqaddr) {
 567                         my $request = NetAddr::IP->new($reqaddr);
 568                         if ($start <= $request && $request <= $start) {
 569                                 my $nip = $start->addr();
 570                                 $self->$logger("IP: $nip");
 571                                 if ($self->{_leases}->{$nip}) {
 572                                         $lease = $self->{_leases}->{$nip};
 573                                         if ($lease->{'binding state'} eq 'free') {
 574                                                 $ip = $nip;
 575                                                 $lease = $self->$create_new_lease_ip4($dhcpreq, $network, $lease);
 576                                         }
 577                                 }
 578                         }
 579                 } else {
 580                         my $free = undef;
 581                         for (; $start <= $end; $start++) {
 582                                 my $nip = $start->addr();
 583                                 $self->$logger("IP: $nip");
 584                                 if ($self->{_leases}->{$nip} && ! $free) {
 585                                         $lease = $self->{_leases}->{$nip};
 586                                         if ($lease->{'binding state'} eq 'free') {
 587                                                 $free = ();
 588                                                 $free->{$nip} = $lease;
 589                                         }
 590                                 } else {
 591                                         $lease = $self->$create_new_lease_ip4($dhcpreq, $network);
 592                                         $ip = $nip;
 593                                         last;
 594                                 }
 595                         }
 596                         if (! $ip && $free) {
 597                                 ($ip, $lease) = each($free);
 598                                 $lease = $self->$create_new_lease_ip4($dhcpreq, $network, $lease);
 599                         }
 600                 }
 601
 602                 return ($ip, $lease);
 603         };
 604
 605         if ($req_addr) {
 606                 if ($self->{_leases}) {
 607                         $lease = $self->{_leases}->{$req_addr};
 608                         return undef if ($lease && $lease->{'hardware ethernet'} ne $self->$get_mac_ip4($dhcpreq));
 609                         $lease = $self->$create_new_lease_ip4($dhcpreq, $network, $lease);
 610                         $ip = $req_addr;
 611                 } else {
 612                         ($ip, $lease) = $find_ip_and_lease->($req_addr);
 613                 }
 614         } else {
 615                 my $mac = $self->$get_mac_ip4($dhcpreq);
 616                 $self->$logger("MAC: $mac");
 617                 if ($self->{_reverse}->{$mac}) {
 618                         $self->$logger("MAC: $mac IP: " . $self->{_reverse}->{$mac});
 619                         $ip = $self->{_reverse}->{$mac};
 620                         $lease = $self->{_leases}->{$ip};
 621                         $lease = $self->$create_new_lease_ip4($dhcpreq, $network, $lease);
 622                 } else {
 623                         ($ip, $lease) = $find_ip_and_lease->($req_addr);
 624                 }
 625         }
 626
 627         $self->$logger("IP: $ip lease:\n" . Dumper($lease));
 628         if ($ip && $lease) {
 629                 $self->$add_lease($ip, $lease);
 630                 if ($self->{_leases}->{$ip} && $self->{_leases}->{$ip}->{starts} ==     $lease->{starts}) {
 631                         $self->{lease_time} = $DEFAULT_LEASE;
 632                         if ($self->{_config}->{$network}->{ttl}) {
 633                                 $self->{lease_time}     = $self->{_config}->{$network}->{ttl};
 634                         }
 635                         $self->{lease_time_renew} = $DEFAULT_LEASE_RENEW;
 636                         if ($self->{_config}->{$network}->{rttl}) {
 637                                 $self->{lease_time_renew} = $self->{_config}->{$network}->{rttl};
 638                         }
 639                         if ($self->{_config}->{$network}->{netmask}) {
 640                                 $self->{subnet_mask} = $self->{_config}->{$network}->{netmask};
 641                         }
 642                         if ($self->{_config}->{$network}->{router}) {
 643                                 $self->{routers} = $self->{_config}->{$network}->{router};
 644                         }
 645                         if ($self->{_config}->{$network}->{broadcast}) {
 646                                 $self->{broadcast_addr} = $self->{_config}->{$network}->{broadcast};
 647                         }
 648                         if ($self->{_config}->{$network}->{'domain-name'}) {
 649                                 $self->{domain_name} = $self->{_config}->{$network}->{'domain-name'};
 650                         }
 651                         if ($self->{_config}->{$network}->{'dns-servers'}) {
 652                                 $self->{dns_servers} = $self->{_config}->{$network}->{'dns-servers'};
 653                         }
 654                         if ($self->{_config}->{$network}->{'ntp-servers'}) {
 655                                 $self->{ntp_servers} = $self->{_config}->{$network}->{'ntp-servers'};
 656                         }
 657                 } else {
 658                         $ip = undef;
 659                 }
 660         }
 661
 662         return $ip;
 663 };
 664
 665 my $calculate_ip_ip4 = sub {
 666         my ($self, $dhcpreq) = @_;
 667         my ($req_addr, $calc_ip, $network);
 668
 669         return undef unless $dhcpreq->chaddr();
 670         $req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
 671         $network = $self->$calculate_net_ip4($dhcpreq);
 672         return undef unless $network;
 673
 674         if ($self->{_config}->{$network}->{static}) {
 675                 my @static = $self->{_config}->{$network}->{static};
 676                 foreach (@static) {
 677                         my @mac = split(/\s+/, $_);
 678                         if ($mac[0] == $self->$get_mac_ip4($dhcpreq)) {
 679                                 $calc_ip = $mac[1];
 680                                 last;
 681                         }
 682                 }
 683         }
 684         if ($req_addr) {
 685                 if ($calc_ip && $req_addr != $calc_ip) {
 686                         $calc_ip = undef;
 687                 } else {
 688                         $calc_ip = $self->$renew_lease_ip4($dhcpreq, $network, $req_addr);
 689                 }
 690         } else {
 691                 $calc_ip = $self->$renew_lease_ip4($dhcpreq, $network);
 692         }
 693
 694         return $calc_ip;
 695 };
 696
 697 my $discover_ip4 = sub {
 698         my ($self, $dhcpreq) = @_;
 699         my ($res, $dhcpresp, $calc_ip, $req_addr);
 700
 701         # calculate address
 702         # $calc_ip = "192.168.9.2";
 703
 704         $self->$logger("Got request\n".$dhcpreq->toString());
 705
 706         $self->{_sock_out_ip4} = IO::Socket::IP->new(
 707                 Broadcast => 1,
 708                 PeerPort => 68,
 709                 PeerAddr => inet_ntoa(INADDR_BROADCAST),
 710                 Proto    => 'udp'
 711         ) || do {
 712                 my $err = $@;
 713                 $self->$logger("[discover_ip4] Socket creation error: $err", ERROR);
 714                 die "[discover_ip4] Socket creation error: $err\n";
 715         };
 716
 717         $res = $self->$read_lease_file();#$self->read_lease_file();
 718
 719         if ($self->{LOG_LEVEL} <= INFO) {
 720                 $req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
 721                 if ($req_addr) {
 722                         $self->$logger("Requested IP: $req_addr", INFO);
 723                 } else {
 724                         $self->$logger("Requested IP: None", INFO);
 725                 }
 726         }
 727         $calc_ip = $self->$calculate_ip_ip4($dhcpreq);
 728         $self->$logger("Offer: $calc_ip");
 729         if ($calc_ip) {
 730                 $self->$logger("Creating lease for $calc_ip");
 731                 $res = $self->$write_lease_file();
 732         }
 733         if ($res && $calc_ip) {
 734                 $dhcpresp = new Net::DHCP::Packet(
 735                         Comment => $dhcpreq->comment(),
 736                         Op => BOOTREPLY(),
 737                         Hops => $dhcpreq->hops(),
 738                         Xid => $dhcpreq->xid(),
 739                         Flags => $dhcpreq->flags(),
 740                         Ciaddr => $dhcpreq->ciaddr(),
 741                         Yiaddr => $calc_ip,
 742                         Siaddr => $dhcpreq->siaddr(),
 743                         Giaddr => $dhcpreq->giaddr(),
 744                         Chaddr => $dhcpreq->chaddr(),
 745                         DHO_DHCP_MESSAGE_TYPE() => DHCPOFFER(),
 746                         DHO_DHCP_SERVER_IDENTIFIER() => $self->{_sock_out_ip4}->sockhost
 747                 );
 748                 $self->$add_options_ip4($dhcpreq);
 749         } else {
 750                 # bad request, we send a NAK
 751                 $dhcpresp = new Net::DHCP::Packet(
 752                         Comment => $dhcpreq->comment(),
 753                         Op => BOOTREPLY(),
 754                         Hops => $dhcpreq->hops(),
 755                         Xid => $dhcpreq->xid(),
 756                         Flags => $dhcpreq->flags(),
 757                         Ciaddr => $dhcpreq->ciaddr(),
 758                         Yiaddr => "0.0.0.0",
 759                         Siaddr => $dhcpreq->siaddr(),
 760                         Giaddr => $dhcpreq->giaddr(),
 761                         Chaddr => $dhcpreq->chaddr(),
 762                         DHO_DHCP_MESSAGE_TYPE() => DHCPNAK(),
 763                         DHO_DHCP_MESSAGE(), "Bad request...",
 764                 );
 765         }
 766
 767         $self->$logger("Sending response to " .
 768                 $self->{_sock_out_ip4}->peerhost . ':' .
 769                 $self->{_sock_out_ip4}->peerport, INFO);
 770
 771         # Socket object keeps track of whom sent last packet
 772         # so we don't need to specify target address
 773         $self->$logger($dhcpresp->toString());
 774         $self->$logger("Sending OFFER tr=".$dhcpresp->comment(), INFO);
 775         $self->{_sock_out_ip4}->send($dhcpresp->serialize()) || die "Error sending OFFER: $!\n";
 776 };
 777
 778 my $request_ip4 = sub {
 779         my ($self, $dhcpreq) = @_;
 780         my ($calc_ip, $dhcpresp, $peeraddr, $result);
 781
 782         $self->$logger("Got request\n".$dhcpreq->toString());
 783
 784         $peeraddr = $dhcpreq->ciaddr() ? $dhcpreq->ciaddr() : inet_ntoa(INADDR_BROADCAST);
 785         $self->{_sock_out_ip4} = IO::Socket::IP->new(
 786                 Broadcast => 1,
 787                 PeerPort => 68,
 788                 PeerAddr => $peeraddr,
 789                 Proto    => 'udp',
 790         ) || do {
 791                 my $err = $@;
 792                 $self->$logger("[request_ip4] Socket creation error: $err", ERROR);
 793                 die "[request_ip4] Socket creation error: $err\n";
 794         };
 795
 796         my $network = $self->$calculate_net_ip4($dhcpreq);
 797         if ($network) {
 798                 my $req_addr = $dhcpreq->getOptionValue(DHO_DHCP_REQUESTED_ADDRESS());
 799                 $calc_ip = $self->$renew_lease_ip4($dhcpreq, $network, $req_addr);
 800         }
 801
 802         # compare calculated address with requested address
 803         if ($calc_ip) {
 804                 # address is correct, we send an ACK
 805                 $dhcpresp = new Net::DHCP::Packet(
 806                         Comment => $dhcpreq->comment(),
 807                         Op => BOOTREPLY(),
 808                         Hops => $dhcpreq->hops(),
 809                         Xid => $dhcpreq->xid(),
 810                         Flags => $dhcpreq->flags(),
 811                         Ciaddr => $dhcpreq->ciaddr(),
 812                         Yiaddr => $calc_ip,
 813                         Siaddr => $dhcpreq->siaddr(),
 814                         Giaddr => $dhcpreq->giaddr(),
 815                         Chaddr => $dhcpreq->chaddr(),
 816                         DHO_DHCP_MESSAGE_TYPE() => DHCPACK(),
 817                         DHO_DHCP_SERVER_IDENTIFIER() => $self->{_sock_out_ip4}->sockhost,
 818                 );
 819                 $self->$add_options_ip4($dhcpreq);
 820                 $result = 'ACK';
 821         } else {
 822                 # bad request, we send a NAK
 823                 $dhcpresp = new Net::DHCP::Packet(
 824                         Comment => $dhcpreq->comment(),
 825                         Op => BOOTREPLY(),
 826                         Hops => $dhcpreq->hops(),
 827                         Xid => $dhcpreq->xid(),
 828                         Flags => $dhcpreq->flags(),
 829                         Ciaddr => $dhcpreq->ciaddr(),
 830                         Yiaddr => "0.0.0.0",
 831                         Siaddr => $dhcpreq->siaddr(),
 832                         Giaddr => $dhcpreq->giaddr(),
 833                         Chaddr => $dhcpreq->chaddr(),
 834                         DHO_DHCP_MESSAGE_TYPE() => DHCPNAK(),
 835                         DHO_DHCP_MESSAGE(), "Bad request...",
 836                 );
 837                 $result = 'NAK';
 838         }
 839
 840         $self->$logger("Sending response to " .
 841                 $self->{_sock_out_ip4}->peerhost . ':' .
 842                 $self->{_sock_out_ip4}->peerport, INFO);
 843
 844         # Socket object keeps track of whom sent last packet
 845         # so we don't need to specify target address
 846         $self->$logger($dhcpresp->toString());
 847         $self->$logger("Sending $result tr=".$dhcpresp->comment(), INFO);
 848         $self->{_sock_out_ip4}->send($dhcpresp->serialize()) || die "Error sending ACK/NAK: $!\n";
 849 };
 850
 851 my $release_ip4 = sub {
 852         my ($self, $dhcpreq) = @_;
 853         my ($ip, $mac);
 854
 855         $self->$logger($dhcpreq->toString());
 856         $ip = $dhcpreq->ciaddr();
 857         $mac = $self->$get_mac_ip4($dhcpreq);
 858         $self->$logger("Release request for IP: $ip MAC: $mac", INFO);
 859
 860         if ($self->{_leases}->{$ip}) {
 861                 my $lease = $self->{_leases}->{$ip};
 862                 if ($lease->{'hardware ethernet'} eq $mac) {
 863                         $lease->{'binding state'} = 'free';
 864                 }
 865                 $self->$write_lease_file();
 866         }
 867 };
 868
 869 #########################################################################
 870 #  Private methods which handle DHCP6 requests
 871 #########################################################################
 872
 873 my $excuse_me_ip6 = sub {
 874         my ($self, $addr, $dhcpreq) = @_;
 875
 876         $self->$logger("IPv6 request from [$addr]: $dhcpreq", INFO);
 877         $self->{_sock_out_ip6} = IO::Socket::IP->new(
 878                 Domain    => PF_INET6,
 879                 V6Only    => 1,
 880                 Broadcast => 1,
 881                 PeerPort  => 546,
 882                 PeerAddr  => $addr,
 883                 Proto     => 'udp',
 884         ) || do {
 885                 my $err = $@;
 886                 $self->$logger("[excuse_me_ip6] Socket creation error: $err", ERROR);
 887                 die "[excuse_me_ip6] Socket creation error: $err\n";
 888         };
 889         $self->$logger("$addr: Not implemented here", INFO);
 890         $self->{_sock_out_ip6}->send("Not implemented here") || die "Error sending excuse: $!\n";
 891 };
 892
 893 #########################################################################
 894 # Public methods
 895 #########################################################################
 896
 897 # generic signal handler to cause daemon to stop
 898 sub signal_handler {
 899     $time_to_die = 1;
 900 }
 901 $SIG{INT} = $SIG{TERM} = $SIG{HUP} = \&signal_handler;
 902
 903 # ignore any PIPE signal: standard behaviour is to quit process
 904 $SIG{PIPE} = 'IGNORE';
 905
 906 sub new {
 907     my ($class, %self) = @_;
 908
 909     # OOP stuff
 910     $class = ref($class) || $class;
 911     my $self = \%self;
 912     bless $self, $class;
 913
 914         # private
 915     $self->{_sock_in_ip4}               = undef;
 916     $self->{_sock_out_ip4}              = undef;
 917     $self->{_sock_in_ip6}               = undef;
 918     $self->{_sock_out_ip6}              = undef;
 919     $self->{_leases}                    = undef;
 920     $self->{_reverse}                   = undef;
 921     $self->{_config}                    = undef;
 922         $self->{_transaction_ip4}       = 0;
 923         $self->{_transaction_ip6}       = 0;
 924         $self->{_dhpcp_ip4}                     = undef;
 925
 926         # public
 927         $self->{log_file}                       ||= 'syslog';
 928     $self->{lease_time}                 ||= $DEFAULT_LEASE;
 929     $self->{lease_time_renew}   ||= $DEFAULT_LEASE_RENEW;
 930     $self->{subnet_mask}                ||= undef;
 931     $self->{routers}                    ||= undef;
 932     $self->{broadcast_addr}             ||= undef;
 933     $self->{domain_name}                ||= undef;
 934     $self->{dns_servers}                ||= undef;
 935         $self->{ntp_servers}            ||= undef;
 936         $self->{LOG_LEVEL}                      = ERROR unless defined $self->{LOG_LEVEL};
 937         $self->{NODAEMON}                       ||= 0;
 938         $self->{DEBUG}                          ||= 0;
 939         $self->{timeout}                        ||= 10;
 940         $self->{lease_file}                     ||= '/tmp/dhcpd.leases';
 941         $self->{conf_file}                      ||= '/tmp/dhcpd.cfg';
 942
 943     return $self;
 944 }
 945
 946 sub run {
 947         my ($self) = @_;
 948         my ($sel, @ready, $socket, $res);
 949
 950         eval {
 951                 $self->$read_config();
 952         };
 953         if ($@) {
 954                 my $err = $@;
 955                 $self->$logger($err, ERROR);
 956                 die $err;
 957         }
 958         $self->$logger("Starting dhcpd", INFO);
 959         if ($self->{NODAEMON} < 1) {
 960                 $self->$logger("Entering Daemon mode");
 961                 chdir '/'                 or die "Can't chdir to /: $!";
 962                 umask 0;
 963
 964                 open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
 965                 open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
 966                 open STDERR, '>/dev/null' or die "Can't write to /dev/null: $!";
 967
 968                 my $pid = fork;
 969                 exit if $pid;
 970                 do {
 971                         my $err = $!;
 972                         $self->$logger("Couldn't fork: $err", ERROR);
 973                         die "Couldn't fork: $err";
 974                 } unless defined($pid);
 975
 976                 POSIX::setsid() || do {
 977                         my $err = $!;
 978                         $self->$logger("Can't start a new session: $err", ERROR);
 979                         die "Can't start a new session: $err";
 980                 };
 981                 $self->$logger("Now in Daemon mode", INFO);
 982         }
 983
 984         $res = $self->$read_lease_file();
 985         $self->$logger("Starting with empty leases file '$self->{lease_file}'", INFO)
 986                 if (! $res || ! $self->{_leases});
 987
 988         $self->$logger("Initialization complete", INFO);
 989
 990         # open listening socket
 991         $self->{_sock_in_ip4} = IO::Socket::IP->new(
 992                 Domain          => PF_INET,
 993                 LocalPort       => 67,
 994                 LocalAddr       => inet_ntoa(INADDR_ANY),
 995                 Proto           => 'udp'
 996         ) || do {
 997                 my $err = $@;
 998                 $self->$logger("IP4 Socket creation error: $err", ERROR);
 999                 die "IP4 Socket creation error: $err\n";
1000         };
1001         $self->{_sock_in_ip6} = IO::Socket::IP->new(
1002                 Domain          => PF_INET6,
1003                 V6Only          => 1,
1004                 LocalPort       => 547,
1005                 LocalAddr       => '::',
1006                 Proto           => 'udp'
1007         ) || do {
1008                 my $err = $@;
1009                 $self->$logger("IP6 Socket creation error: $err", ERROR);
1010                 die "IP6 Socket creation error: $err\n";
1011         };
1012
1013         $sel = IO::Select->new($self->{_sock_in_ip4});
1014         $sel->add($self->{_sock_in_ip6});
1015
1016         until ($time_to_die) {
1017                 my $buf = undef;
1018                 my $fromaddr;
1019                 my $dhcpreq;
1020
1021                 eval {  # catch fatal errors
1022                         while (@ready = $sel->can_read) {
1023                                 $self->$logger("Waiting for incoming packet", INFO);
1024                                 foreach $socket (@ready) {
1025                                         if ($socket == $self->{_sock_in_ip4}) {
1026                                                 # receive ipv4 packet
1027                                                 $fromaddr = $self->{_sock_in_ip4}->recv($buf, 4096)
1028                                                         || $self->$logger("recv: $!", ERROR);
1029                                                 next if ($!);   # continue loop if an error occured
1030                                                 $self->{_transaction_ip4}++;    # transaction counter
1031
1032                                                 {
1033                                                         use bytes;
1034                                                         my ($port,$addr) = unpack_sockaddr_in($fromaddr);
1035                                                         my $ipaddr = inet_ntoa($addr);
1036                                                         $self->$logger("Got a packet tr=$self->{_transaction_ip4} src=$ipaddr:$port length=".length($buf), INFO);
1037                                                 }
1038
1039                                                 $dhcpreq = new Net::DHCP::Packet($buf);
1040                                                 $dhcpreq->comment($self->{_transaction_ip4});
1041
1042                                                 my $messagetype = $dhcpreq->getOptionValue(DHO_DHCP_MESSAGE_TYPE());
1043
1044                                                 if ($messagetype eq DHCPDISCOVER()) {
1045                                                                 $self->$discover_ip4($dhcpreq);
1046                                                 } elsif ($messagetype eq DHCPREQUEST()) {
1047                                                                 $self->$request_ip4($dhcpreq);
1048                                                 } elsif ($messagetype eq DHCPINFORM()) {
1049                                                         $self->$logger("Not implemented: DHCPINFORM", WARNING);
1050                                                 } elsif ($messagetype eq DHCPRELEASE()) {
1051                                                                 $self->$release_ip4($dhcpreq);
1052                                                 } else {
1053                                                         $self->$logger("Packet dropped", WARNING);
1054                                                         # bad messagetype, we drop it
1055                                                 }
1056                                         } else {
1057                                                 # Receive ipv6 packet
1058                                                 my $myaddr = $self->{_sock_in_ip6}->sockhost;
1059
1060                                                 $fromaddr = $self->{_sock_in_ip6}->recv($buf, 4096)
1061                                                         || $self->$logger("recv: $!", ERROR);
1062                                                 next if ($!);   # continue loop if an error occured
1063                                                 $self->{_transaction_ip6}++;    # transaction counter
1064                                                 $self->$logger("recv: $buf", INFO);
1065                                                 {
1066                                                         use bytes;
1067                                                         my ($port,$addr) = unpack_sockaddr_in6($fromaddr);
1068                                                         my $ipaddr = inet_ntop(AF_INET6, $addr);
1069                                                         $self->$logger("Got a packet tr=$self->{_transaction_ip6} src=$ipaddr:$port length=".length($buf), INFO);
1070                                                 }
1071                                                 $self->$excuse_me_ip6($myaddr, $buf);
1072                                         }
1073                                 }
1074                         }
1075                 };      # end of 'eval' blocks
1076                 if ($@) {
1077                         $self->$logger("Caught error in main loop: $@", ERROR);
1078                 }
1079         }
1080         $self->{_sock_in_ip4}->close;
1081         $self->{_sock_in_ip6}->close;
1082         $self->$logger("Exiting dhcpd", INFO);
1083 }
1084
1085 1;