#!/usr/bin/perl -w
# -*- perl -*-

#
# Author: Slaven Rezic
#
# Copyright (C) 2007,2013,2018,2024 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: slaven@rezic.de
# WWW:  http://www.rezic.de/eserte/
#

use strict;
use FindBin;
use lib "$FindBin::RealBin/..", "$FindBin::RealBin/../lib", "$FindBin::RealBin/../t";

use IO::Pipe;
use LWP::UserAgent;
use Time::HiRes qw(time);
use Getopt::Long;
use File::Basename qw(basename);
use Term::ANSIColor qw(colored);

my($host, $m_host);
my($compare_host, $compare_m_host);
my $skip_lines = 0;
my $do_file_cache_normalization = 1; # about the x-bbbike-file-cache header
my $do_content_length_normalization = 1; # usually for servers working with chunked transfer-encoding vs servers emitting content-length
my $do_connection_normalization = 0; # usually for Connection:keep-alive vs close
my $do_compression = 0;
my $do_dump;
my $do_validation;
my $url_layout = 'cgi-bin';
GetOptions(
	   "host=s" => \$host,
	   "mhost=s" => \$m_host,
	   "comparehost=s" => \$compare_host,
	   "comparemhost=s" => \$compare_m_host,
	   "skip-lines=i" => \$skip_lines,
	   'file-cache-normalization!' => \$do_file_cache_normalization,
	   'content-length-normalization!' => \$do_content_length_normalization,
	   'connection-normalization!' => \$do_connection_normalization,
	   'compression!' => \$do_compression,
	   'dump!' => \$do_dump,
	   'validation!' => \$do_validation,
	   'url-layout=s' => \$url_layout,
	  )
    or die <<EOF;
usage: $0 [-host ...] [-mhost ...] [-comparehost ...] [-comparemhost ...]
	[-skip-lines number] [-url-layout cgi-bin|cgi]
	[-no-file-cache-normalization] [-no-content-length-normalization] [-connection-normalization] [-compression]
	[-dump] [-validation]
	logfile
EOF

die "-url-layout can only be 'cgi-bin' or 'cgi'" if $url_layout !~ /^(cgi-bin|cgi)$/;

my $dump_dir;
my $dump_index;
if ($do_dump) {
    $dump_dir = "/tmp/replay_accesslog_dump";
    $dump_index = 1;
    mkdir $dump_dir if !-d $dump_dir;
}

if (!$host) {
    $host = "bbbike-pps";
}
if (!$m_host) {
    $m_host = "m.$host";
}
my $in_test_mode;
if ($compare_host || $do_validation) {
    require Test::More;
    Test::More::plan('no_plan');
    $in_test_mode = 1;
}
if ($compare_host) {
    require Test::Differences;
    if (!$compare_m_host) {
	$compare_m_host = "m.$compare_host";
    }
}
if ($do_validation) {
    require BBBikeTest;
}

my $ua = LWP::UserAgent->new;
if ($do_compression) {
    $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
}
if ($compare_host) {
    # So things are easier to compare, especially there's no need to
    # handle artificial http headers like "Link"
    $ua->parse_head(0);
}

my $accesslog = shift
    or die "Please specify logfile";

if ($accesslog eq '-') {
    open BW, $accesslog
	or die "Can't open -: $!";
} else {
    require File::ReadBackwards;
    tie *BW, 'File::ReadBackwards', $accesslog
	or die $!;
}
while(<BW>) {
    my $logentry = parse_accesslog($_);
    next if $url_layout eq 'cgi-bin' && $logentry->{file} !~ m{^/cgi-bin/bbbike2?(\.en)?\.cgi};
    next if $url_layout eq 'cgi'     && $logentry->{file} !~ m{^/bbbike/cgi/bbbike2?(\.en)?\.cgi};
    next if $logentry->{file} =~ m{coordssession=\d};
    #next if $logentry->{code} !~ m{^2};
    next if $logentry->{rtype} ne 'GET';

    if ($skip_lines > 0) {
	$skip_lines--;
	if ($in_test_mode) {
	SKIP: { Test::More::skip("because of --skip-line") };
	}
	next;
    }

    $ua->agent($logentry->{agent} . " (BBBike-Test/1.0 replay_accesslog)");
    print STDERR "$logentry->{duration}s " . substr($logentry->{file},0,70) ."...\n";
    my $is_m = $logentry->{host} =~ m{^m\.};

    my $resp;
    my $url;
    my $use_host = $is_m ? $m_host : $host;
    my $use_compare_host = $is_m ? $compare_m_host : $compare_host;

    my $pipe;
    if ($compare_host) {
	$pipe = IO::Pipe->new;
	if (fork == 0) {
	    $pipe->writer;
	    my $compare_url = "http://$use_compare_host$logentry->{file}";

	    my $compare_resp = $ua->get($compare_url);

	    $pipe->print($compare_resp->as_string);
	    $pipe->close;
	    exit;
	}
	$pipe->reader;
    }


    {
	$url = "http://$use_host$logentry->{file}";

	my $t0 = time;
	$resp = $ua->get($url);
	my $elapsed = time - $t0;
	if ($resp->is_success) {
	    my $diff_log_duration = sprintf "%.1f", $elapsed - $logentry->{duration};
	    if ($diff_log_duration > 0) { $diff_log_duration = '+'.$diff_log_duration }
	    my $colored_diff_log_duration = colored([$diff_log_duration =~ /^\+/ ? 'yellow on_black' : 'green on_black'], 'delta ' . $diff_log_duration . 's');
	    printf STDERR "  %.1fs (%s) " . colored(['green on_black'], 'OK') . "\n", $elapsed, $colored_diff_log_duration;
	} else {
	    print STDERR "  " . colored(['red on_black'], $resp->status_line) . "\n";
	}
    }

    if ($do_validation) {
	if ($resp->content_type eq 'application/gpx+xml') {
	    BBBikeTest::gpxlint_string($resp->decoded_content(charset => 'none'), "GPX validation");
	}
    }

    if ($pipe) {
	my $compare_resp_string = do {
	    local $/;
	    <$pipe>;
	};
	my $compare_resp = HTTP::Response->parse($compare_resp_string);

	# note: compare_responses mangles the response objects
	compare_responses($resp, $compare_resp, $url, ignore_hosts => [$use_host, $use_compare_host]);
    }
}

sub compare_responses {
    my($resp, $compare_resp, $testname, %opt) = @_;

    my @ignore_hosts = $opt{ignore_hosts} ? @{ delete $opt{ignore_hosts} } : ();

    die "Unhandled arguments: " . join(" ", %opt) if %opt;

    # XXX group normalizations
    # - necessary always (e.g. date/time differences, different session ids)
    # - necessary only if running on different servers (e.g. perlbal vs. apache, different module versions...)

    # massage responses
    for my $r ($resp, $compare_resp) {
	my $h = $r->headers;
	for my $rh (
		    'client-peer',
		    'client-transfer-encoding', # perlbal vs. apache
		    'content-language', # XXX who's creating this header? I see it on bbbike-pps, but not on cvrsnica
		    'etag',
		    'server',
		    # date headers are theoretically the same, but
		    # only if the requests are really handled in
		    # the same second
		    'client-date',
		    'date',
		    'expires',
		    'last-modified',
		    ($do_file_cache_normalization ? 'x-bbbike-file-cache' : ()),
		    ($do_content_length_normalization ? 'content-length' : ()),
		    ($do_connection_normalization ? 'connection' : ()),
		   ) {
	    $h->remove_header($rh);
	}

	my @cookies = $r->header('set-cookie');
	if (@cookies) {
	    for my $cookie (@cookies) {
		# normalize time component in cookies
		$cookie =~ s{; expires=.*}{; expires=...};
	    }
	    $r->header('set-cookie', \@cookies);
	}

	delete $h->{'::std_case'}; # XXX only disturbing, especially if entries here are not removed if a header was removed above
	$r->previous(undef); # too much noise
	$r->request(undef); # expected diffs, at least the uri/uri_canonical
	delete $r->{_protocol}; # XXX HTTP/1.0 vs. 1.1, depending on perlbal or Apache in front
	$r->{_rc} .= ""; # XXX stringify

	# XXX normalize abs urls vs. half-abs urls, and hosts
	my $content = $r->content;
	for my $ignore_host (@ignore_hosts) {
	    $content =~ s{\Qhttp://$ignore_host\E}{}g;
	}
	# XXX This is probably a bbbike.cgi.config option
	$content =~ s{\Qhttp://www.bbbike.de/cgi-bin/\E(mapserver_address.cgi)}{$1}g;
	$content =~ s{\Q/bbbike/cgi/\E(mapserver_address.cgi)}{$1}g;
	# XXX this too
	$content =~ s{\Qhttp://www.gpsies.com/map.do?url=/cgi-bin/bbbike.cgi}{http://www.gpsies.com/map.do?url=http://bbbike.de/cgi-bin/bbbike.cgi}g;
	$content =~ s{\Qhttp://www.gpsies.com/map.do?url=/cgi-bin/bbbike.en.cgi}{http://www.gpsies.com/map.do?url=http://bbbike.de/cgi-bin/bbbike.cgi}g;
        # XXX and this
	$content =~ s{\Q/cgi-bin/bbbike.cgi?tmp=/}{/BBBike/tmp/}g;
	# normalize session ids (coordssession, oldcs, Session in json/xml/...)
	$content =~ s{(name=coordssession value=)"[^"]+"}{$1""}g;
	$content =~ s{(name="oldcs" value=)"[^"]+"}{$1""}g;
	$content =~ s{("Session":)"[^"]+"}{$1""}g; # json
	$content =~ s{(<Session>)[^<]+}{$1}g; # xml
	$content =~ s{^(Session:) \S+$}{$1 ~}gm; # yaml
	$content =~ s{('Session' => )'[^']+'}{$1''}g; # perldump
	$content =~ s{(\?coordssession=)[0-9a-f_:]+}{$1}g; # leaflet link
	# timestamp in "dummy" param
	$content =~ s{(/cgi-bin/bbbike2?(\.en)?\.cgi\?dummy=)\d+}{$1DUMMY}g;
	# XML::LibXML version in gpx etc. outputs
	$content =~ s{XML::LibXML \d+(\.\d+)+}{XML::LibXML VERSION}g;
	# XXX missing normalizations
	# - different (hash-based?) ordering, maybe should be normalized in bbbike.cgi by importance?
	#   # *  91|8 km</td><td>Fu\xdfg\xe4nger; Parkweg (Teilstrecke); Asphalt mit Sch\xe4den (Teilstrecke)  |8 km</td><td>Parkweg (Teilstrecke); Fu\xdfg\xe4nger; Asphalt mit Sch\xe4den (Teilstrecke)  *
	$r->content($content);
    }

    if ($do_dump) {
	my $new_content = $resp->decoded_content(charset => 'none');
	my $old_content = $compare_resp->decoded_content(charset => 'none');
	if ($new_content ne $old_content) {
	    my $obase = sprintf "$dump_dir/%06d_", $dump_index;
	    my($suffix) = $resp->header('content-disposition') =~ /filename=.*\.(.+?)(?:\b|$)/;
	    if (!$suffix) { $suffix = 'bin' }

	    {
		my $ofile = "${obase}old.$suffix";
		warn "INFO: dump $ofile...\n";
		open my $ofh, ">", $ofile or die "Can't write to $ofile: $!";
		print $ofh $old_content;
		close $ofh or die $!;
	    }

	    {
		my $ofile = "${obase}new.$suffix";
		warn "INFO: dump $ofile...\n";
		open my $ofh, ">", $ofile or die "Can't write to $ofile: $!";
		print $ofh $new_content;
		close $ofh or die $!;
	    }

	    $dump_index++;
	}
    }

    for my $r ($resp, $compare_resp) {
	my $content = $r->content;
	$content =~ s{(.{80})}{$1\n}g; # wrap lines for easier diff'ing
	$r->content($content);
    }

    Test::Differences::eq_or_diff($resp, $compare_resp, $testname, {context=>5});
}

# Taken from Parse::AccessLogEntry and changed
sub parse_accesslog {
    my $Line=shift;
    my $Ref;
    my $Rest;
    my $R2;
    while ($Line =~ s{^(unknown|127\.0\.0\.1|192\.168\.\d+\.\d+|10\.\d+\.\d+\.\d+),\s+}{}) { } # hmmm, strip proxies?
    ($Ref->{host},$Ref->{user},$Ref->{date},$Rest)= $Line=~m,^([^\s]+)\s+-\s+([^ ]+)\s+\[(.*?)\]\s+(.*),;
    my @Dsplit=split(/\s+/,$Ref->{date});
    $Ref->{diffgmt}=$Dsplit[1];
    my @Ds2=split(/\:/,$Dsplit[0],2);
    $Ref->{date}=$Ds2[0];
    $Ref->{time}=$Ds2[1];
    if ($Rest) {
	($Ref->{rtype},$Ref->{file},$Ref->{proto},$Ref->{code},$Ref->{bytes},$R2)=split(/\s/,$Rest,6);
	$Ref->{rtype}=~tr/\"//d;
	$Ref->{proto}=~tr/\"//d;
	if ($R2) {
	    my @Split=split(/\"/,$R2);
	    $Ref->{refer}=$Split[1];
	    $Ref->{agent}=$Split[3];
	    if ($Split[4] =~ m{(\d+)us}) {
		$Ref->{duration} = $1/1_000_000;
	    } else {
		($Ref->{duration})=$Split[4] =~ m{(\d+)};
	    }
	    $Ref->{host} = $Split[5];
	}
    }
    return $Ref;
}

__END__

=head1 NAME

replay_accesslog - replay bbbike.cgi requests using an accesslog

=head1 SYNOPSIS

    cat /path/to/access_log | replay_accesslog [options] -

=head1 DESCRIPTION

=head2 Comparison feature

To enable the comparison feature, the -comparehost switch needs to be
specified. The installation on the compare host should be as similar
as possible, ideally running on the same host with the same server
software, just with a differing vhost.

Currently I don't have this setup, but am comparing cvrsnica against
bbbike-pps. The command line looks like this:

   cat .../live/access.log | grep -v mapserver=1 | grep -v info=1 | grep -v all=1 | ./miscsrc/replay_accesslog -host bbbike.cvrsnica.herceg.de -comparehost bbbike-pps - -skip-lines 0 |& less

Still there are known comparison problems:

=over

=item mapserver not configured on cvrsnica at all

=item info=1 output naturally differs, as things like OS and software and modtime information are contained here

=item all=1 may differ if the locale implementation are different (i.e. sort order for "u" and "ü"); may be fixed once I am using sort_german here

=item same (locale) problem also with the choose_ch_form pages, which may be identified by the existence of (start|via|ziel)charimg.x=... params in URL

=item there are differences in the route list (html, json...) probably because of non-deterministic hash order

=back

=head2 TODO

=cut
