#!/usr/bin/perl

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell
#
# Copyright 2004-2007 SPARTA, Inc.  All rights reserved.  See the COPYING
# file distributed with this software for details
#

#use strict;

use Net::DNS;
use Net::DNS::SEC::Tools::conf;
use Net::DNS::SEC::Validator;
use Net::DNS::Packet;
use Net::SMTP;
use Getopt::Long qw(:config no_ignore_case_always);
use Sys::Syslog;
use IO::File;
use POSIX;
use Data::Dumper;
$Data::Dumper::Purity = 1;

#
# Detect required Perl modules.
#
use Net::DNS::SEC::Tools::BootStrap;
dnssec_tools_load_mods('Date::Parse'	=> "",
		       'Net::DNS::SEC'  => "");

########################################################
# Defaults

my %opts = (
        t => 3600, # default to one hour
        v => 1,
        c => 0
);

########################################################
# main

# Parse command-line options
GetOptions(\%opts,
             'a|anchor_data_file=s',
             'c|config',
             'd|domain=s',
             'f|foreground|fg',
             'k|dnsval_conf_file=s',
             'h|help',
             'L|syslog',
             'm|mail_contact_addr=s',
             'n|named_conf_file=s',
             'N|no_error',
             'o|outfile=s',
             'p|print',
             'r|resolv_conf_file=s',
             's|smtp_server=s',
             'S|single_run',
             't|sleeptime=i',
             'v|verbose',
             'V|version',
             'w|hold_time=s',
             'persistent_data_file=s',
           );

if ($opts{'h'}) {
    usage();
}

# Parse the dnssec-tools.conf file
my %dtconf = parseconfig();

# then $dtconf{'name_of_option_in_dnssec-tools.conf'}
# contains the value of that option as set in the conf file

#my $tafile = $opts{'a'} ? $opts{'a'} 
my $newkeyfile = $opts{'a'} ? $opts{'a'} 
                        : $dtconf{'taanchorfile'};
                     
my $resfile = $opts{'r'} ? $opts{'r'}
                        : $dtconf{'taresolvconffile'};

my $ncfile = $opts{'n'} ? $opts{'n'}
                        : $dtconf{'tanamedconffile'};

my $dvfile = $opts{'k'} ? $opts{'k'}
                        : $dtconf{'tadnsvalconffile'};

my $contactaddr = $opts{'m'} ? $opts{'m'}
                             : $dtconf{'tacontact'};

my $smtpserver =  $opts{'s'} ? $opts{'s'}
                             : $dtconf{'tasmtpserver'};

#my $newkeyfile = $opts{'persistent_data_file'} ? $opts{'persistent_data_file'}
#                             : "/usr/local/etc/dnssec-tools/newkey.perldata";

#if ($opts{'persistent_data_file'}) {
#    $newkeyfile = $opts{'persistent_data_file'};
#} else { 
#    print STDERR "Proceeding with no persistent data file defined.\n";
#    print STDERR "This means that pending key data will not be saved in case \n";
#    print STDERR "trustman is restarted, and pending key hold times start over.\n";
#}

if ($dvfile && $ncfile) {
    usage(2);
}

if (!$smtpserver) {
    print "smtpserver is undefined\n";
}

my $sleeptime = $opts{'t'} ? $opts{'t'}
                           : $dtconf{'tasleeptime'};

my $holdtime = $opts{'w'} ? $opts{'w'}
                           : $dtconf{'taholdtime'};

my $initrun = 1;
my @domains;
push @domains, split(/,/,$opts{'d'}) if ($opts{'d'});
my %revdomains;
for (my $i = 0; $i <=$#domains; $i++) {
    $revdomains{$domains[$i]} = $i;
}

my %keystorage;

my %newkeys;
load_newkeys();

my %remkeys;

my %sleeptimes;
my %active_refresh_times;

my %zone_configfile_map;
my $once;

# my $revoke = 1;
my $revoke = 0;

if ((!$contactaddr) && (!$opts{'L'}) && (!$opts{'p'})) {
    usage();
}

if ($opts{'f'}) {
    $once = $opts{'S'};
    get_domains_keys(\%keystorage);
    do {
        my $newsleeptime = &checkkeys($sleeptime);
        if (!$once) {
            sleep($newsleeptime);
        }
    } while (!$once);
} elsif ($opts{'c'}) {
    my $conffile = getconffile();
    my $didnconf = 0;
    my $didvconf = 0;
    my $didtime = 0;
    my $didcontact = 0;
    my $didsmtp = 0;
    open(CONF,$conffile) or die "unable to open \"$conffile\".";
    usage () unless $opts{'o'};
    open(OUT,">$opts{'o'}") or die "unable to open \"$opts{'o'}\" for writing.";
    while(<CONF>) {
        next if (/^tasleeptime/ && ($opts{'t'}));
        next if (/^tasholdime/ && ($opts{'w'}));
        next if (/^tasmtpserver/ && ($opts{'s'}));
        next if (/^tacontact/ && ($opts{'m'}));
        next if (/^taresolvconffile/ && ($opts{'r'}));
        next if (/^tanamedconffile/ && ($opts{'n'}));
        next if (/^tadnsvalconffile/ && ($opts{'k'}));
        print OUT $_;
    }
    if ($opts{'t'}) {
        print OUT "tasleeptime\t" . $sleeptime . "\n";
    }
    if ($opts{'w'}) {
        print OUT "taholdtime\t" . $holdtime . "\n";
    }
    if ($opts{'s'}) {
        print OUT "tasmtpserver\t" . $smtpserver . "\n";
    }
    if ($opts{'m'}) {
        print OUT "tacontact\t" . $contactaddr . "\n";
    }
    if ($opts{'r'}) {
        print OUT "taresolvconffile\t" . $resfile . "\n";
    }
    if ($opts{'n'}) {
        print OUT "tanamedconffile\t" . $ncfile . "\n";
    }
    if ($opts{'k'}) {
        print OUT "tadnsvalconffile\t" . $dvfile . "\n";
    }
    close (OUT);
    close (CONF);

} else {
    $once = $opts{'S'};
    get_domains_keys(\%keystorage);
    &daemonize;
    do {
        my $newsleeptime = &checkkeys($sleeptime);
        if (!$once) { 
            sleep($newsleeptime);
        }
    } while (!$once);
} 

sub load_newkeys {
    # load in the newkeys info from file if available
    open (FILE, "< $newkeyfile") or warn "can't open newkey file: $!";
    my $undefval = $/;
    undef $/;
    eval <FILE>;
    warn "can't recreate newkey data from file: $@" if $@;
    close FILE;
    $/ = $undefval;
}

sub show_version {
    print STDERR "Version: 1.0\n";
    print STDERR "DNSSEC-Tools Version: 1.2\n";
    exit(1);
}

sub usage {
    my $arg = @_;
    if ($arg) {
        print "trustman takes only one config file argument.\n";
        print "please indicate EITHER a dnsval.conf file OR a named.conf file.\n";
    }
    print "trustman [-d domain] [-L] [-f] [-c -o] [-v] [-V]\n";
    print "\tuse the -f option to run in the foreground.\n";
#    print "\t[-o outfile] [-m mailcontact] [-s smtpserver]";
#    print "\t[-t secs] [-n named_conf_file] [-k dnsval_conf_file]";
#    print "\tUse -L to log to syslog; this can be in addition to mail.\n";
    print "\tIf a domain is not specified, all domains in the key_containing_files will be checked.\n";
    print "\tIf no key_containing_files are specified, dnssec-tools.conf will be
parsed for appropriate files.\n";
    print "\tWhen running the configure option (-c or --config), you MUST specify an output file (-o).\n";
    exit(1);
}

sub checkkeys {
    my $sleep = shift;

    my %keys_to_verify;
    foreach my $k (keys %keystorage) {
        @{$keys_to_verify{$k}} = @{$keystorage{$k}};
    }

    my $domains_to_check;

    foreach my $d (@domains) {
    # check all domains to see if $active_refresh_times{$d} has been reached
         my $now = localtime();
         my $nowsecs = str2time($now);
         if ($nowsecs >= $active_refresh_times{$d}) {
             push @domains_to_check, $d;
         } elsif ($initrun) { # first time through, check all domains
             push @domains_to_check, $d;
         }
    }

    foreach my $d (@domains_to_check) {
        my $query;
        $query = resolve_and_check_dnskey($d,$dvfile);
        my %pendingnewkeys;
        if (keys %newkeys) {
            for (my $i = 0; $i <= $#{$newkeys{$d}}; $i++) {
                my $pendingkeyobj = { flags => $newkeys{$d}[$i]{flags},
                                      protocol => $newkeys{$d}[$i]{protocol},
                                      algorithm => $newkeys{$d}[$i]{algorithm},
                                      key => $newkeys{$d}[$i]{key},
                                      found => 0,
                                    };
                push (@{$pendingnewkeys{$d}}, $pendingkeyobj);
            }
        }

# check the RRSIG over the DNKSEY
        if ($query) {
            foreach my $rrsigrec (grep { $_->type eq 'RRSIG' } $query->answer) {
                 
                 my $orgttl = $rrsigrec->orgttl;
                 my $sigexp = $rrsigrec->sigexpiration;
                 my ($refresh_secs,$refresh_time) = compute_sleepsecs($orgttl, $sigexp);
                 $sleeptimes{$d} =  $refresh_secs;
                 $active_refresh_times{$d} = $refresh_time;
                 last; # only need one sleep time per domain
            }
# if an RRSET is received which does NOT contain a pending
# new key, remove that new key from the %newkeys
            foreach my $keyrec (grep { $_->type eq 'DNSKEY' } $query->answer) {
                next if (!($keyrec->flags & 1));
                my $ttl = $keyrec->ttl;
                my $key = $keyrec->key;
                $key =~ s/\s+//g; # remove all spaces   
                my $nonmatch;
                # we don't care if a DNSKEY record is found with the
                # revoke bit set unless it is a key we have stored
                # so check for a match first
                $nonmatch = compare_keys(\%keystorage, $d, $keyrec, $key);
                if ($nonmatch) {
                # may be a new key, remember it.
                # check if this key is already in %newkeys

                # also need to find any keys in %newkeys which do
                # NOT appear in a subsequent RRSET
 
                    my $notnewkey = 0;
                    if (keys %newkeys) {
                        for (my $i = 0; $i <= $#{$newkeys{$d}}; $i++) {
                            if ($newkeys{$d}[$i]{key} eq $key &&
                                $newkeys{$d}[$i]{flags} eq $keyrec->flags &&
                                $newkeys{$d}[$i]{protocol} eq $keyrec->protocol &&
                                $newkeys{$d}[$i]{algorithm} eq $keyrec->algorithm ) 
                            {
                                $notnewkey = 1;
                                if (keys %pendingnewkeys) {
                                    for (my $i = 0; $i <= $#{$pendingnewkeys{$d}}; $i++) {
                                        if ($pendingnewkeys{$d}[$i]{key} eq $key &&
                                            $pendingnewkeys{$d}[$i]{flags} eq $keyrec->flags &&
                                            $pendingnewkeys{$d}[$i]{protocol} eq $keyrec->protocol &&
                                            $pendingnewkeys{$d}[$i]{algorithm} eq $keyrec->algorithm ) {
                                            $pendingnewkeys{$d}[$i]{found} = 1;
                                        }
                                    }
                                }
                            
                            }
                        }
                    }
                    if (!$notnewkey) {
                    
                        if ($holdtime) {
                            $add_holddown_time = $holdtime;
                        } else {
                            $add_holddown_time = compute_add_holddown($ttl);
                        }
                        my $newkeyobj = { flags => $keyrec->flags,
                                          protocol => $keyrec->protocol,
                                          algorithm => $keyrec->algorithm,
                                          key => $key,
                                          holdtime => $add_holddown_time,
                                        };
                        push(@{$newkeys{$d}},$newkeyobj);
                        # whenever newkeys is modified, write it out
                        open (FILE, "> $newkeyfile") 
                            or warn "can't open newkeys file: $!";
                        print FILE 
                            Data::Dumper->Dump([\%newkeys], ['*newkeys']);
                        close FILE or warn "can't close newkeys file: $!";
                    }
#                } elsif ($keyrec->REVOKE == 1) {
                # see if it has the revoke bit set
                } elsif ($revoke == 1) {
                    # this key is being revoked
                    if ($dvfile) {
                        revoke_ta_dnsvalconf($d,$keyrec);
                    }
                    if ($ncfile) {
                        revoke_ta_namedconf($d,$keyrec);
                    }

# verify that ALL keys in %keystorage (now %keys_to_verify) were matched.
# if a known key disappears, set its remove_holddown timer for
# removal if it doesn't reappear in time
                } else {
                # if this is neither a new key, nor a revoked key
                # if it is a configured trust anchor, delete it from
                # the keys_to_verify structure so we know it is not
                # "removed"

                    for (my $i = 0; $i <= $#{$keys_to_verify{$d}}; $i++) {
                        if ($keys_to_verify{$d}[$i]{key} eq $key &&
                            $keys_to_verify{$d}[$i]{flags} eq $keyrec->flags &&
                            $keys_to_verify{$d}[$i]{protocol} eq $keyrec->protocol &&
                            $keys_to_verify{$d}[$i]{algorithm} eq $keyrec->algorithm ) {
                            splice @{$keys_to_verify{$d}},$i,1;
                        }
                    }
                    # if it appears in the %remkeys struct, since it has
                    # now reappeared, remove it from remkeys
                    if (keys %remkeys) {
                        for (my $i = 0; $i <= $#{$remkeys{$d}}; $i++) {
                            if ($remkeys{$d}[$i]{key} eq $key &&
                                $remkeys{$d}[$i]{flags} eq $keyrec->flags &&
                                $remkeys{$d}[$i]{protocol} eq $keyrec->protocol &&
                                $remkeys{$d}[$i]{algorithm} eq $keyrec->algorithm ){
                                splice @{$remkeys{$d}},$i,1;
                            }
                        }
                    }

                }

            }
            
# only want to remove pending keys which do not appear in this
# RRSET if the query was successful. Will deal with the unsuccessful
# query below

            for (my $k = 0; $k <= $#{$pendingnewkeys{$d}}; $k++) {
                # any pending key still not marked found should be
                # removed from %newkeys
                if (!$pendingnewkeys{$d}[$k]{found}) {
                    for (my $j = 0; $j <= $#{$newkeys{$d}}; $j++) {
                      # find the entry in newkeys that corresponds to
                      # the pending key not found
                        if ($newkeys{$d}[$j]{key} eq 
                            $pendingnewkeys{$d}[$k]{key} &&
                            $newkeys{$d}[$j]{flags} eq
                            $pendingnewkeys{$d}[$k]{flags} &&
                            $newkeys{$d}[$j]{protocol} eq
                            $pendingnewkeys{$d}[$k]{protocol} &&
                            $newkeys{$d}[$j]{algorithm} eq
                            $pendingnewkeys{$d}[$k]{algorithm} ) {
                            splice @{$newkeys{$d}},$j,1;
                            # whenever newkeys is modified, write it out
                            open (FILE, "> $newkeyfile")
                                or warn "can't open newkeys: $!";
                            print FILE
                                Data::Dumper->Dump([\%newkeys], ['*newkeys']);
                            close FILE or warn "can't close newkeys file: $!";

                        }
                    }
                }
            }
        } else {
            print "query failed for domain " . $d . "\n";
            $refresh_secs = compute_queryfail_sleepsecs(0,0);
            $sleeptimes{$d} =  $refresh_secs;
        }
    }

# all domains have been queried, and queries have been processed

    if (%newkeys) {
        my @newkeydomains;

        # if add_holddown_time has been reached, notify

        my $now = localtime();
        my $nowsecs = str2time($now);

        foreach my $d (keys %newkeys) {
            for (my $i = 0; $i <= $#{$newkeys{$d}}; $i++) {
                if ($nowsecs >= $newkeys{$d}[$i]{holdtime}) {
                    # notify about this key
                    push @newkeydomains, $d;
                }
            }
        }
        foreach my $d (@newkeydomains) {
        # these are all domains for which new keys have reached their
        # add holddown time. add these keys as new trust anchors
        # to the appropriate config files
            if ($zone_configfile_map{$d} eq $ncfile) {
                add_ta_namedconf($d);
            }
            if ($zone_configfile_map{$d} eq $dvfile) {
                add_ta_dnsvalconf($d);
            }
        # now that this key has been added to the appropriate
        # config file(s), put it in keystorage and remove it
        # from newkeys
            for (my $i =0; $i <= $#{$newkeys{$d}}; $i++) {
                my $newstorageobj = { flags => $newkeys{$d}[$i]{flags},
                                      protocol => $newkeys{$d}[$i]{protocol},
                                      algorithm => $newkeys{$d}[$i]{algorithm},
                                      key => $newkeys{$d}[$i]{key},
                                    };
                push (@{$keystorage{$d}}, $newstorageobj);

                splice @{$newkeys{$d}},$i,1; 
                # whenever newkeys is modified, write it out
                open (FILE, "> $newkeyfile") 
                    or warn "can't open newkeys: $!";
                print FILE 
                    Data::Dumper->Dump([\%newkeys], ['*newkeys']);
                close FILE or warn "can't close newkeys file: $!";
            }
        }
#        if (($contactaddr) && (@newkeydomains)) { # mail it
#            mailcontact(0,$smtpserver,$contactaddr,@newkeydomains);
#        }
        
    }

    if (keys %remkeys) {
    # see if any remkeys have reached their holdtimes
    # if so, remove them from the config file
        my $now = localtime();
        my $nowsecs = str2time($now);

        foreach my $d (keys %remkeys) {
            for (my $i = 0; $i <= $#{$remkeys{$d}}; $i++) {
                if ($nowsecs >= $remkeys{$d}[$i]{holdtime}) {
                # mark this for deletion
                    if ($zone_configfile_map{$d} eq $ncfile) {
                        remove_ta_namedconf($d, $remkeys{$d}[$i]{key},
                                            $remkeys{$d}[$i]{flags},
                                            $remkeys{$d}[$i]{protocol},
                                            $remkeys{$d}[$i]{algorithm});
                    }
                    if ($zone_configfile_map{$d} eq $dvfile) {
                        remove_ta_dnsvalconf($d, $remkeys{$d}[$i]{key},
                                            $remkeys{$d}[$i]{flags},
                                            $remkeys{$d}[$i]{protocol},
                                            $remkeys{$d}[$i]{algorithm});
                    }
                }
            }
        }
    }

    foreach my $d (keys %keys_to_verify) {
    # any domains/keys still in %keys_to_verify did not appear
    # in a query, but are configured trust anchors. 
    # Set the remove holddown time (30 days) for these keys
    # and add to remkeys for processing on next go
        my $remove_holddown_time = compute_remove_holddown();
        for (my $i = 0; $i <= $#{$keys_to_verify{$d}}; $i++) {
            my $remkeyobj = { flags => $keys_to_verify{$d}[$i]{flags},
                              protocol => $keys_to_verify{$d}[$i]{protocol},
                              algorithm => $keys_to_verify{$d}[$i]{algorithm},
                              key => $keys_to_verify{$d}[$i]{key},
                              holdtime => $remove_holddown_time,
                            };
            push (@{$remkeys{$d}},$remkeyobj);
        }
    }

    $initrun = 0;

    foreach my $d (keys %sleeptimes) {
        if ($sleep > $sleeptimes{$d} &&
            $sleeptimes{$d} > 0) {
            $sleep = $sleeptimes{$d};
        }
        # otherwise, just leaving the current $sleep
    }
    return $sleep;
        
} # end checkkeys

sub add_ta_namedconf  {
    my $domain = @_;
    open (TMP, ">/tmp/named.conf.tmp") or die "unable to open temp file.";
    open (CONF,$ncfile) or die "unable to read named.conf file.";
    while (<CONF>) {
        print TMP $_;
        if (/^trusted-keys/) {
            print TMP "\n\n";
            for (my $i =0; $i <= $#{$newkeys{$domain}}; $i++) {
                my $newkey = $domain . " " . 
                             $newkeys{$domain}[$i]{flags} . " " .
                             $newkeys{$domain}[$i]{protocol} . " " .
                             $newkeys{$domain}[$i]{algorithm} . " " .
                             $newkeys{$domain}[$i]{key} . "\";\n";
                print TMP $newkey;
            }
        }
    }
    close (CONF);
    close (TMP);
# rename TMP to $ncfile
    my $origname = $ncfile . ".orig";
    rename ($ncfile,$origname);
    rename ("/tmp/named.conf.tmp",$ncfile);

}

sub add_ta_dnsvalconf  {
    my ($domain) = @_;

    my $pat = "trust-anchor";

    open (TMP, ">/tmp/dnsval.conf.tmp") or die "unable to open temp file.";
    open (CONF,$dvfile) or die "unable to read dnsval.conf file.";
    $/ = ";";
    while (<CONF>) {
        my $domainfound = 0;
        s/\s;\s*$//;
        if (s/^\s*(\S*)\s*$pat\s*//) {
            print TMP $1 . " $pat\n\n";
            while ($_ ne '' && s/^\s*(\S+)\s+("*[^"]+"|\S+)\s*//) {
                my ($d, $val) = ($1, $2);
                # strip off the trailing dot from the domainname
                $d =~ s/\.$//;
                $val =~ s/[\n\r]//g;
                if ($d eq $domain) {
                    $domainfound = 1;
                }
                # add the trailing dot when printing domainname
                print TMP $d . ". " . $val . "\n\n";
            }

            for (my $i =0; $i <= $#{$newkeys{$domain}}; $i++) {
                my $newkeyentry = $domain . ". \"" . 
                             $newkeys{$domain}[$i]{flags} . " " .
                             $newkeys{$domain}[$i]{protocol} . " " .
                             $newkeys{$domain}[$i]{algorithm} . " " .
                             $newkeys{$domain}[$i]{key} . "\"";
                if ($domainfound) {
                    print TMP $newkeyentry . $2;
                    print "Adding following key to $dvfile:\n";
                    print $newkeyentry . "\n";
                }
            }
            print TMP "\n;\n";
        } else {
            print TMP $_;
        }
    }
    close (CONF);
    close (TMP);
# rename TMP to $dvfile
    my $origname = $dvfile . ".orig";
    rename ($dvfile,$origname);
    rename ("/tmp/dnsval.conf.tmp",$dvfile);
}

sub remove_ta_dnsvalconf {
    my ($domain, $k, $f, $p, $a) = @_;

    my $pat = "trust-anchor";

    open (TMP, ">/tmp/dnsval.conf.tmp") or die "unable to open temp file.";
    open (CONF,$dvfile) or die "unable to read dnsval.conf file.";
    my $origsep = $/;
    $/ = ";";
    while (<CONF>) {
        s/\s;\s*$//;
        if (s/^\s*(\S*)\s*$pat\s*//) {
            print TMP $1 . " $pat\n\n";
            while ($_ ne '' && s/^\s*(\S+)\s+("*[^"]+"|\S+)\s*//) {
                my ($d, $val) = ($1, $2);
                # strip off the trailing dot from the domainname
                $d =~ s/\.$//;
                $val =~ s/[\n\r]//g;
                if ($d eq $domain) {
                    my ($flags, $protocol, $algorithm, $key) = $val =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S[^"]+)/;
                    $key =~ s/\s+//g;
                    $k =~ s/[\n\r]//g;
                    if ($k eq $key &&
                        $f eq $flags &&
                        $p eq $protocol &&
                        $a eq $algorithm) {
# its a match, comment it out
                        print TMP "# The following key has been removed.\n";
                        my $remkeyrec = $d . ". " . $val;
                        print TMP "# " . $remkeyrec . "\n\n";
                    } else {
                        # add the trailing dot when printing domainname
                        print TMP $d . ". " . $val . "\n\n";
                    }

                } else {
                    # add the trailing dot when printing domainname
                    print TMP $d . ". " . $val . "\n\n";
                }
            }
            print TMP "\n;\n";
        } else {
            print TMP $_;
        }
    }
    close (CONF);
    close (TMP);
    $/ = $origsep;
# rename TMP to $dvfile
    my $origname = $dvfile . ".orig";
    rename ($dvfile,$origname);
    rename ("/tmp/dnsval.conf.tmp",$dvfile);
}

sub remove_ta_namedconf  {
    my ($domain, $key, $flags, $proto, $algo) = @_;

    my $pat = "^trusted-keys";
    my $trustsection = 0;

    open (TMP, ">/tmp/named.conf.tmp") or die "unable to open temp file.";
    open (CONF,$ncfile) or die "unable to read named.conf file.";
    my $origsep = $/;
    $/ = ";";
    while (<CONF>) {
        if (s/^\s*$pat\s*//) {
            print TMP "trusted-keys {";
            $trustsection = 1;
            s/\s*\{//;
            if ($_ ne '' && /^(\s*\n*)(\S+)\s+(\d+)\s+(\d+)\s+(\d)+\s+(\"*[^"]+"|\S+)\s*/) {
                my ($space, $d, $f, $p, $a, $k) = ($1, $2, $3, $4, $5, $6);
                # strip off the trailing dot from the domainname
                $d =~ s/\.$//;
                $k =~ s/\s+//g;
                $k =~ s/\"//g;
                if ($d eq $domain) {
                    $key =~ s/[\n\r]//g;
                    $key =~ s/\"//g;
                    if ($key eq $k &&
                        $flags eq $f &&
                        $proto eq $p &&
                        $algo eq $a) {
                        # its a match, comment it out
                            print TMP $space; # attempting to preserve spacing
                            print TMP "# The following key has been removed.\n";
                            $remkeyrec = $d . ". " . $f . " " . $p . " " . $a . " " . "\"" . $k . "\";";
                            print TMP "# " . $remkeyrec . "\n";
                    }
                } else {
                # just print it, it's not the key we're looking for
                    print TMP $_;
                }
            }
        } elsif ($trustsection) {
            if (/\s*\};/) {
                $trustsection = 0;
                print TMP "\n};\n";
            } elsif ($_ ne '' && /^(\s*\n*)(\S+)\s+(\d+)\s+(\d+)\s+(\d)+\s+(\"*[^"]+"|\S+)\s*/) {

                my ($space, $d, $f, $p, $a, $k) = ($1, $2, $3, $4, $5, $6);
                # strip off the trailing dot from the domainname
                $d =~ s/\.$//;
                $k =~ s/\s+//g;
                $k =~ s/\"//g;
                if ($d eq $domain) {
                    $key =~ s/[\n\r]//g;
                    $key =~ s/\"//g;
                    if ($key eq $k &&
                        $flags eq $f &&
                        $proto eq $p &&
                        $algo eq $a) {
                        # its a match, comment it out
                            print TMP $space; # attempting to preserve spacing
                            print TMP "# The following key has been removed.\n";
                            $remkeyrec = $d . ". " . $f . " " . $p . " " . $a . " " . "\"" . $k . "\";";
                            print TMP "# " . $remkeyrec . "\n";
                    } else {
                    # just print it, it's not the key we're looking for
                        print TMP $_;
                    }
                } else {
                # just print it, it's not the domain we're looking for
                    print TMP $_;
                }
            }
        } else {
            print TMP $_;
        }
    }
    $/ = $origsep;
    close (CONF);
    close (TMP);
# rename TMP to $dvfile
    my $origname = $ncfile . ".orig";
    rename ($ncfile,$origname);
    rename ("/tmp/named.conf.tmp",$ncfile);
}

sub revoke_ta_dnsvalconf  {
    my ($domain,$keyrec) = @_;

    my $pat = "trust-anchor";

    open (TMP, ">/tmp/dnsval.conf.tmp") or die "unable to open temp file.";
    open (CONF,$dvfile) or die "unable to read dnsval.conf file.";
    my $origsep = $/;
    $/ = ";";
    while (<CONF>) {
        s/\s;\s*$//;
        if (s/^\s*(\S*)\s*$pat\s*//) {
            print TMP $1 . " $pat\n\n";
            while ($_ ne '' && s/^\s*(\S+)\s+("*[^"]+"|\S+)\s*//) {
                my ($d, $val) = ($1, $2);
                # strip off the trailing dot from the domainname
                $d =~ s/\.$//;
                $val =~ s/[\n\r]//g;
                if ($d eq $domain) {
                    my ($flags, $protocol, $algorithm, $key) = $val =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S[^"]+)/;
                    $key =~ s/\s+//g;
                    my $keyin = $keyrec->{key};
                    $keyin =~ s/[\n\r]//g;
                    if ($keyin eq $key &&
                        $keyrec->{flags} eq $flags &&
                        $keyrec->{protocol} eq $protocol &&
                        $keyrec->{algorithm} eq $algorithm) {
# its a match, comment it out
                        print TMP "# The following key has been revoked.\n";
                        $revkeyrec = $d . ". " . $val;
                        print TMP "# " . $revkeyrec . "\n\n";
                    }

                } else {
                    # add the trailing dot when printing domainname
                    print TMP $d . ". " . $val . "\n\n";
                }
            }
            print TMP "\n;\n";
        } else {
            print TMP $_;
        }
    }
    close (CONF);
    close (TMP);
    $/ = $origsep;
# rename TMP to $dvfile
    my $origname = $dvfile . ".orig";
    rename ($dvfile,$origname);
    rename ("/tmp/dnsval.conf.tmp",$dvfile);
}

sub revoke_ta_namedconf  {
    my ($domain,$keyrec) = @_;

    my $pat = "^trusted-keys";
    my $trustsection = 0;

    open (TMP, ">/tmp/named.conf.tmp") or die "unable to open temp file.";
    open (CONF,$ncfile) or die "unable to read named.conf file.";
    my $origsep = $/;
    $/ = ";";
    while (<CONF>) {
        if (s/^\s*$pat\s*//) {
            print TMP "trusted-keys {";
            $trustsection = 1;
            s/\s*\{//;
            if ($_ ne '' && /^(\s*\n*)(\S+)\s+(\d+)\s+(\d+)\s+(\d)+\s+(\"*[^"]+"|\S+)\s*/) {
                my ($space, $d, $f, $p, $a, $k) = ($1, $2, $3, $4, $5, $6);
                # strip off the trailing dot from the domainname
                $d =~ s/\.$//;
                $k =~ s/\s+//g;
                $k =~ s/\"//g;
                if ($d eq $domain) {
                    my $keyin = $keyrec->{key};
                    $keyin =~ s/[\n\r]//g;
                    if ($keyin eq $k &&
                        $keyrec->{flags} eq $f &&
                        $keyrec->{protocol} eq $p &&
                        $keyrec->{algorithm} eq $a) {
# its a match, comment it out
                            print TMP $space; # attempting to preserve spacing
                            print TMP "# The following key has been revoked.\n";
                            $revkeyrec = $d . ". " . $f . " " . $p . " " . $a . " " . "\"" . $k . "\";";
                            print TMP "# " . $revkeyrec . "\n";
                    } else {
                    # just print it, it's not the domain we're looking for
                        print TMP $_;
                    }
                } else {
                # just print it, it's not the domain we're looking for
                    print TMP $_;
                }
            }
            
        } elsif ($trustsection) {
            if (/\s*\};/) { 
                $trustsection = 0;
                print TMP "\n};\n";
            } elsif ($_ ne '' && /^(\s*\n*)(\S+)\s+(\d+)\s+(\d+)\s+(\d)+\s+(\"*[^"]+"|\S+)\s*/) {
                my ($space, $d, $f, $p, $a, $k) = ($1, $2, $3, $4, $5, $6);
                # strip off the trailing dot from the domainname
                $d =~ s/\.$//;
                $k =~ s/\s+//g;
                $k =~ s/\"//g;
                if ($d eq $domain) {
                    my $keyin = $keyrec->{key};
                    $keyin =~ s/[\n\r]//g;
                    if ($keyin eq $k &&
                        $keyrec->{flags} eq $f &&
                        $keyrec->{protocol} eq $p &&
                        $keyrec->{algorithm} eq $a) {
# its a match, comment it out
                            print TMP $space; # attempting to preserve spacing
                            print TMP "# The following key has been revoked.\n";
                            $revkeyrec = $d . ". " . $f . " " . $p . " " . $a . " " . "\"" . $k . "\";";
                            print TMP "# " . $revkeyrec . "\n";
                    }
                } else {
                # just print it, it's not the key we're looking for
                    print TMP $_;
                }
            }
        } else {
            print TMP $_;
        }
    }
    $/ = $origsep;
    close (CONF);
    close (TMP);
# rename TMP to $dvfile
    my $origname = $ncfile . ".orig";
    rename ($ncfile,$origname);
    rename ("/tmp/named.conf.tmp",$ncfile);
}

sub get_domains_keys {
# using globals %keystorage and @domains, is this evil?

# if domains are specified on the command line, we will only
# check those domain. Otherwise, check all domains found in config files.
    read_conf_file(\%keystorage, $ncfile, \%zone_configfile_map) if ($ncfile);
    read_dnsval_file(\%keystorage, $dvfile, \%zone_configfile_map) if ($dvfile);

# if @domains exists now, we used only domains from the cmd line,
# so we're done. if not, we got domains from config files, and
# need to populate both @domains and %revdomains
    if (!exists ($domains[0])) {
        foreach my $d (keys(%keystorage)) {
            $domains[$#domains + 1] = $d;
            if (!(exists $revdomains{$d})) {
                $revdomains{$d} = $#domains +1;
            }
        }
    } 
    

    if (!@domains) {
        print "No domains to check, exiting....\n";
        exit(1);
    }

}

#########################################################
#
# resolve_and_check_dnskey
# called by checkkeys, queries a zone to get the 
# DNSKEY record; returns an answer only if it was validated
# 
sub resolve_and_check_dnskey {
    my ($d,$file) = @_;
    my $validator = new Net::DNS::SEC::Validator(resolv_conf => $resfile,
                                                 dnsval_conf => $file);
    my $r = $validator->res_query($d, "IN", "DNSKEY");
    if ($r && $validator->isvalidated) {
        my ($pkt, $err) = new Net::DNS::Packet(\$r);
        if (!$err) {
            return $pkt;
        }
    }
    return undef;
}

#######################################################################
# read_conf_file()
#
# reads in a config file pointed to by $file
# looks for trust anchors using $pat and stores key
# information in $storage
#
sub read_conf_file {
    my ($storage, $file, $configmap) = @_;
    Verbose("reading and parsing trust keys from $file\n");
    my $pat = "trusted-keys";

    # regexp pulled from Fast.pm
    my $pat_maybefullname = qr{[-\w\$\d*]+(?:\.[-\w\$\d]+)*\.?};

    open (FILE, "< $file") or die "can't open config file: $!\n";
    while (<FILE>) {
	if (/$pat/) {
	    while (<FILE>) {
		last if (/^\s*\};/);
		if (/\s*($pat_maybefullname)\s+(257)\s+(\d+)\s+(\d+)\s+\"(.+)\"\s*;/) {

                    my $domainname = $1;
                    my ($flags, $protocol, $algorithm) = ($2, $3, $4);
                    my $key = $5;
                    $domainname =~ s/\.$//;

                    if (keys %revdomains) {
# only store key data from domains we are actually checking (@domains)
# if domains were supplied on the command line (-d)

                        if (exists($revdomains{$domainname})) {
                            $key =~ s/[\n\r\s]//g;

                            # need to remember where these keys came from
                            $configmap->{$domainname} = $file;

                            my $newstorageobj = { flags => $flags,
                                                  protocol => $protocol,
                                                  algorithm => $algorithm,
                                                  key => $key,
                                                };
                            push (@{$storage->{$domainname}}, $newstorageobj);
                        }
                    }
		}
	    }
	}
    }
    close FILE;
}

#######################################################################
# read_dnsval_file()
#
# reads in a config file pointed to by $file
# looks for trust anchors using $pat and stores key
# information in $storage
#
sub read_dnsval_file {
    my ($storage, $file, $configmap) = @_;
    Verbose("reading and parsing trust keys from $file\n");
    my $pat = "trust-anchor";

    my $fh = new IO::File;
    if (!$fh->open("<$file")) {
	print STDERR "Could not open named configuration file: $file\n";
	exit (1);
    }
    # set separator to semicolon in order to get whole chunk
    $/ = ";";
    while (<$fh>) {
        s/\s;\s*$//;
        s/[\n\r]//g;
        if (s/^\s*(\S*)\s*$pat\s*//) {
            my $trustanchor_type = $1;
            while ($_ ne '' && s/^\s*(\S+)\s+("*[^"]+"|\S+)\s*//) {
                my ($domainname, $value) = ($1, $2);
                $value =~ s/[\n\r]//g;
                my ($flags, $proto, $algo, $key) = $value =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S[^"]+)/;


                # strip the trailing dot
                $domainname =~ s/\.$//;

                if (keys %revdomains) {
# only store key data from domains we are actually checking (@domains)
# if domains were supplied on the command line (-d)

                    if (exists($revdomains{$domainname})) {
    
                        $configmap->{$domainname} = $file;

                        push @{$storage->{$domainname}},
		              { flags => $flags,
			        protocol => $proto,
			        algorithm => $algo,
			        key => $key };
	                $storage->{$domainname}[$#{$storage->{$domainname}}]{key} =~ s/\s+//g;
                    }
                } else {
                    $configmap->{$domainname} = $file;

                    push @{$storage->{$domainname}},
		          { flags => $flags,
		            protocol => $proto,
		            algorithm => $algo,
		            key => $key };
	            $storage->{$domainname}[$#{$storage->{$domainname}}]{key} =~ s/\s+//g;
                }
	    }
	}
    }
    $fh->close;
}

sub compute_add_holddown {
    my $ttl = shift;
    my $holddown;
    my $default = 2592000;
    my $now = localtime();
    my $nowsecs = str2time($now);

# return secs since the epoch as the time to release this holddown
    if ($ttl < $default) { # 30 days unless ttl is less
        $holddown = $nowsecs + $ttl;
    } else {
        $holddown = $nowsecs + $default;
    }
    return $holddown;
}


sub compute_remove_holddown {
    my $holddown;
    my $default = 2592000;
    my $now = localtime();
    my $nowsecs = str2time($now);

# return secs since the epoch as the time to release this holddown
    $holddown = $nowsecs + $default;
    return $holddown;
}

sub compute_sleepsecs {
# min(expiration interval [sigexpiration - now],1/2 * ottl, 15 days)
    my ($ottl,$sexp) = @_;
    $sexp =~ s/(....)(..)(..)(..)(..)(..)/$1-$2-$3T$4:$5:$6/;
    my $sigexp = str2time($sexp);
    my $fifteendays = 129600;
    my $halfottl = $ottl / 2;
    my $now = localtime();
    my $nowsecs = str2time($now);
    my $expinterval = $sigexp - $nowsecs;
    my $actrefsecs;
    if ($halfottl < $expinterval) {
        if ($halfottl < $fifteendays) {
            $actrefsecs = $halfottl;
        } else {
            $actrefsecs = $fifteendays;
        }
    } else {
        if ($expinterval < $fifteendays) {
            $actrefsecs = $expinterval;
        } else {
            $actrefsecs = $fifteendays
        }
    }
    
    return ($actrefsecs,$actrefsecs+$nowsecs);
}

sub compute_queryfail_sleepsecs {
# MAX(1 hour, MIN(1 day, 0.1 * ottl, 0.1 * expiration interval[sigexpiration - now])
    my ($ottl,$sexp) = @_;
    $sexp =~ s/(....)(..)(..)(..)(..)(..)/$1-$2-$3T$4:$5:$6/;
    my $sigexp = str2time($sexp);
    my $onehour = 3600;
    my $oneday = 86400;
    my $tenth_ottl = $ottl / 10;
    my $now = localtime();
    my $nowsecs = str2time($now);
    my $tenth_expinterval = ($sigexp - $nowsecs) / 10;
    my $refreshsecs;
    if ($tenth_ottl < $tenth_expinterval) {
        if ($tenth_ottl < $oneday) {
            $refreshsecs = $tenth_ottl;
        } else {
            $refreshsecs = $oneday;
        }
    } else {
        if ($tenth_expinterval < $oneday) {
            $refreshsecs = $tenth_expinterval;
        } else {
            $refreshsecs = $oneday;
        }
    }
    if ($refreshsecs >= $onehour) {
        return ($refreshsecs);
    } else { 
        return ($onehour);
    }
}

######################################################################
# mailcontact()
#  - emails a contact address with the error output
sub mailcontact {
    my ($ok,$smtp,$contact,@domains) = @_;
    my $fromaddr = 'trustman@localhost';

    # set up the SMTP object and required data
    my $message = Net::SMTP->new($smtp) || die "failed to create smtp message";
    $message->mail($fromaddr);
    $message->to(split(/,\s*/,$contact));
    $message->data();

    # create headers
    $message->datasend("To: " . $contact . "\n");
    $message->datasend("From: " . $fromaddr . "\n");

    # create the body of the message: the warning
    if ($ok) {
        $message->datasend("Subject: trustman all clear\n\n");
        $message->datasend("trustman detected no DNSKEY mismatches for the following zones: \n\n");
    } else {
        $message->datasend("Subject: trustman: new key detected \n\n");
        $message->datasend("trustman has detected new keys for the following zones: \n\n");
    }
    foreach my $d (@domains) {
        $message->datasend("\t" . $d . "\n");
        $message->datasend("Key found: \n");
        $message->datasend($newkeys{$d} . "\n\n");
    }
    if (!$ok) {
        $message->datasend("\n\nThese keys have passed the add holddown time\n");
        $message->datasend("and can now be added manually.\n\n");
    }

    # finish and send the message
    $message->dataend();
    $message->quit;
}

#######################################################################
# compare_keys()
#
# compares the contents of two keys to see if the new one ($domain,
# $rec, and $keyin) matches a cached one previously stored (in
# $storage->{$domain} )
#
sub compare_keys {
    my ($storage, $domain, $rec, $keyin) = @_;
    my $newkey = 1;
    if (!exists($storage->{$domain})) {
# What would nonexistence of this really mean?
    }
    for (my $i = 0; $i <= $#{$storage->{$domain}}; $i++) {
        if ($storage->{$domain}[$i]{key} eq $keyin &&
            $storage->{$domain}[$i]{flags} eq $rec->flags &&
            $storage->{$domain}[$i]{protocol} eq $rec->protocol &&
            $storage->{$domain}[$i]{algorithm} eq $rec->algorithm) {

            $newkey = 0;
            # any match is good enough, get out now
            $i = $#{$storage->{$domain}} + 1;
	} else {
            $newkey = 1;
        }
    }
    return $newkey;
}

#######################################################################
# Verbose()
#
# prints something(s) to STDERR only if -v was specified.
#
sub Verbose {
    print STDERR @_ if ($opts{'v'});
}

####################################################################
# daemonize
# 
# run as a daemon

sub daemonize {
  chdir '/' or die "Can't chdir to /: $!";
  open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
  open STDERR, '>/dev/null' or die "Can't write to /dev/null: $!";
  defined(my $pid = fork()) or die "Can't fork: $!";
  exit if $pid;
  POSIX::setsid() or die "Can't start a new session: $!";
  umask 0;
}

#######################################################################
# Getopt::GUI::Long portability
#
# will be used in a near-future version

sub LocalGetOptions {
    if (eval {require Getopt::GUI::Long;}) {
	require Getopt::Long;
	import Getopt::GUI::Long;
	Getopt::GUI::Long::Configure(qw(display_help no_ignore_case));
	return GetOptions(@_);
    }
    require Getopt::Long;
    import Getopt::Long;
    Getopt::Long::Configure(qw(auto_help no_ignore_case));
    GetOptions(LocalOptionsMap(@_));
}

sub LocalOptionsMap {
    my ($st, $cb, @opts) = ((ref($_[0]) eq 'HASH') 
			    ? (1, 1, $_[0]) : (0, 2));
    for (my $i = $st; $i <= $#_; $i += $cb) {
	if ($_[$i]) {
	    next if (ref($_[$i]) eq 'ARRAY' && $_[$i][0] =~ /^GUI:/);
	    push @opts, ((ref($_[$i]) eq 'ARRAY') ? $_[$i][0] : $_[$i]);
	    push @opts, $_[$i+1] if ($cb == 2);
	}
    }
    return @opts;
}

=head1 NAME

trustman - manage keys used as trust anchors

=head1 SYNOPSIS

trustman [options]

=head1 DESCRIPTION

trustman runs by default as a daemon to verify if keys stored locally
in configuration files (named.conf or dnsval.conf) still match the same keys
as fetched from the zone where they are defined. If mismatches
are detected, the daemon: 

sets an add holddown timer for new keys;
sets a remove holddown timer for missing keys;
removes revoked keys from the conf file.

On subsequent runs, the timers are checked and if the times
are reached, adds keys to the conf file or removes them,
as appropriate.

The same check can be run once manually (-S) and in the foreground (-f). 

This script can also be used to set up configuration data in the file
dnssec-tools.conf for later use by the daemon, making fewer command
line arguments necessary. Configuration data is stored in dnssec-tools.conf.
The current version requires you to edit dnssec-tools.conf by hand and
supply values for the contact person email address (tacontact) and the
SMTP server (tasmtpserver). Also edit the location of named.conf and
dnsval.conf in that file if necessary.

=head1 OPTIONS

=over #indent

=item -a

A persistent data file for storing new keys waiting to be added.

=item -c

Create a configure file for trustman from the command line options given.

=item -d

The domain to check (supersedes configuration file)

=item -f

Run in the foreground

=item -h

Help

=item -k 

A dnsval.conf file to read

=item -L

Log messages to syslog.

=item -m

Mail address for the contact person to whom reports should be sent

=item -n 

A named.conf file to read

=item -N

Send report when there are no errors.

=item -o

Output file for configuration

=item -p

Log/print messages to stdout.

=item -r 

A resolv.conf file to read (can use /dev/null to force libval to
recursively answer the query rather than asking other name servers)

=item -s

SMTP server trustman should use to send reports

=item -S

Run only once 

=item -t

The number of seconds to sleep between checks. Default is 3600 (one hour)

=item -v

Verbose.

=item -V

Version.

=item -w

The value of the hold down timer

=back #unindent
=head1 PRE-REQUISITES

=head1 COPYRIGHT

Copyright 2006 SPARTA, Inc.  All rights reserved.
See the COPYING file included with the DNSSEC-Tools package for details.

=cut
