scripts/named-conf

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use IO::File;
   5 use Data::Dumper;
   6 use POSIX;
   7 use Fcntl qw(:DEFAULT :flock);
   8
   9 use vars qw($quis
  10             $mode $doall $domail
  11             $etcfile $where
  12             $debug $needglue $localonly $repeat $verbosity
  13             $admin $mail_state_dir $mail_max_warnfreq
  14             $progress_fh $warn_fh $modifiers
  15             %group2modcmd %group2used);
  16
  17 $quis= $0; $quis =~ s,.*/,,;
  18
  19 $mode= '';
  20 $doall= 0;
  21 $etcfile= "/etc/bind/chiark-conf-gen.zones";
  22 $where= '<built-in>';
  23 $debug= 0;
  24 $needglue= 1;
  25 $localonly= 0;
  26 $verbosity= 2;
  27 $admin=''; $mail_state_dir=''; $mail_max_warnfreq= 50;
  28 $repeat= 0;
  29 $domail= '';
  30 $progress_fh= 'STDOUT';
  31 $warn_fh= 'STDERR';
  32 $modifiers= '';
  33
  34 use vars qw($dig_owner $dig_type $dig_rdata);
  35
  36 while (@ARGV && $ARGV[0] =~ m/^\-/) {
  37     $_= shift @ARGV;
  38     if (s/^\-\-//) {
  39         last if m/^$/;
  40         if (m/^(yes|no|force)$/) { m/^./; $mode= $&; $domail=''; }
  41         elsif (m/^nothing$/) { $mode= 'x'; $domail=''; }
  42         elsif (m/^mail\-(first|middle|final)/) { $mode='n'; $domail=$1; }
  43         elsif (m/^all$/) { $doall=1; }
  44         elsif (m/^config$/) { $etcfile= loarg(); $where= '--config option'; }
  45         elsif (m/^glueless$/) { $needglue=0; }
  46         elsif (m/^localonly$/) { $localonly=1; }
  47         elsif (m/^quiet$/) { $verbosity--; }
  48         elsif (m/^repeat$/) { $repeat=1; }
  49         elsif (m/^verbose$/) { $verbosity++; }
  50         else { usageerr("unknown option --$_"); }
  51     } else {
  52         s/^\-//;
  53         last if m/^$/;
  54         while (m/^./) {
  55             if (s/^[ynf]//) { $mode=$&; $domail=''; }
  56             elsif (s/^A//) { $doall=1; }
  57             elsif (s/^C//) { $etcfile= soarg(); $where= '-C option'; }
  58             elsif (s/^D//) { $debug++; }
  59             elsif (s/^g//) { $needglue=0; }
  60             elsif (s/^l//) { $localonly=1; }
  61             elsif (s/^m(\w+)(\W+)$//) {
  62                 my ($g,$m) = ($1,$2);
  63                 $group2modcmd{$g}=$m;
  64                 usageerr("modifiers $m for group $g: $@") if bad_modifiers($m);
  65             }
  66             elsif (s/^q//) { $verbosity--; }
  67             elsif (s/^r//) { $repeat=1; }
  68             elsif (s/^v//) { $verbosity++; }
  69             else { usageerr("unknown option -$&"); }
  70         }
  71     }
  72 }
  73
  74 sub loarg() { usageerr("missing option value") if !@ARGV; return shift @ARGV; }
  75 sub soarg() { my ($rv); $rv=$_; $_=''; return length $rv ? $rv : loarg(); }
  76
  77 usageerr("-q may be specified at most twice") if $verbosity<0;
  78 usageerr("-v may be specified at most once") if $verbosity>3;
  79 usageerr("-D may be specified at most twice") if $debug>2;
  80 usageerr("must specify either -f|-y|-n or zones (and not both)")
  81     if !!$mode == !!@ARGV;
  82
  83 sub usageerr ($) {
  84     die <<END;
  85 $_[0]
  86
  87 usage: chiark-named-conf [options] -f|-y|-n|<zone>...
  88 operation modes:
  89  -f --force   install without checking
  90  -y --yes     check and install
  91  -n --no      check only (configured zones)
  92  --nothing    list zones only
  93  --mail-*     send mail about broken zones (see manpage)
  94  <zone> ...   check only (specified zones, even unconfigured ones)
  95 additional options:
  96  -A --all       report on zones marked ? (ones we know are broken)
  97  -D             debug $quis (does not help debug your DNS config)
  98  -g --glueless  do not warn about any glueless referrals (not recommended)
  99  -l --localonly full checks only on zones which we primary
 100  -q --quiet     no output for OK zones
 101  -r --repeat    repeat warnings for all sources of imperfect data
 102  -v --verbose   extra verbose info about each zone
 103  -C|--config <DIR/FILE  use FILE as default config and DIR as default dir
 104
 105 chiark-named-conf is Copyright 2002 Ian Jackson.  It is Free software, under
 106 the GNU General Public License, and you are welcome to change it and/or
 107 distribute copies under certain conditions.  There is ABSOLUTELY NO WARRANTY.
 108 END
 109 }
 110
 111 cfg_fail("config filename $etcfile should not be directory")
 112     if $etcfile =~ m,/$,;
 113
 114 use vars qw($default_dir);
 115 $default_dir= $etcfile =~ m,^.*/, ? $& : './';
 116
 117 use vars qw($slave_dir $slave_prefix $slave_suffix);
 118 $slave_dir= 'slave';
 119 $slave_prefix= '';
 120 $slave_suffix= '';
 121
 122 use vars qw(@self_ns @self_soa @self_addr @forbid_addr @conv_glueless);
 123 @self_ns= @self_soa= @self_addr= @forbid_addr= ();
 124 @conv_glueless= qw(in-addr.arpa ip6.arpa ip6.int);
 125
 126 use vars qw(%zone_cfg @zone_cfg_list);
 127 %zone_cfg= ();
 128 @zone_cfg_list= ();
 129
 130 use vars qw($output $default_output %output_contents);
 131 $output= '';
 132 $default_output= '';
 133 %output_contents= ();
 134
 135 use vars qw($check $install);
 136 $check= $mode !~ m/^[fx]/;
 137 $install= $mode =~ m/^[yf]/;
 138
 139 read_config($etcfile);
 140 debug_dump('@zone_cfg_list %zone_cfg');
 141 process_zones($mode ? @zone_cfg_list : @ARGV);
 142 debug_dump('%output_contents');
 143 output_files() if $install;
 144
 145 exit 0;
 146
 147 #-------------------- configuration reading
 148
 149 sub cfg_fail ($) { die "$quis: $where:\n $_[0]\n"; }
 150
 151 sub read_config ($) {
 152     my ($if) = @_;
 153     my ($fh,$z,@self,$before,$group,
 154         $mod,$dir,$prefix,$suffix,$subfile,$lprefix,$lsuffix,$zf);
 155     local ($_);
 156
 157     $fh= new IO::File $if,'r' or cfg_fail("open $if:\n $!");
 158     $before= '';
 159     for (;;) {
 160         if (!defined($_= <$fh>)) {
 161             cfg_fail("read config file $if:\n $!") if $fh->error();
 162             last;
 163         }
 164         chomp; s/\s+$//;
 165         if (s/\\$//) { $before.= $_; next; }
 166         $_= $before.$_;
 167         $before= '';
 168         s/^\s+//;
 169         $where= "$if:$.";
 170         next if m/^\#/;
 171         last if m/^end$/;
 172         next unless m/\S/;
 173         if (m/^self(\-ns|\-soa|)\s+(\S.*\S)/) {
 174             @self= split /\s+/, $2;
 175             @self_ns= @self if $1 ne '-soa';
 176             @self_soa= @self if $1 ne '-ns';
 177         } elsif (m/^serverless\-glueless\s+(\S.*\S)/) {
 178             @conv_glueless= split /\s+/, $1;
 179         } elsif (m/^self\-addr\s+([0-9. \t]+)/) {
 180             @self_addr= split /\s+/, $1;
 181         } elsif (m/^forbid\-addr(?:\s+([0-9. \t]+))?/) {
 182             @forbid_addr= defined $1 ? split /\s+/, $1 : ();
 183         } elsif (m,^
 184                  primary\-dir (\W*)
 185                  \s+ (\S+)/([^/ \t]*)
 186                  (?: \s+ ([^/ \t]*) (?: (/.+) )?
 187                   )?
 188                  $,x) {
 189             ($mod, $dir, $prefix, $suffix, $subfile) =
 190                 ($1,qualify($2),$3,$4,$5);
 191             cfg_fail("modifiers $mod for directory $dir: $@")
 192                 if bad_modifiers($mod);
 193             $suffix= '' if !defined $suffix;
 194             $subfile= '' if !defined $subfile;
 195             $suffix= '_db' if !length $suffix && !length $subfile;
 196             if (-d "$dir/$prefix") { $dir.='/'; $dir.=$prefix; $prefix=''; }
 197             opendir D, $dir or cfg_fail("open primary-dir $dir:\n $!");
 198             $lprefix= length $prefix; $lsuffix= length $suffix;
 199             while (defined($_= readdir D)) {
 200                 next if m/^\./ && !$lprefix;
 201                 next unless length > $lprefix+$lsuffix;
 202                 next unless substr($_,0,$lprefix) eq $prefix;
 203                 next unless substr($_,length($_)-$lsuffix) eq $suffix;
 204                 $z= substr($_,$lprefix,length($_)-($lprefix+$lsuffix));
 205                 $zf= $dir.'/'.$prefix.$z.$suffix.$subfile;
 206                 if (!stat $zf) {
 207                     next if length $subfile && $! == &ENOENT;
 208                     cfg_fail("cannot stat zonefile $zf:\n $!");
 209                 }
 210                 -f _ or cfg_fail("zonefile $zf is not a plain file");
 211                 zone_conf($z,'primary','p',$mod,$zf);
 212             }
 213             closedir D or cfg_fail("close primary-dir $dir:\n $!");
 214         } elsif (m/^primary(\W*)\s+(\S+)\s+(\S+)$/) {
 215             zone_conf($2,'primary','p',$1,qualify($3));
 216         } elsif (m/^published(\W*)\s+(\S+)\s+([0-9.\t]+)$/) {
 217             zone_conf($2,'published','s',$1,'',$3);
 218         } elsif (m/^stealth(\W*)\s+(\S+)\s+([0-9. \t]+)$/) {
 219             zone_conf($2,'stealth','u',$1,'',split /\s+/, $3);
 220         } elsif (m/^modifiers\s+(\W+)(?:\s+(\w+))$/) {
 221             ($mod,$group) = ($1,$2);
 222             cfg_fail("modifiers $mod for group $group: $@")
 223                 if bad_modifiers($mod);
 224             if (exists $group2modcmd{$group}) {
 225                 $mod= $group2modcmd{$group};
 226                 $group2used{$group}++;
 227             }
 228             $modifiers= $mod;
 229         } elsif (m/^slave\-dir\s+(\S+)(?:(?:\s+(\S+))\s+(\S+))?$/) {
 230             ($slave_dir, $slave_prefix, $slave_suffix) = (qualify($1),$2,$3);
 231             $slave_prefix='' if !defined $slave_prefix;
 232             $slave_suffix='' if !defined $slave_suffix;
 233         } elsif (m/^output\s+bind8\+(\S+)$/) {
 234             cfg_fail("default output may not apply to only some zones")
 235                 if @zone_cfg_list && length $default_output;
 236             set_output(qualify($1));
 237         } elsif (m/^include\s+(\S+)$/) {
 238             read_config($1);
 239         } elsif (m/^admin\s+(\S+)$/) {
 240             $admin=$1;
 241         } elsif (m/^mail\-state\-dir\s+(\S+)$/) {
 242             $mail_state_dir= $1;
 243         } elsif (m/^mail\-max\-warnfreq\s+(\d{1,3}(?:\.\d{0,5})?)$/) {
 244             cfg_fail("mail-max-warnfreq must be <=100") if $1>100;
 245             $mail_max_warnfreq= $1;
 246         } else {
 247             cfg_fail("unknown configuration directive".
 248                      " or incorrect syntax or arguments:\n".
 249                      " \`$_'");
 250         }
 251     }
 252     foreach $group (keys %group2modcmd) {
 253         next if exists $group2used{$group};
 254         cfg_fail("command line specifies modifier group $group".
 255                  " but missing in configuration file");
 256     }
 257     $fh->close or cfg_fail("close config file $if:\n $!");
 258 }
 259
 260 sub qualify ($) {
 261     my ($i) = @_;
 262     $i= "$default_dir$i" unless $i =~ m,^/,;
 263     return $i;
 264 }
 265
 266 sub bad_modifiers ($) {
 267     local ($_) = @_;
 268     if (!eval {
 269         die "bad modifier $&" if m/[^!*\$\@~?]/;
 270         die "repeated modifier $1" if m/(.).*$1/;
 271         1;
 272     }) {
 273         $@ =~ s/\n//;
 274         return 1;
 275     }
 276     return 0;
 277 }
 278
 279 sub zone_conf ($$$$$@) {
 280     my ($zone,$style,$sabbr,$mod,$file,@servers) = @_;
 281     my ($sfx,$aref);
 282     $file= qualify("$slave_dir/$slave_prefix".$zone.$slave_suffix)
 283         unless length $file;
 284     if (!length $output) {
 285         $default_output= qualify('chiark-conf-gen.bind8')
 286             unless length $default_output;
 287         set_output($default_output);
 288     }
 289     cfg_fail("redefined zone $zone\n".
 290              " earlier definition $zone_cfg{$zone}{'where'}")
 291         if exists $zone_cfg{$zone};
 292     $zone_cfg{$zone}{'where'}= $where;
 293     $zone_cfg{$zone}{'file'}= $file;
 294     $zone_cfg{$zone}{'style_p'}= $style.$mod;
 295     $zone_cfg{$zone}{'s'}= "$sabbr $mod $modifiers";
 296     # p)rimary s)econdary u)npub f)oreign
 297     # followed by modifiers, first per-zone, then default
 298     $zone_cfg{$zone}{'servers'}= [ @servers ];
 299     if ($domail) {
 300         length $admin && length $mail_state_dir or
 301             cfg_fail("mailing but failed to specify admin".
 302                      " or mail-state-dir before zone");
 303         $zone_cfg{$zone}{'admin'}= $admin;
 304         $zone_cfg{$zone}{'maildir'}= qualify($mail_state_dir);
 305         $zone_cfg{$zone}{'mailmwarn'}= $mail_max_warnfreq;
 306     }
 307     foreach $sfx (qw(self_soa self_ns self_addr forbid_addr conv_glueless)) {
 308         { no strict 'refs'; $aref= [ @$sfx ]; }
 309         @$aref or cfg_fail("failed to specify $sfx before zone")
 310             if $sfx =~ m/^self/;
 311         $zone_cfg{$zone}{$sfx}= $aref;
 312     }
 313     foreach $sfx (qw(self_soa self_ns)) {
 314         $zone_cfg{$zone}{$sfx} =~ s/\*$/$zone/;
 315     }
 316     $zone_cfg{$zone}{'output'}= $output;
 317     push @zone_cfg_list, $zone;
 318 }
 319
 320 sub set_output($) {
 321     my ($newout) = @_;
 322     $output= $newout;
 323     $output_contents{$output}= '';
 324 }
 325
 326 #-------------------- checking
 327
 328 use vars qw($zone $cfg $warnings %zone_warnings);
 329 $warnings= 0;
 330
 331 sub progress ($$) {
 332     my ($minv,$m) = @_;
 333     return if $verbosity < $minv;
 334     print $progress_fh "$m\n" or die "$quis: $zone: write log: $!\n";
 335 }
 336
 337 sub verbose ($) { progress(3, '    ' . $_[0]); }
 338
 339 sub process_zones (@) {
 340     my (@zones) = @_;
 341     local ($zone,$cfg);
 342
 343     foreach $zone (@zones) {
 344         $cfg= $zone_cfg{$zone} || {
 345             'style_p' => 'foreign',
 346             's' => 'f',
 347             'servers' => [ ],
 348             };
 349
 350         mail_zone_before() if $domail;
 351         zone_reset();
 352         progress(1, sprintf "%-20s %s", $zone, $$cfg{'style_p'});
 353         if ($check && ($doall || !zone_style('?',0))) {
 354             eval {
 355                 if ($localonly && $cfg->{'s'} =~ m/f/) {
 356                     zone_warning("foreign zone specified with -l",'');
 357                 } elsif ($localonly && $cfg->{'s'} !~ m/p/) {
 358                     zone_check_local();
 359                 } else {
 360                     zone_check_full();
 361                 }
 362             };
 363             zone_warning("checks failed: $@",'') if length $@;
 364         }
 365         $output_contents{$$cfg{'output'}} .= zone_output()
 366             if $install;
 367
 368         mail_zone_after() if $domail;
 369     }
 370     if ($domail) {
 371     } elsif ($warnings) {
 372         printf STDERR ("%s: %d warning(s) in %d zone(s);".
 373                        " %d zone(s) checked ok.\n",
 374                        $quis,
 375                        $warnings,
 376                        scalar(keys %zone_warnings),
 377                        scalar(@zones - keys %zone_warnings));
 378     } else {
 379         progress(1, sprintf "%d zone(s) checked ok", scalar @zones);
 380     }
 381 }
 382
 383 use vars qw(%delgs); # $delgs{$nameserver_list} = [ $whosaidandwhy ]
 384 use vars qw(%auths); # $auths{$nameserver_list} = [ $whosaidandwhy ]
 385 use vars qw(%glue);  # $glue{$name}{$addr_list} = [ $whosaidandwhy ]
 386 use vars qw(%soas);  # $soa{"$serial $origin"} = [ $whosaidandwhy ]
 387 use vars qw(%addr_is_ok %warned);
 388 use vars qw($delg_to_us);
 389 use vars qw(@to_check); # ($addr,$whyask,$name_if_auth,$glueless_ok, ...)
 390 use vars qw(@to_check_soa); # ($addr,$whyask,$name,$is_ns, ...)
 391
 392 sub zone_warning ($$) {
 393     my ($w,$o) = @_;
 394     my ($wk);
 395
 396     return 0 if !$repeat && $warned{$w}++;
 397
 398     $w =~ s/\n$//;
 399     $w =~ s,\n, // ,g;
 400
 401     $w .= " ($o)" if length $o;
 402     print $warn_fh "$zone: warning: $w\n" or die $!;
 403     $warnings++;
 404     $zone_warnings{$zone}++;
 405     return 1;
 406 }
 407
 408 sub zone_warnmore ($) {
 409     print $warn_fh "$zone:  $_[0]\n" or die $!;
 410 }
 411
 412 sub zone_check_full () {
 413     zone_investigate();
 414     zone_consistency();
 415     zone_servers_ok();
 416 }
 417
 418 sub zone_reset() {
 419     %delgs= %auths= %glue= %soas= %warned= %addr_is_ok= ();
 420     $delg_to_us= 0;
 421     @to_check= @to_check_soa= ();
 422 }
 423
 424 sub zone_investigate() {
 425     my ($super_zone, @start_nsnames, $start_ww,
 426         $start_ns, @start_ns_addrs, $s, $wa, $name_if_auth,
 427         %nsrrset_checked, %soa_checked, $addr, $glueless_ok,
 428         $rcode, $name, $is_ns);
 429
 430     if (!zone_style('*',0)) {
 431         $super_zone= $zone;
 432         for (;;) {
 433             debug_trace("zone $zone superzone $super_zone");
 434             $super_zone eq '.'
 435                 and die "no superzone ? ($super_zone)\n";
 436             $super_zone =~ s/^[^.]+\.//
 437                 or $super_zone= '.';
 438             ($rcode,@start_nsnames)=
 439                 lookup($super_zone,'ns-','06',"superzone search");
 440             last if !$rcode;
 441         }
 442         $start_ww= "server for $super_zone";
 443     } else {
 444         ($rcode,@start_nsnames)=
 445             lookup($zone,'ns-','0',"initial nameserver search");
 446         $start_ww= "nameserver for $zone";
 447     }
 448     for $start_ns (@start_nsnames) {
 449         $start_ns= lc $start_ns;
 450         ($rcode,@start_ns_addrs)= lookup($start_ns,'a','0',"$start_ww");
 451         foreach $addr (@start_ns_addrs) {
 452             push @to_check, $addr, "$start_ns, $start_ww", undef, 0;
 453         }
 454     }
 455     for (;;) {
 456         # We do these in order so that we always do NS RRset checks on
 457         # nameservers that came from other NS RRsets first; otherwise
 458         # we might set nsrrset_checked due to a glueless_ok check,
 459         # and then not check for gluefulness later.
 460         debug_dump('@to_check @to_check_soa');
 461         if (($addr,$wa,$name_if_auth,$glueless_ok,@to_check) = @to_check) {
 462             push @to_check_soa, $addr, $wa, $name_if_auth, 1,
 463                 if defined $name_if_auth;
 464             next if $nsrrset_checked{$addr}++;
 465             zone_check_nsrrset($addr, $wa, $name_if_auth, $glueless_ok);
 466         } elsif (($addr,$wa,$name,$is_ns,@to_check_soa) = @to_check_soa) {
 467             next if $soa_checked{$addr}++;
 468             zone_check_soa($addr,$wa,$name,$is_ns);
 469         } else {
 470             last;
 471         }
 472     }
 473 }
 474
 475 sub zone_check_nsrrset ($$$$) {
 476     my ($uaddr,$wa, $name_if_auth, $glueless_ok) = @_;
 477     my (@s, $s, $a, %s2g, @glue, $glue, $delgs_or_auths, $wwn, $ww);
 478     my ($rcode);
 479     $ww= "[$uaddr] $wa";
 480     verbose("checking delegation by $ww");
 481     dig(sub {
 482         if ($dig_type eq 'ns' && $dig_owner eq $zone) {
 483             $s2g{lc $dig_rdata} = [ ];
 484         } elsif ($dig_type eq 'a' && exists $s2g{$dig_owner}) {
 485             $wwn= "in glue from $ww";
 486             zone_server_queue($dig_rdata,$dig_owner,$wwn,"NS [$uaddr]",0);
 487             push @{ $s2g{$dig_owner} }, $dig_rdata;
 488         }
 489     },
 490              $zone,'ns',$uaddr);
 491     if (!%s2g) {
 492         zone_warning("unable to find NS RRset at [$uaddr]", $wa);
 493         return;
 494     } elsif (keys %s2g == 1) {
 495         zone_warning("only one nameserver ". (join '', keys %s2g),
 496                      $ww);
 497     }
 498     @s= sort keys %s2g;
 499     foreach $s (@s) {
 500         zone_ns_name($s,$ww);
 501         @glue= @{ $s2g{$s} };
 502         if (!@glue) {
 503             zone_warning("glueless NS $s", $ww)
 504                 unless $glueless_ok || zone_style('~',!$needglue) ||
 505                        grep { has_suffix_of($zone,".$_"); }
 506                            @{ $cfg->{'conv_glueless'} };
 507             ($rcode,@glue)= lookup($s,'a','0',"glueless NS from $ww");
 508             foreach $a (@glue) {
 509                 $wwn= "glueless NS from $ww";
 510                 zone_server_queue($a,$s,$wwn,"NS [$uaddr]",0);
 511             }
 512         }
 513         $glue= join ' ', sort @glue;
 514         push @{ $glue{$s}{$glue} }, $ww;
 515     }
 516     $s= join ' ', @s;
 517     $delgs_or_auths= defined($name_if_auth) ? \%auths : \%delgs;
 518     push @{ $delgs_or_auths->{$s} }, $ww;
 519 }
 520
 521 sub zone_ns_name ($$) {
 522     my ($name,$ww) = @_;
 523     my ($cg);
 524     $delg_to_us=1 if grep { $name eq $_ } @{ $cfg->{'self_ns'} };
 525     foreach $cg (@{ $cfg->{'conv_glueless'} }) {
 526         zone_warning("nameserver $name in serverless-glueless".
 527                      " namespace area $cg",
 528                      $ww)
 529             if has_suffix_of(".$name",".$cg");
 530     }
 531     zone_warning("published server, as $name, but configured as stealth",
 532                  $ww)
 533         if $cfg->{'s'} =~ m/u/ &&
 534            grep { $_ eq $name }
 535                @{ $cfg->{'self_ns'} }, @{ $cfg->{'self_soa'} };
 536 }
 537
 538 sub zone_server_queue ($$$$$) {
 539     my ($addr,$name,$wwn,$wwq,$is_soa) = @_;
 540     zone_server_addr($addr,$name,$wwn,$wwq,$is_soa);
 541     push @to_check, $addr, "$name, $wwn", $name, $is_soa;
 542 }
 543
 544 sub zone_server_addr ($$$$$) {
 545     my ($addr,$name,$ww,$wwq,$is_soa) = @_;
 546     debug_trace("zone_server_addr ".join '|',@_);
 547     $addr_is_ok{$addr}= "$name ($wwq)"
 548         if $is_soa || $cfg->{'s'} =~ m/u/;
 549     zone_warning("forbidden nameserver address [$addr] $name",$ww)
 550         if grep { $_ eq $addr } @{ $cfg->{'forbid_addr'} };
 551
 552     my ($name_is_self, $addr_is_self);
 553     $name_is_self= grep { $_ eq $name }
 554         @{ $cfg->{$is_soa ? 'self_soa' : 'self_ns'} };
 555     $addr_is_self= grep { $_ eq $addr }
 556         @{ $cfg->{'self_addr'} };
 557     if ($name_is_self && !$addr_is_self) {
 558         zone_warning("our $name supplied with wrong address [$addr]", $ww);
 559     }
 560     if (!$name_is_self && $addr_is_self) {
 561         zone_warning("we [$addr] are named in ".
 562                      ($is_soa ? "SOA" : "NS").
 563                      " by wrong name $name",
 564                      $ww);
 565     }
 566     if (!$name_is_self && !$addr_is_self &&
 567         $is_soa && $cfg->{'s'} =~ m/p/) {
 568         zone_warning("SOA ORIGIN $name is not us (".
 569                      (join ' ', @{ $cfg->{'self_soa'} }).")", $ww);
 570     }
 571     $delg_to_us=1 if $addr_is_self && !$is_soa;
 572 }
 573
 574 sub zone_check_soa ($$$$) {
 575     my ($uaddr,$wa,$name,$is_ns) = @_;
 576     my ($lame,$serial,$origin,$got,$rcode,@soa_addrs,$soa_addr,$ww,$wwn);
 577     verbose("checking service at [$uaddr] $name");
 578     $lame= 'dead or lame';
 579     $ww= "[$uaddr] $wa";
 580     dig(sub {
 581         if ($dig_type eq 'flags:') {
 582             $lame= $dig_rdata =~ m/ aa / ? '' : 'lame';
 583         } elsif ($dig_type eq 'soa' && $dig_owner eq $zone && !$lame) {
 584             die "several SOAs ? $ww" if defined $origin;
 585             $got= $dig_rdata;
 586             $got =~ m/^(\d+) (\S+)$/ or die "$got ?";
 587             ($serial,$origin) = ($1,$2);
 588         }
 589     },
 590              $zone,'soa',$uaddr);
 591     $lame= 'broken' if !$lame && !defined $origin;
 592     if ($lame) { zone_warning("$lame server [$uaddr]",$wa); return; }
 593     progress(2, sprintf "%-16s %46s has %s%s",
 594              $zone, "$name [$uaddr]", $serial, $is_ns ? '' : '*');
 595     push @{ $soas{$got} }, $ww;
 596     ($rcode,@soa_addrs)= lookup($origin,'a','0',"SOA ORIGIN");
 597     $wwn= "SOA ORIGIN from $ww";
 598     foreach $soa_addr (@soa_addrs) {
 599         zone_server_queue($soa_addr,$origin,$wwn,"SOA [$uaddr]",1);
 600     }
 601 }
 602
 603 sub zone_consistency() {
 604     my ($d, $org_ser, $origin, $a, $h, $self_soa, $wa);
 605     zone_consistency_set('delegations',\%delgs);
 606     foreach $d (keys %delgs) { delete $auths{$d}; }
 607     zone_consistency_set('zone nameserver rrset',\%auths);
 608     foreach $h (keys %glue) {
 609         zone_consistency_set("glue for $h", $glue{$h});
 610     }
 611     zone_consistency_set("serial number and/or SOA ORIGIN",\%soas);
 612     $self_soa= $cfg->{'self_soa'};
 613 }
 614
 615 sub zone_servers_ok () {
 616     my ($showok,%fs);
 617     if (%addr_is_ok) {
 618         $showok= 0;
 619         foreach $a (@{ $cfg->{'servers'} }) {
 620             next if exists $addr_is_ok{$a};
 621             zone_warning("we slave from [$a]",'')
 622                 and $showok=1;
 623         }
 624         if ($showok) {
 625             foreach $a (keys %addr_is_ok) {
 626                 zone_warnmore("permitted master [$a] $addr_is_ok{$a}");
 627             }
 628         }
 629     }
 630     if ($cfg->{'s'} =~ m/s/ && !$delg_to_us) {
 631         zone_warning("we are supposedly published secondary,".
 632                      " but not listed as a nameserver",'');
 633         map { $fs{$_}=1 } keys(%delgs), keys(%auths);
 634         zone_warnmore("servers are: ". join ' ', sort keys %fs);
 635     }
 636 }
 637
 638 sub zone_consistency_set ($%) {
 639     my ($msg,$set) = @_;
 640     my ($d,$o);
 641     if (keys(%$set) > 1) {
 642         zone_warning("inconsistent $msg:",'');
 643         foreach $d (keys %$set) {
 644             foreach $o (@{ $set->{$d} }) { zone_warnmore(" $d from $o"); }
 645         }
 646     }
 647 }
 648
 649 sub zone_check_local () {
 650     zone_servers_simplefind();
 651     zone_servers_ok();
 652 }
 653
 654 sub zone_servers_simplefind () {
 655     my ($rcode,@nsnames,$ns,@soas,$origin);
 656
 657     ($rcode,@nsnames)= lookup($zone,'ns-','0',"zone's servers");
 658     foreach $ns (@nsnames) {
 659         zone_ns_name($ns,"NS");
 660         zone_server_simple($ns,'NS',0);
 661     }
 662     $delgs{join ' ', sort @nsnames} = [ "zone's servers" ];
 663
 664     ($rcode,@soas)= lookup($zone,'soa','0',"SOA ORIGIN");
 665     die "multiple SOA RRs in set!  @soas ?" if @soas!=1;
 666     $soas[0] =~ m/^(\S+)\s/ or die "SOA ? $_";
 667     zone_server_simple(domain_canon($1,"lookup $zone SOA"),'SOA',1);
 668 }
 669
 670 sub zone_server_simple ($$$) {
 671     my ($name,$ww,$is_soa) = @_;
 672     my ($rcode,@addrs,$addr);
 673     ($rcode,@addrs)= lookup($name,'a','0', "server - ".
 674                             ($is_soa ? "SOA ORIGIN" : "NS"));
 675     foreach $addr (@addrs) { zone_server_addr($addr,$name,$ww,$ww,$is_soa); }
 676 }
 677
 678 sub zone_style ($$) {
 679     my ($stylechar, $default) = @_;
 680     local ($_) = $$cfg{'s'};
 681     $stylechar =~ s/\W/\\$&/ or die;
 682     return m/(\S*)$stylechar/ ? $1 !~ m/\!/ : $default;
 683 }
 684
 685 #-------------------- mailing
 686
 687 use vars qw($m_base $m_lastok @m_ok @m_fail
 688             $m_info $m_time $m_lock $m_m);
 689
 690 sub mail_zone_before () {
 691     my (@s1,@s2);
 692
 693     $m_base= $$cfg{'maildir'}.'/'.$zone;
 694     $m_lastok= '-';
 695     @m_ok= ();
 696     @m_fail= ();
 697
 698     for (;;) {
 699         $m_lock= new IO::File "${m_base}_lock", O_RDWR|O_CREAT, 0600
 700             or die "$quis: create lockfile ${m_base}_lock";
 701         if (!flock($m_lock, LOCK_EX|LOCK_NB)) {
 702             <$m_lock> =~ m/^\d+ /;
 703             die "$quis: $zone: concurrrency? - flock $&$!\n";
 704             $m_lock->close;
 705             next;
 706         }
 707         (@s1= $m_lock->fstat) or die "$quis: fstat ${m_base}_lock: $!\n";
 708         (@s2= stat "${m_base}_lock") or
 709             die "$quis: stat ${m_base}_lock: $!\n";
 710         last if ($s1[0] eq $s2[0] && $s1[1] eq $s2[1]);
 711         $m_lock->close;
 712     }
 713     (print $m_lock "$$        \n" and $m_lock->flush)
 714         or die "$quis: write pid to ${m_base}_lock: $!\n";
 715
 716     if ($m_info= new IO::File "${m_base}_info", 'r') {
 717         $!=0; $_= <$m_info>;
 718         $_ =~ m/\n/ or die "$quis: read ${m_base}_info: $!\n";
 719         m/^\d+ (\d+|-) ([0-9:]*) ([0-9:]*) / or
 720             die "$quis: ${m_base}_info malformed\n";
 721         $m_lastok= $1;
 722         if ($domail ne 'first') {
 723             if ($2 eq ':' && $3 eq ':') {
 724                 warn "$quis: $zone: mid/last run, but last".
 725                     "run already done, ignoring zone\n";
 726                 next;
 727             }
 728             @m_ok= split /\:/, $2;
 729             @m_fail= split /\:/, $3;
 730         }
 731     } elsif ($! != &ENOENT) {
 732         die "$quis: open ${m_base}_info: $!\n";
 733     } elsif ($domail eq 'first') {
 734         warn "$quis: $zone: first run, but not --mail-first,".
 735             " ignoring zone\n";
 736         next;
 737     }
 738     if ($domail eq 'first') {
 739         remove "${m_base}_history" or $!==&ENOENT
 740             or die "$quis: remove ${m_base}_history: $!\n";
 741     }
 742     $progress_fh= $warn_fh= new IO::File "${m_base}_history",'a',0666
 743         or die "$quis: open ${m_base}_history: $!\n";
 744     $m_info= new IO::File "${m_base}_info.tmp",'w',0666
 745         or die "$quis: open ${m_base}_info.tmp: $!\n";
 746
 747     $m_time= time;
 748     progress(-1, "\n".('-'x70)."\n".ptime($m_time)."\n");
 749 }
 750
 751 sub mail_zone_after () {
 752     if ($zone_warnings{$zone}) {
 753         push @m_fail, $m_time;
 754         progress(-1,"failed - $zone_warnings{$zone} warnings");
 755     } else {
 756         push @m_ok, $m_time;
 757         $m_lastok= $m_time;
 758         progress(-1,"everything is fine");
 759     }
 760     close $progress_fh or die "$quis: close ${m_base}_history: $!\n";
 761     $progress_fh= $warn_fh= 'STDERR';
 762
 763     if ($domail eq 'final') {
 764         if (100*@m_fail <= $$cfg{'mailmwarn'}*(@m_fail + @m_ok)) {
 765             printf " %-40s ok\n" or die "$quis: mail ok report: $!\n";
 766         } elsif (zone_style('@',0)) {
 767             printf " %-40s mail suppressed\n"
 768                 or die "$quis: mail suppress report: $!\n";
 769         } else {
 770             mail_zone_mail();
 771         }
 772     }
 773
 774     @m_fail= @m_ok= ('','')
 775         if $domail eq 'final';
 776
 777     printf $m_info "%s %s %s %s \n",
 778         $m_time, $m_lastok, join(':',@m_ok), join(':',@m_fail)
 779             or die "$quis: write new ${m_base}_info: $!\n";
 780     $m_info->close or die "$quis: close new ${m_base}_info: $!\n";
 781     rename "${m_base}_info.tmp", "${m_base}_info"
 782         or die "$quis: install new ${m_base}_info: $!\n";
 783     $m_lock->close;
 784 }
 785
 786
 787 sub pmail ($) {
 788     print $m_m $_[0]
 789         or die "$quis: write ${m_base}_mail: $!\n";
 790 }
 791 sub ptime ($) {
 792     my ($time) = @_;
 793     return gmtime($time)." GMT ($time)";
 794 }
 795
 796 sub mail_zone_mail () {
 797     my ($log, $zone_to, $zterr, $c, $r, $t);
 798     $m_m= new IO::File "${m_base}_mail", 'w', 0666
 799         or die "$quis: create ${m_base}_mail: $!\n";
 800     $zone_to=''; $zterr='';
 801     if (!zone_style("\$",$$cfg{'s'} =~ m/u/)) {
 802         eval {
 803             $_= lookup($zone,'soa','0','problem-addr');
 804             m/\n\n/ and die "multiple soas\n";
 805             m/^\S+ (\S.*\@\S+) [0-9 ]+$/ or
 806                 die "bad soa \`$_'\n";
 807             $zone_to= $1;
 808         };
 809         $zterr= $@;
 810         $zterr =~ s/\n$//;
 811     }
 812     pmail <<END
 813 From: zone check system <$$cfg{'admin'}>
 814 Subject: $zone - configuration problems report
 815 END
 816 ;
 817     pmail("To: ");
 818     pmail("SOA MNAME for $zone <$zone_to>\nCC: ")
 819         if length($zone_to);
 820     pmail($$cfg{'admin'}."\n\n");
 821     pmail <<END
 822 You are receiving this mail because your email address is listed
 823 in the SOA (Start Of Authority) record for $zone
 824 in the DNS, which means you are supposedly the DNS administrator
 825 responsible for this zone.  This report is generated automatically
 826 on behalf of $$cfg{'admin'}, who
 827 is the administrator for a server for the zone.  Please contact
 828 them if you have any problem with this report.
 829
 830 END
 831 if length $zone_to;
 832     pmail <<END
 833 Sent to $$cfg{'admin'} since SOA MNAME unavailable:
 834 $zterr
 835
 836 END
 837 if length $zterr;
 838     pmail <<END
 839 The zone has had configuration errors or persistent operational
 840 problems during recent checks.  See the logs below for details.
 841
 842 Check history for $zone:
 843 END
 844 ;
 845     if ($m_lastok ne '-') {
 846         pmail(" Last seen to be fine: ".ptime($m_lastok)."\n");
 847     } else {
 848         pmail(" No record of this zone ever being fine.\n");
 849     }
 850     for $t (@m_fail) {
 851         pmail(" Errors/warnings at: ".ptime($t)."\n");
 852     }
 853     for $t (@m_ok) {
 854         pmail(" Everything in order at: ".ptime($t)."\n");
 855     }
 856     pmail("\n");
 857     $log= new IO::File "${m_base}_history",'r'
 858         or die "$quis: reopen ${m_base}_history: $!";
 859     undef $/;
 860     pmail($log);
 861     $/= "\n";
 862     $log->error && $log->close
 863         or die "$quis: reread or close ${m_base}_log: $!";
 864     $m_m->close or die "$quis: close ${m_base}_mail: $!\n";
 865     $m_m= new IO::File "${m_base}_mail"
 866         or die "$quis: reopen ${m_base}_mail: $!";
 867
 868     defined($c= fork) or die "$quis: fork for mail: $!\n";
 869     if (!$c) {
 870         open STDIN, "<& ${m_m}" or die "$quis - sendmail: dup for stdin: $!\n";
 871         exec '/usr/sbin/sendmail','-odq','-oee','-oi',
 872             'ijackson@chiark.greenend.org.uk'; # should be -t
 873         die "$quis - sendmail: exec: $!\n";
 874     }
 875     $m_m->close;
 876     $!=0; $r= waitpid $c,0;
 877     $r == $c or die "$quis: waitpid sendmail ($c): $r $!";
 878     $? and warn "$quis: sendmail failed: $?\n";
 879
 880     printf " %-40s %s\n", $zone, $zone_to or
 881         die "$quis: write mailing report: $!\n";
 882 }
 883
 884 #-------------------- outputting
 885
 886 sub zone_output () {
 887     my ($o,$m);
 888
 889     $o= "zone \"$zone\" {\n";
 890     if ($$cfg{'s'} =~ m/p/) {
 891         $o.= "    type master;\n";
 892     } else {
 893         $o.= "    type slave;\n".
 894              "    masters {\n";
 895         foreach $m (@{ $$cfg{'servers'} }) { $o.= "        $m;\n"; }
 896         $o.= "    };\n";
 897     }
 898     $o.= "    file \"$$cfg{'file'}\";\n";
 899     $o.= "};\n";
 900     return $o;
 901 }
 902
 903 sub output_files () {
 904     my ($fn,$ofn,$mfn,$l,$dir, $maxmode,$h,@to_install);
 905
 906     foreach $ofn (keys %output_contents) {
 907         $fn= $ofn; $mfn= "output file $fn";
 908         for (;;) {
 909             if (!lstat $fn) {
 910                 $! == &ENOENT or die "$quis: stat $mfn:\n $!\n";
 911                 $maxmode= 0666;
 912                 last;
 913             } elsif (-f _) {
 914                 $maxmode= (stat _)[2];
 915                 last;
 916             } elsif (-l _) {
 917                 defined($l= readlink $fn)
 918                     or die "$quis: readlink $mfn:\n $!\n";
 919                 $dir= $fn =~ m,^.*/, ? $& : './';
 920                 $fn= "$dir$l" unless $l =~ m,^/,;
 921                 $mfn= "output file $fn (symlink target of $ofn)";
 922             } else {
 923                 die "$quis: output file $mfn exists but is not a file".
 924                     " (or symlink to one)";
 925             }
 926         }
 927         unlink "$fn.new" or $! == &ENOENT or
 928             die "$quis: cannot clear out old .new version of $mfn:\n $!";
 929         $h= new IO::File "$fn.new",'w',$maxmode
 930             or die("$quis: create .new version of $mfn:\n $!");
 931         print $h
 932             "# generated by $quis, do not edit\n",
 933             $output_contents{$ofn}
 934             or die "$quis: write data to .new version of $mfn:\n $!";
 935         $h->close
 936             or die "$quis: close .new version of $mfn:\n $!";
 937         push @to_install, $fn,$mfn;
 938     }
 939
 940     while (($fn,$mfn, @to_install) = @to_install) {
 941         rename "$fn.new",$fn
 942             or die "$quis: install new version of $mfn:\n $!";
 943     }
 944 }
 945
 946 #-------------------- general utilities
 947
 948 sub debug_dump ($) {
 949     my ($vn);
 950     return unless $debug>1;
 951     local $Data::Dumper::Terse=1;
 952     foreach $vn (split /\s+/, $_[0]) {
 953         print "$vn := ", eval "Dumper(\\$vn)";
 954     }
 955 }
 956
 957 sub debug_trace ($) {
 958     return unless $debug;
 959     print "D $_[0]\n";
 960 }
 961
 962 sub has_suffix_of ($$) {
 963     my ($whole,$suffix) = @_;
 964     debug_trace("has_suffix_of $whole $suffix");
 965     return 0 if length $whole < length $suffix;
 966     return 0 if substr($whole, length($whole) - length($suffix)) ne $suffix;
 967     debug_trace("has_suffix_of $whole $suffix YES");
 968     return 1;
 969 }
 970
 971 sub lookup ($$$$) {
 972     my ($domain,$type,$okrcodes,$w) = @_;
 973     my ($c,$h,@result);
 974     debug_trace("lookup ==> (->$okrcodes) $domain $type");
 975     $h= new IO::Handle;
 976
 977     defined($c= open $h, "-|") or die "$quis: fork adnshost:\n $!\n";
 978     if (!$c) {
 979         exec 'adnshost','-Fi','+Do','+Dt','+Dc','-Cf',"-t$type",
 980              '-',"$domain";
 981         die "$quis: exec adnshost:\n $!\n";
 982     }
 983     @result= $h->getlines();
 984     $h->error and die "$quis: read from adnshost:\n $!\n";
 985     chomp @result;
 986     $!=0; $h->close;
 987     die "$quis: lookup -t$type $domain $okrcodes ($w) failed $? $! @result\n"
 988         if $! or $?&255 or $?>1536 or index($okrcodes,$?>>8)<0;
 989     debug_trace("lookup <== $? @result");
 990     return ($?,@result);
 991 }
 992
 993 sub dig (&$$$) {
 994     my ($eachrr, $qowner,$qtype,$qaddr) = @_;
 995     # also pseudo-rr with type `flags:'
 996     my ($h,$inmid,$irdata,$c,$digwhy);
 997     local ($_);
 998
 999     debug_trace("dig ==> \@$qaddr $qowner $qtype");
1000
1001     $h= new IO::Handle;
1002     defined($c= open $h, "-|") or die "$quis: fork dig:\n $!\n";
1003     if (!$c) {
1004         open STDERR, ">&STDOUT" or die $!;
1005         exec ('dig',
1006               '+nodef','+nosea','+nodebug','+norecurse',
1007               "\@$qaddr",'-t',$qtype,$qowner);
1008         die "$quis: exec dig:\n $!\n";
1009     }
1010     $inmid='';
1011     for (;;) {
1012         if (!defined($_= $h->getline())) {
1013             $h->error() and die "$quis: read from dig:\n $!\n";
1014             last;
1015         }
1016         chomp;
1017         if (length $inmid) {
1018             s/^\s+/ / or die "$inmid // $_ ?";
1019             s/\;.*$//;
1020             $_= $inmid.$_;
1021             $inmid='';
1022             s/$/ \(/ unless s/\s*\)\s*$//;
1023         }
1024         if (s/\s*\(\s*$//) { $inmid= $_; next; }
1025         $digwhy= "dig $qowner $qtype $qaddr \`$_'";
1026         if (m/^\;\; flags\:( [-0-9a-z ]+)\;/) {
1027             $dig_owner=''; $dig_type='flags:'; $dig_rdata= "$1 ";
1028             debug_trace("dig  f: $dig_rdata");
1029             &$eachrr;
1030         } elsif (m/^\;/) {
1031         } elsif (!m/\S/) {
1032         } elsif (m/^([-.0-9a-z]+)\s+\d\w+\s+in\s+([a-z]+)\s+(\S.*)/i) {
1033             $dig_owner=domain_canon($1,$digwhy); $dig_type=lc $2; $irdata=$3;
1034             if ($dig_type eq 'a') {
1035                 $irdata =~ m/^[.0-9]+$/ or die "$irdata ?";
1036                 $dig_rdata= $&;
1037             } elsif ($dig_type eq 'ns') {
1038                 $irdata =~ m/^[-.0-9a-z]+$/i or die "bad nameserver $irdata ?";
1039                 $dig_rdata= domain_canon($irdata,$digwhy);
1040             } elsif ($dig_type eq 'soa') {
1041                 $irdata =~ m/^([-.0-9a-z]+)\s+.*\s+(\d+)(?:\s+\d\w+){4}$/i
1042                     or die "bad SOA $irdata ?";
1043                 $dig_rdata= $2.' '.domain_canon($1,$digwhy);
1044             } else {
1045                 debug_trace("ignoring uknown RR type $dig_type");
1046                 next;
1047             }
1048             debug_trace("dig  $dig_owner $dig_type $dig_rdata");
1049             &$eachrr;
1050         } else {
1051             debug_trace("ignoring unknown dig output $_");
1052         }
1053     }
1054     $h->close;
1055     debug_trace("dig <== gave $?");
1056 }
1057
1058 sub domain_canon ($$) {
1059     my ($i,$w) = @_;
1060     $i =~ s/(.)\.$/$1/;
1061     return '.' if $i eq '.';
1062     die "domain $i ($w) ?" unless $i =~ m/^[0-9a-z]/i;
1063     return lc $i;
1064 }