#!/usr/bin/perl -w

use utf8;
use strict;
use warnings;

BEGIN {
    unshift @INC, ( $ENV{POPHOME} || '/usr/pop' ) . '/lib'
      unless $ENV{KUNDE_NO_PERLPATH};
}

use Date::Format qw(time2str);
use Encode qw(decode);
use HTML::TreeBuilder ();
use noris::DNS::Resolver;

use Cf qw($BGCOLOR $NORIS_VHOST $NSI);
use Dbase::Getopt;
use Dbase::Globals qw(
  aufzaehlung
  find_descr
  get_gruppen
  get_kunde
  info_descr
  puny_decode
  test_gruppe
);
use Dbase::Help qw(:readonly DoSelect DoFn DoTime in_list quote);
use Fehler qw(hat_problem);
use Umlaut qw(textmodus);

use constant COLUMNS_CSV =>
  qw(Sub-Domain Name Endung IP HTTP HTTP-Redirect HTTPS HTTPS-Redirect);
use constant COLUMNS_HTML =>
  qw(Sub-Domain IP HTTP HTTP-Redirect HTTPS HTTPS-Redirect);
use constant ALIGN => {};    # { 'Sub-Domain' => 'right', SLD => 'center' };
use constant IS_NORIS_VHOST => { map +( $_ => 1 ), split ' ', $NORIS_VHOST };
use constant START_HTML     => (
    -bgcolor  => $BGCOLOR,
    -charset  => 'utf-8',
    -encoding => 'utf-8',
    -lang     => 'de-DE'
);

my $MitPreisen;
my @Args = GetOptions(
    'csv-file=s'    => \my $CSV_File,
    'debug+'        => \my $Debug,
    'destination=s' => \my $Destination,
    'html-file=s'   => \my $HTML_File,
    'resolver=s'    => \my %Resolver,
    'scp-to=s'      => \my $SCP2,
    'useragent=s'   => \my %UserAgent,
    'mit-preisen'   => \$MitPreisen,
    'ohne-preise'   => sub { $MitPreisen = '' },
) or die "USAGE: $0 <Kunde>+";

my @xcolumns = ( 'Monat', $MitPreisen ? 'Preis' : () );

my $kunden = in_list( 'domainkunde.kunde', '', map get_kunde( $_, 1 ), @Args );
if ( my $probleme = hat_problem() ) { exit $probleme }

sub debug($$) { }

# Umlaute sollen nicht umgebaut werden, da sonst Probleme mit utf8 (RT#253906):
sub encode_entities($) { HTML::Entities::encode( shift, q("&'<>) ) }

if ($Debug) {
    no warnings 'redefine';
    *debug = sub($$) {
        my ( $level, $message ) = @_;
        return if $Debug < $level;
        print STDERR ref $message ? $message->($Debug) : $message;
    };
}

$| = 1;

my %xdata;
{
    my $domainflags_dnszone = find_descr( domainflags => dnszone => 1 );
    my $domainstatus_unregistriert =
      find_descr( domainstatus => unregistriert => 1 );
    my ( $registriert_grs, $registriert_grc ) =
      get_gruppen( domainstatus_ident => registriert => 1 );

    DoSelect {
        my (
            $domain,       $status, $dnszone,
            $timestamp,    $ns_ip,$ns_bits,  $monat,
            $tarifname_id, $dienst, $kunde
          )
          = @_;
        my $xdata = $xdata{$domain} = {
            Monat      => $monat,
            NameServer => $dnszone ? (defined $ns_bits) ? Dbase::IP->new_db($ns_ip,$ns_bits)->str : $NSI : undef,
            Status     => $status == $domainstatus_unregistriert
            ? 'nicht via noris network registriert'
            : test_gruppe(
                domainstatus => $status,
                $registriert_grs, $registriert_grc
              )
            ? 'registriert via noris network'
            : info_descr( domainstatus => $status ),
            TimeStamp => $timestamp
        };
        my %seen;

        if ( defined $tarifname_id ) {
            if ($MitPreisen) {
                my $preis;
                {
                    my $tarifklasse = DoFn(<<_);
	SELECT id
	FROM   tarifklasse
	WHERE  tarifname = $tarifname_id
	   AND kunde = $kunde
	   AND id IN ( SELECT klasse FROM tarif WHERE dienst = $dienst )
_
                    $tarifklasse = DoFn(<<_) unless defined $tarifklasse;
	SELECT id
	FROM   tarifklasse
	WHERE  tarifname = $tarifname_id AND kunde IS NULL
_
                    $preis = DoFn(<<_) if $tarifklasse;
	SELECT   festpreis
	FROM     tarif
	WHERE    klasse = $tarifklasse AND dienst = $dienst
	ORDER BY beginn DESC
	LIMIT  1
_
                    last if defined $preis;

                    die "Zirkuläre Referenz in tarifeq für Dienst $dienst.\n"
                      if $seen{$dienst}++;

                    defined( my $berechne = DoFn(<<1) ) or die <<2;
	SELECT berechne FROM tarifeq WHERE dienst = $dienst
1
Kann keinen Tarif für Domain $domain ermitteln (vergebliche Suche in tarifeq für Dienst $dienst).
2
                    $dienst = $berechne;

                    redo;
                }
                ( $xdata->{Preis} = sprintf '%.2f', $preis / 1000 ) =~ y/./,/;
            }
            $xdata->{Monat} = time2str( '%Y-%m', DoTime() )
              unless defined $xdata->{Monat};
        }
      }
      <<_;
	SELECT    domainkunde.domain,
	          domainkunde.status,
	          domainkunde.flags & ( 1 << $domainflags_dnszone ),
	          DATE_FORMAT(domainkunde.timestamp, '%Y-%m-%d %H:%i'),
	          ipkunde.ip6,ipkunde.bits,
	          DATE_FORMAT(FROM_UNIXTIME(tarifkunde.nextrech), '%Y-%m'),
	          tarifkunde.tarifname,
	          tarifkunde.dienst,
	          tarifkunde.kunde
	FROM      domainkunde
	LEFT JOIN tarifkunde ON domainkunde.ktarif  = tarifkunde.id
	LEFT JOIN ipkunde    ON domainkunde.nserver = ipkunde.id
	WHERE     $kunden
	      AND domainkunde.domain NOT LIKE '%.in-addr.arpa'
	      AND ( domainkunde.ende IS NULL                 OR
	            domainkunde.ende > UNIX_TIMESTAMP(NOW()) )
	ORDER BY  domainkunde.domain
_
}
die "Keine Domains gefunden.\n" unless keys %xdata;

debug(
    3 => sub {
        require Data::Dumper and Data::Dumper->Dump( [ \%xdata ], ['*xdata'] );
    }
);

my %data;
{
    my @default_nservers =
      ( my $resolver = noris::DNS::Resolver->new )->nameservers;
    while ( my ( $option, $value ) = each %Resolver ) {
        $resolver->$option($value);
    }

    my $useragent = my::LWP::UserAgent->new;
    while ( my ( $option, $value ) = each %UserAgent ) {
        $useragent->$option($value);
    }

    my %host;
    while ( my ( $domain, $xdata ) = each %xdata ) {

        debug( 1 => "$domain:\n" );

        my ( @rr, $zone );

        if ( defined $xdata->{NameServer} ) {
            $resolver->nameservers( $xdata->{NameServer} );
            if ( @rr = $resolver->axfr($domain) ) {
                $xdata{$domain}{AXFR} = 1;
                die "No SOA for $domain!?\n" if $rr[0]->type ne 'SOA';
                $zone = $rr[0]->name;
            }
            else {
                $resolver->nameservers(@default_nservers);

                if ( my $packet = $resolver->send($domain) ) {
                    @rr = $packet->answer;

                    unless ( my $packet = $resolver->send( $domain, 'SOA' ) ) {
                        warn "DNS query for $domain\'s SOA failed: "
                          . $resolver->errorstring;
                    }
                    elsif (
                        ( my $rcode = $packet->header->rcode ) ne 'NOERROR' )
                    {
                        warn "DNS SOA query for $domain returned $rcode.\n";
                    }
                    elsif ( ( my $n_soa = $packet->header->ancount ) != 1 ) {
                        warn "$n_soa SOA RRs for $domain!?\n";
                    }
                    elsif ( my $type =
                        ( my $soa = ( $packet->answer )[0] )->type ne 'SOA' )
                    {
                        warn "Got $type instead of SOA for $domain!?\n";
                    }
                    else { $zone = $soa->name }

                    $zone = $domain unless defined $zone;    # Fallback
                }
                else {
                    warn "DNS query for $domain failed: "
                      . $resolver->errorstring;
                }
            }
        }

        if (@rr) {

            $zone =~ /([^.]+)\.(.+)/ or die "Unusual zone name: $zone\n";
	    my %sdata = ( Name => $1, Endung => $2 );

            for my $rr (@rr) {
                next unless grep $rr->type eq $_, qw(A CNAME);
                debug( 1 => "\t" . ( my $name = $rr->name ) . '... ' );
                die <<_ if exists $host{$name};
Kann nicht mit mehr als einer IP-Adresse pro FQDN umgehen ($name).
_
                my $sdata;
                {
                    my $subdomain = '';
                    if ( lc( my $name = $rr->name ) ne lc $zone ) {
                        if ( ( $subdomain = $name ) !~ s/\.\Q$zone\E\z//i )
                        {    # nur Warnung sinnvoll, s. RT#418384
                            warn <<_;
Ignoring $name, since it does not belong to zone $zone.
_
                            next;
                        }
                    }
                    $sdata = $data{$domain}{$subdomain} =
                      { 'Sub-Domain' => $subdomain, %sdata };
                }

                if ( $rr->type eq 'A' ) {
                    for (qw(HTTP HTTPS)) {
                        debug( 1 => ', ' ) if $_ eq 'HTTPS';
                        $sdata->{$_} = 'noris-VirtualHost: '
                          if exists IS_NORIS_VHOST->{ $sdata->{IP} =
                              $rr->address };
                        {
                            my $packet = $resolver->send(
                                join( '.', reverse split /\./, $sdata->{IP} )
                                  . '.in-addr.arpa', 'PTR'
                              )
                              or die
                              "Can't get reverse lookup for $sdata->{IP}: "
                              . $resolver->errorstring;
                            if (
                                my @answer =
                                map $_->type eq 'PTR' ? $_->ptrdname : (),
                                $packet->answer
                              )
                            {
                                warn
"Expected one PTR record for $sdata->{IP}, but found "
                                  . @answer
                                  unless @answer == 1;
                                $sdata->{IP} .=
                                  ' (' . join( ', ', @answer ) . ')';
                            }
                        }
                        debug( 1 => "$sdata->{IP}... " );

                        unless (
                            defined(
                                my $response = $useragent->simple_request(
                                    HTTP::Request->new(
                                        GET => "\L$_\E://$name/"
                                    )
                                )
                            )
                          )
                        {
                            $sdata->{$_} = 'atypischer Abfragefehler';
                            debug( 1 => $sdata->{$_} );
                        }

			elsif ( $response->is_redirect ) {
                            $sdata->{$_} .= "$_-Redirect";
                            debug(
                                1 => "$sdata->{$_} -> "
                                  . (
                                    $sdata->{"$_-Redirect"} =
                                      $response->header('Location')
                                  )
                            );
                        }

                        elsif ( $response->is_success ) {

                            # man möchte NICHT $tree->utf8_mode(1) setzen,
                            # weil es sonst (beim Kunden medienproduktion
                            # bzw. der Domain dievergessenen-der-film.de)
                            # "wide character in subroutine entry"-Fehler gibt.
                            ( my $tree = HTML::TreeBuilder->new )
                              ->parse( $response->as_string );

                            unless (
                                my $meta_tag = $tree->look_down(
                                    qw(_tag meta http-equiv refresh))
                              )
                            {
                                $sdata->{$_} .= '-';
                                debug( 1 => 'OK' );
                            }
                            elsif ( $meta_tag->attr('content') =~
                                /^(\d+)(?:\s*;\s*|\s+)URL=(.*)/i )
                            {
                                $sdata->{"$_-Redirect"} = $2;
                                $sdata->{$_} .=
                                  'META-Tag-Redirect'
                                  . ( defined $1 && " nach $1 s" );
                                debug( 1 =>
qq($sdata->{$_} -> <$sdata->{"$_-Redirect"}>)
                                );
                            }
                            else {
                                $sdata->{$_} .=
'(mutma&szlig;lich kaputter META-Tag-Redirect)';
                                debug( 1 =>
                                      'mutmaßlich kaputter META-Tag-Redirect: '
                                      . $meta_tag->attr('content')
                                      . "\n" );
                            }
                            $tree->delete;
                        }

                        elsif ( $response->is_error ) {
                            if ( $response->code == 500 ) {
                                $sdata->{$_} = "kein $_-Server";
                                debug( 1 => $response->status_line );
                            }
                            else {
                                $sdata->{$_} =
                                  'Fehler: ' . $response->status_line;
                                debug( 1 => $sdata->{$_} );
                            }
                        }

                        else {
                            die
"Unerwarteter Antwort-Typ beim Aufruf von <\L$_\E://$name/>.";
                        }
                    }
                }
                else {
                    $sdata->{IP} =
                      decode( latin1 => 'Alias für ' . $rr->cname );
                    debug( 1 => $sdata->{IP} );
                }
                debug( 1 => "\n" );
            }
        }
        else {    # Fallback, falls gar keine DNS-Einträge gefunden wurden
            @{ $data{$domain}{''} }{qw(Endung Name Sub-Domain)} =
              map scalar reverse($_), split /\./, scalar reverse($domain), 3;
        }
    }
}

debug(
    2 => sub {
        require Data::Dumper and Data::Dumper->Dump( [ \%data ], ['*data'] );
    }
);

my $dir;
if ( defined $Destination ) {
    -d ( $dir = $Destination ) or mkdir $dir or die "mkdir('$dir'): $!\n";
}
else {
    require File::Temp and File::Temp->import('tempdir');
    defined( $dir = tempdir() ) or die;
    debug( 1 => "Verwende als temporäres Verzeichnis '$dir'.\n" );
}
chdir $dir or die "chdir('$dir'): $!\n";

my @Files;

sub save_open($;$) {
    my ( $file, $charset ) = @_;
    open my $fh, '>' . ( defined $charset && ":$charset" ), $file
      or die "open('>', '$file'): $!\n";
    push @Files, $file;
    $fh;
}

if ( defined $CSV_File ) {
    require noris::CSV;
    my $fh = save_open($CSV_File);
    textmodus($fh);
    my $csv = noris::CSV->new( { always_quote => 1, sep_char => ';' } );
    print $fh $csv->as_decoded_string( COLUMNS_CSV, @xcolumns );

    for my $domain ( sort keys %data ) {
        for my $subdomain ( sort keys %{ $data{$domain} } ) {
            print $fh $csv->as_decoded_string(
                map defined() ? $_ : '-',
                @{ $data{$domain}{$subdomain} }{ (COLUMNS_CSV) },
                length $subdomain ? () : @{ $xdata{$domain} }{@xcolumns}
            );
        }
    }
    close $fh or warn "close('>', '$CSV_File'): $!\n";
}

if ( defined $HTML_File ) {
    require CGI;
    require HTML::Entities;
    my $fh = save_open( $HTML_File, 'utf8' );
    ( my $cgi = CGI->new )->autoEscape(0);
    my $norislogo = $cgi->a(
        { href => '/', target => '_blank' },
        $cgi->img(
            {
                align  => 'right',
                alt    => 'noris network',
                border => 0,
                height => 29,
                src    => '/images/noris_logo.gif',
                width  => 192
            }
        )
      ),
      my $title =
      'Domainliste f&uuml;r ' . encode_entities( aufzaehlung(@Args) );
    print $fh $cgi->start_html( START_HTML, -title => $title ), $norislogo,
      $cgi->start_table,
      $cgi->caption( $cgi->h1($title), time2str( 'Stand %Y-%m-%d', DoTime() ) ),
      $cgi->Tr(
        [
            $cgi->th(
                [
                    'Domain',
                    $MitPreisen ? 'Preis' : (),
                    qw(F&auml;lligkeit Status),
                    'letzte &Auml;nderung'
                ]
            ),
            $cgi->td( { colspan => 5 }, $cgi->hr( { noshade => undef } ) )
        ]
      );
    for my $puny_domain ( sort keys %xdata ) {
        my $decoded_domain = lc puny_decode($puny_domain);
        my $xdata          = $xdata{$puny_domain};
        print $fh $cgi->Tr(
            $cgi->td(
                $cgi->a(
                    { href => ( my $domainfile = "$puny_domain.html" ) },
                    encode_entities($decoded_domain)
                )
            ),
            $MitPreisen
            ? $cgi->td( { align => 'right' },
                defined $xdata->{Preis} ? "$xdata->{Preis} EUR" : $cgi->br )
            : (),
            $cgi->td(
                { align => 'center' },
                defined $xdata->{Monat} ? $xdata->{Monat} : $cgi->br
            ),
            $cgi->td( $xdata->{Status} ),
            $cgi->td( $xdata->{TimeStamp} )
        );

        my $dfh = save_open( $domainfile, 'utf8' );

        print $dfh $cgi->start_html(
            START_HTML, -title => "$title; Domain $decoded_domain"
          ),
          $norislogo, $cgi->h1( encode_entities($decoded_domain) ),
          defined $xdata->{Monat}
          || defined $xdata->{Preis}
          ? $cgi->p(
            defined $xdata->{Monat}
            ? "Diese Domain wird im Monat $xdata->{Monat} zur Bezahlung f&auml;llig"
              . (
                defined $xdata->{Preis}
                  && "; die Verl&auml;ngerung wird dann voraussichtlich $xdata->{Preis} EUR kosten"
              )
              . '.'
            : "Diese Domain kostet j&auml;hrlich derzeit $xdata->{Preis} EUR."
          )
          : ();

        if ( $data{$puny_domain} ) {

            print $dfh $cgi->start_table( { border => 1, cellspacing => 0 } ),
              $cgi->caption(
                $xdata->{AXFR}
                ? 'Eingetragene A- und CNAME-Records in der DNS-Zone dieser Domain:'
                : 'Weitergehende Informationen zum Setup der Domain (unvollst&auml;ndig, da AXFR nicht m&ouml;glich war):'
              ),
              $cgi->Tr(
                { bgcolor => 'gray' },
                map $cgi->th(
                    defined ALIGN->{$_} ? { align => ALIGN->{$_} } : (),
                    encode_entities($_)
                ),
                COLUMNS_HTML
              );
            for my $subdomain ( sort keys %{ $data{$puny_domain} } ) {
                my $sdata = $data{$puny_domain}{$subdomain};
                print $dfh $cgi->Tr(
                    map $cgi->td(
                        {
                            defined ALIGN->{$_} ? { align => ALIGN->{$_} } : (),
                            valign => 'top'
                        },
                        defined $sdata->{$_}
                        ? '&nbsp;' . encode_entities( $sdata->{$_} ) . '&nbsp;'
                        : $cgi->br
                    ),
                    COLUMNS_HTML
                );
            }
            print $dfh $cgi->end_table;

            if ( !defined $xdata->{Tarif} && defined $xdata->{AXFR} ) {
                print $dfh $cgi->p(<<_),
Die angezeigten DNS-Daten wurden durch Befragung des NameServers $xdata->{NameServer} ermittelt.
Es handelt sich hierbei nicht zwingend um die tats&auml;chlich produktiven DNS-Daten.
_
            }
        }

        print $dfh $cgi->end_html;
        close $dfh or die "close('>', '$domainfile'): $!\n";
    }
    print $fh $cgi->end_table, defined $CSV_File
      && $cgi->p(
        $cgi->a( { href => $CSV_File }, 'Gesamtliste als CSV-Datei' ) ),
      $cgi->end_html;
    close $fh or die "close('>', '$HTML_File'): $!\n";
}

if ( defined $SCP2 && @Files ) {
    my @scp = ( qw(scp -p), @Files, $SCP2 );
    debug( 1 => "Calling '@scp'.\n" );
    system @scp;
}

require File::Path and File::Path->import('rmtree') and rmtree($dir)
  unless defined $Destination;

# Workaround für HTTPS-Timeout-Problem, vgl. RT#251603:

package my::LWP::UserAgent;
use base 'LWP::UserAgent';

sub simple_request {
    my $self = shift;
    my ($request) = @_;
    return $self->SUPER::simple_request(@_)
      unless $request->uri =~ /^https:/ && ( my $timeout = $self->timeout );
    my $response;
    eval {
        local $SIG{ALRM} = sub { die "TIMEOUT\n" };
        alarm $timeout;
        $response = $self->SUPER::simple_request(@_);
        alarm 0;
    };
    $response;
}

__END__

=head1 NAME

domainliste - Generierung einer Domain-/DNS-Übersicht

=head1 SYNOPSE

    domainliste consors condomain              \
                -useragent timeout=42          \
                -csv-file domainliste.csv      \
                -html-file index.html          \
                -scp-to consors@www2.noris.net:

=head1 BESCHREIBUNG

Das Script generiert eine Übersicht über alle Domains sowie die zugehörigen
DNS-Einträge für einen oder mehrere Kunden

=head1 OPTIONEN

=over 4

=item -mit-preisen

Domainpreise mit anzeigen

=item -ohne-preise

Domainpreise nicht anzeigen (Default)

=item -csv-file Dateiname

Name der Datei, in der das Ergebnis als in Form von CSV gespeichert werden soll

=item -debug

zur Ausgabe von Debugging-Meldungen auf STDERR.
Je öfter die Option verwendet wird, desto höher der Debug-Level, und desto
zahlreicher die Meldungen.

=item -destination Verzeichnisname

Lokales Verzeichnis, in dem die Ergebnis-Dateien abgelegt werden sollen.
Wird kein Verzeichnis angegeben, wird mittels L<tempdir()|File::Temp/tempdir>
ein temporäres erzeugt und nach erfolgreichem Durchlauf des Scripts wieder
gelöscht.

=item -html-file Dateiname

Name der Index-Datei für die Ausgabe in Form von HTML-Seiten.
Zusätzlich wird dann automatisch für jede Domain eine Datei namens DOMAIN.html
angelegt und in der Index-Datei verlinkt.
Bei gleichzeitiger Ausgabe einer L<CSV-Datei|/csv-file=s> wird auch diese in der
Index-Datei verlinkt.

=item -resolver Option=Wert

Hiermit können Argumente direkt in der Form C<OPTION=WERT> an den intern
verwendeten L<Net::DNS::Resolver|Net::DNS::Resolver> übergeben werden.

=item -scp-to Ziel

Ziel, zu dem die Ergebnis-Dateien via scp übertragen werden sollen

=item -useragent Name=Wert

Hiermit können Argumente direkt in der Form C<OPTION=WERT> an den intern
verwendeten L<LWP::UserAgent|LWP::UserAgent> übergeben werden.

=back

=head1 BEKANNTE FEHLER

Das Script kann nicht mit mehreren A-Records zum gleichen FQDN umgehen(, sondern
stirbt, wenn es auf so eine Konstellation trifft).

=head1 AUTOR

 Martin H. Sluka <fany@noris.net>
 für die noris network AG

=cut
