#!/usr/bin/perl -w
#
# Run a test
#

use strict;
use warnings;
use open qw( :encoding(UTF-8) :std );
use File::Copy;
use DBI;
use Getopt::Long qw(:config permute);  # allow mixed args.
use File::pushd;
use File::Touch;
use Digest::SHA;

# Options variables
my $debug  = 0;
my $dsn    = "davical";
my $dbuser = "";
my $dbpass = "";
my $webhost  = 'mycaldav';
my $althost  = 'myempty';
my $ldaphost = 'mycaldav_ldap';
my $testdef;
my $suite;
my $case;
my $helpmeplease = 0;


my $testmode = 'DAVICAL';
my $save_location = "/var/log/davical";
my $request_id;
my %conf_file_hashes;

# Hash for eval'd Perl code to store long lived variables in
my %evaled;

my $dbadir = $0;
$dbadir =~ s{/[^/]*$}{};
my $patchdir = $dbadir . "/patches";


GetOptions ('debug!'    => \$debug,
            'dsn=s'     => \$dsn,
            'dbuser=s'  => \$dbuser,
            'dbpass=s'  => \$dbpass,
            'webhost=s' => \$webhost,
            'althost=s' => \$althost,
            'test=s'    => \$testdef,
            'suite=s'   => \$suite,
            'case=s'    => \$case,
            'help'      => \$helpmeplease  );

usage() if ( $helpmeplease || ((!defined($suite) || !defined($case)) && !defined($testdef)));

my $dbh;

# Allow enabling debugging via an environment variable. Useful for debugging CI.
$debug = 1 if ($ENV{DEBUG} || 0) == 1;

my @arguments = ( "--basic", "--proxy", "", "--insecure" );
push @arguments, "--silent"  unless ( $debug );
push @arguments, "--verbose" if ( $debug );

my $url;
my $script;     # Not neede as global, used as flag.
my $script_dir;
my $is_head_request = 0;
my $sql_count = 1;
my @auth = ( "--user", "user1:user1" );

# Allow easier pasting of tests on the command line.
$case =~ s/\.test$//;

if ( ! defined($testdef) ) {
  $testdef = "tests/$suite/$case.test";
}

die "You need to run this from the testing directory!\n"
  unless -d "tests";

# Heuristics to work out if we should make $save_location elsewhere. We want
# /var/log/davical for the CI rig, but within the test directories for local
# runs. Do we?
if ($ENV{USER} ne 'testrunner') {
    $save_location = "tests/$suite/results/";
} elsif (! -w $save_location) {
    warn "$save_location isn't writable, using local location";
    $save_location = "tests/$suite/results/";
}

# Record the request_ids from the web server.
my $request_id_file = "$save_location/$case.request_id";
open(my $REQUEST_ID_FILE, "> $request_id_file")
    || die "Failed to open $request_id_file for writing";

# Allow for application configuration per test file. Ensure the file we
# manage is empty in case the previous test was aborted.
my $dynamic_app_conf_file = 'regression-conf.php.dynamic.per-test';
if (-f $dynamic_app_conf_file) {
    $conf_file_hashes{$dynamic_app_conf_file}{'old'}
        = Digest::SHA->new->addfile($dynamic_app_conf_file)->hexdigest();

    unlink $dynamic_app_conf_file
        || die "Failed to remove $dynamic_app_conf_file: $!\n";
} else {
    $conf_file_hashes{$dynamic_app_conf_file}{'old'} = '';
}

touch $dynamic_app_conf_file;

my $datafile = $testdef;
$datafile =~ s{\.test$}{};
push @arguments, "--header", 'X-DAViCal-Testcase: '.$datafile;
$datafile .= '.data';

my $state = "";
my $data_binary;

my $sql_variable  = "";
my $sql_statement = "";
my $sql_values    = {};
my $perl_code = "";
my $app_conf  = "";
my $queries   = ();
my $replacements = ();
my $line_number  = 0;


open( TEST, '<', $testdef ) or die "Can't open '$testdef'";
while( <TEST> ) {
  my $line = $_;
  $line_number++;

  # Do any variable replacements we have so far
  foreach my $variable ( keys %{$sql_values} ) {
    my $value = $sql_values->{$variable};
    $line =~ s/##$variable##/$value/g;
  }

  if ( $state ne "" ) {
    $line =~ /^BEGIN(?!:)/ && do {
      print "Found a new BEGIN line, while still processing a previous one. Line number: $line_number\n";
      exit 0;
    };

    if ( /^END$state$/ ) {
      if ( $state eq "SQL" ) {
        get_sql_value( $sql_variable, $sql_values, $sql_statement );
      }
      elsif ( $state eq "DOSQL" ) {
        do_sql( $sql_statement );
      }
      elsif ( $state eq "QUERY" ) {
        run_sql($sql_statement);
      }
      elsif ( $state eq "PERL" ) {
        eval($perl_code);
        if ($@) {
          print "Failed to run Perl code: $@\n";
          exit 0;
        }
      }
      elsif ( $state eq "APPCONF" ) {
        write_app_conf($app_conf);
      }
      $state = "";
    }
    elsif ( $state eq "DATA" ) {
      $data_binary .= $line;
    }
    elsif ( $state =~ /^SQL|QUERY|DOSQL$/ ) {
      $sql_statement .= $line;
    }
    elsif ( $state eq "PERL" ) {
      $perl_code .= $line;
    }
    elsif ( $state eq "APPCONF" ) {
      $app_conf .= $line;
    }
    next;
  }

  /^\s*(#|$)/ && next;

  $line =~ /^\s*HEAD\s*(#|$|=)/ && do {
    push @arguments, "--include";
  };

  $line =~ /^\s*MODE\s*=\s*(\S*)(?:,(\d+))/ && do {
    my $mode = $1;
    my $args = $2;

    if (uc($mode) =~ /^TAP$/) {
      $testmode = 'TAP';
      use Test::More;

      if ($args =~ /^\d+$/) {
        plan tests => $args;
      }
    } else {
      die "Unknown test mode: $1";
    }
  };

  $line =~ /^\s*VERBOSE\s*(#|$|=)/ && do {
    push @arguments, "--verbose";
  };

  $line =~ /^\s*NOAUTH\s*(#|$|=)/ && do {
    @auth = ();
  };

  $line =~ /^\s*DIGEST\s*(#|$|=)/ && do {
    push @arguments, "--digest";
    @auth = ( "--user", $1 );
  };

  $line =~ /^\s*AUTH\s*=\s*(\S.*)$/ && do {
    @auth = ( "--user", $1 );
  };

  $line =~ /^\s*DATA\s*=\s*(\S.*)$/ && do {
    my $basename = $1;
    if ( defined($suite) ) {
      if ( -e "tests/$suite/$basename.data" ) {
        $datafile="tests/$suite/$basename.data";
      }
      elsif ( -e "tests/$suite/$basename" ) {
        $datafile="tests/$suite/$basename";
      }

    }
    elsif ( -e "$basename.data" ) {
      $datafile="$basename.data";
    }
    elsif ( -e $basename ) {
      $datafile=$basename;
    }
    else {
      die "Can't find DATA file $basename or $basename.data";
    }
  };

  $line =~ /^BEGINDATA\s*$/ && do {
    $data_binary = "";
    $state = "DATA";
  };

  $line =~ /^BEGINPERL\s*$/ && do {
    $perl_code = "";
    $state = "PERL";
  };

  $line =~ /^BEGINAPPCONF\s*$/ && do {
    $app_conf = "";
    $state = "APPCONF";
  };

  $line =~ /^(?:BEGIN)?GETSQL\s*=\s*(\S.*)$/ && do {
    $sql_variable = $1;
    $sql_statement = "";
    $state = "SQL";
  };

  $line =~ /^(?:BEGIN)?DOSQL\s*$/ && do {
    $sql_statement = "";
    $state = "DOSQL";
  };

  $line =~ /^\s*APPCONF\s*=\s*(\S.*)$/ && do {
      my $basename = $1;
      my $test_app_conf_file;

      if ( -e "tests/$suite/$basename.appconf" ) {
          $test_app_conf_file="tests/$suite/$basename.appconf";
      }
      elsif ( -e "tests/$suite/$basename" ) {
          $test_app_conf_file="tests/$suite/$basename";
      }

      if (! defined $test_app_conf_file) {
          die "Can't find app conf file $basename or $basename.appconf";
      }

      copy $test_app_conf_file, $dynamic_app_conf_file
          || die "Failed to copy $test_app_conf_file to $dynamic_app_conf_file: $!\n";
  };


  $line =~ /^REPLACE\s*=\s*(\S)(.*)$/ && do {
    my $separator = $1;
    $2 =~ /^([^$separator]*)$separator([^$separator]*)$separator$/ && do {
      push @$replacements, { 'pattern' => $1, 'replacement' => $2 };
    };
  };

  $line =~ /^(?:BEGIN)?QUERY\s*$/ && do {
    $sql_statement = "";
    $state = "QUERY";
  };

  $line =~ /^\s*TYPE\s*=\s*(\S.*)$/ && do {
    if ( $1 eq "HEAD" ) {
      push @arguments, "--head";
    }
    else {
      push @arguments, "--request", $1;
    }
  };

  # HTTP headers to send with curl
  $line =~ /^\s*HEADER\s*=\s*(\S.*)$/ && do {
    my $arg = $1;
    $arg =~ s{regression.host}{$webhost};
    $arg =~ s{regression_ldap.host}{$ldaphost};
    $arg =~ s{alternate.host}{$althost};
    push @arguments, "--header", $arg;
  };

  # URL to use with curl
  $line =~ /^\s*URL\s*=\s*(\S.*)$/ && do {
    $url = $1;
    $url =~ s{regression.host}{$webhost};
    $url =~ s{regression_ldap.host}{$ldaphost};
    $url =~ s{alternate.host}{$althost};

    run_curl($url);
  };


  # The directory to run the next SCRIPT in.
  $line =~ /^\s*SCRIPT_DIR\s*=\s*(\S.*)$/ && do {
    $script_dir = $1;
  };

  # Run this SCRIPT, collect the output.
  $line =~ /^\s*SCRIPT\s*=\s*(\S.*)$/ && do {
    $script=$1;
    $script =~ s{regression.host}{$webhost};
    $script =~ s{regression_ldap.host}{$ldaphost};
    $script =~ s{alternate.host}{$althost};

    my $dir = pushd($script_dir)
      if defined $script_dir;

    open RESULTS, "-|", $script;
    while( <RESULTS> ) {
      my $line = $_;
      foreach my $replacement ( @$replacements ) {
        $line =~ s/$replacement->{'pattern'}/$replacement->{'replacement'}/;
      }
      print $line;
    }

    $script_dir = undef;
  };

  $line =~ /^\s*STATIC\s*=\s*(.*?)\s*$/ && do {
    my $source = "tests/$suite/static/$1";
    my $dest = "../htdocs/testfiles";

    die "Can't find $source to copy into $dest\n"
      unless -f $source;

    mkdir $dest
      unless -d $dest;

    copy($source, $dest)
      || die "Failed to copy $source: $1";
  }
}

if ( ! defined $url && ! defined $script && ! defined $sql_statement
     && ! defined $perl_code ) {
  print <<EOERROR ;
The .test file must contain either at least one URL, SCRIPT, PERL, or QUERY.
EOERROR
  exit (2);
}

if ($testmode eq 'TAP') {
  done_testing();
}

exit(0);

sub run_curl {
  my $url = shift;

  maybe_restart_apache();

  my @args = @arguments;
  push @args, @auth;

  if ( -f $datafile ) {
    push @args, "--data-binary", "\@$datafile";
  }
  elsif ( defined($data_binary) ) {
    push @args, "--data-binary", $data_binary;
  }
  else {
    undef($datafile);
  }

  push @args, $url;

  warn join " ", "curl", @args, "\n"
    if $debug;

  open RESULTS, "-|", "curl", @args;
  while ( <RESULTS> ) {
    my $line = $_;

    # Grab the web server request_id for later reference
    if ($line =~ /^Request-ID: (.*?)\s*$/) {
      $ENV{REQUEST_ID} = $1;
      $request_id      = $1;
      print $REQUEST_ID_FILE "$1\n";
    }

    foreach my $replacement ( @$replacements ) {
      $line =~ s/$replacement->{'pattern'}/$replacement->{'replacement'}/;
    }

    print $line;
  }

  print "\n";
}

sub run_sql {
  my $query = shift;

  print "SQL Query " . $sql_count++ . " Result:\n";

  opendb() unless defined($dbh);

  # run SQL statement and dump results, into array of hashes
  my $results = $dbh->selectall_arrayref($sql_statement, { Slice => {} } );

  if ( $dbh->err ) {
    print $dbh->errstr, "\n";
    return;
  } elsif (! defined $results) {
    print "No results from SQL query\n";
    return;
  }

  foreach my $row ( @$results ) {
    warn "Query result ================================================\n"
        if $debug;
    my $sep = "";
    foreach my $name ( sort keys %$row ) {
      my $value = $row->{$name};
      $value = 'NULL' unless ( defined($value) );
      printf("%17.17s: >%s<\n", $name, $value );
    }
    print "\n";
  }
}



=item do_sql( $sql_statement )

Queries the database using the specified statement and
ignores the result.

=cut

sub do_sql {
  my $sql = shift;

  opendb() unless defined($dbh);
  $dbh->do($sql);

  if ( $dbh->err ) {
    print $dbh->errstr, "\n";
    return;
  }

  print "SQL executed successfully.\n";
  print $sql, "\n";
}


=item get_sql_value( $sql_variable, $sql_values, $sql_statement )

Queries the database using the specified statement and puts
the first column of the first row returned into the
hash referenced $sql_values->{$sql_variable} for replacement
later in the parsing process.

=cut

sub get_sql_value {
  my $varname = shift;
  my $values  = shift;
  my $sql = shift;

  opendb() unless defined($dbh);
  my $results = $dbh->selectall_arrayref($sql);

  if ( $dbh->err ) {
    print $dbh->errstr, "\n";
    return;
  }

  warn "RESULT for $varname is ", $results->[0][0], "\n"
    if $debug;

  $values->{$varname} = (defined($results->[0][0]) ? $results->[0][0] : "");
}

=item opendb()

Opens the database connection to the global $dbh handle.
Note that the standard PostgreSQL environment variables will also work
with DBD::Pg.

=cut

sub opendb {
  $dsn = "dbi:Pg:dbname=$dsn";
  $dbh = DBI->connect($dsn, $dbuser, $dbpass, { AutoCommit => 1 } ) or die "Can't connect to database $dsn";
  $dbh->do("SET TIMEZONE TO 'Pacific/Auckland'");
}

sub webui_login {
    my %args = (
        username => undef,
        password => undef,
        url      => undef,
        failauth => 0,
        @_,
    );

    use Test::WWW::Mechanize;
    my $mech = Test::WWW::Mechanize->new;

    $mech->get_ok($args{url}, "Fetch first page");
    $mech->text_contains('Log On Please', "Not logged in");
    $mech->submit_form_ok(
        {
            fields => {
                username => $args{username},
                password => $args{password},
            },
        }, "Login to site"
    );

    if ($args{failauth}) {
        # We expected failure.
        $mech->text_contains("You must log in to use this system", "Failed to login");
    } else {
        $mech->text_contains("You are logged on as " . $args{username}, "Logged in");
    }

    return $mech;
}

=item write_app_conf()

Write per test configuration entries to the DAViCal regression test server
configuration.

=cut

sub write_app_conf {
    my $content = shift;

    # We may want to append extra content to a common file.
    open(my $FILE, ">> $dynamic_app_conf_file")
        || die "Failed to open $dynamic_app_conf_file for writing";
    print $FILE $content;
}

=item maybe_restart_apache

Check to see if the DAViCal config file snippet has changed, if it has,
restart Apache to make sure the new config is picked up.

=cut

sub maybe_restart_apache {
    my $restarted = 0;

    for my $file (keys %conf_file_hashes) {
        my $curr = (-f $file ? Digest::SHA->new->addfile($file)->hexdigest() : '');

        if (! $restarted && $curr ne $conf_file_hashes{$file}{old}) {
            system("sudo /usr/sbin/apache2ctl restart\n");
            $restarted = 1;
        }

        # We've restarted Apache, treat the current hashes as old now, in
        # case we make multiple queries to the server, or modify the config
        # files again within this test file.
        $conf_file_hashes{$file}{old} = $curr
            if $restarted;
    }
}


sub usage {
  print <<EOERROR ;

Usage:
  dav_test [DB opts] [--suite <testsuite> --case <testname>] | [--test <filename>]

This program will read the file 'tests/<testsuite>/<testname>.test
and follow the instructions there.

The following options are available for controlling the database, for
those test cases which might require it:
  --dsn <database>[;port=NNNN][;host=example.com]
  --dbuser <user>
  --dbpass <password>


The test instructions will include lines defining the test like:
=================================================
# This is an example
HEADER=Depth: 0
HEADER=Content-type: text/xml
TYPE=PROPFIND

HEAD

DATA=OTHERTEST

URL=http://mycaldav/caldav.php/andrew/

# This will let you use ##somename## for this value after this
GETSQL=somename
SELECT column FROM table WHERE criteria
ENDSQL

# The data can be included in line
BEGINDATA
... data content ...
ENDDATA

# The result could be some SQL output
QUERY
SELECT something, or, other FROM table ...
ENDQUERY

# Run some Perl code
BEGINPERL
my \$variable = 'foo';
ENDPERL

# Dynamically add content to the DAViCal configuration file for this test.
# Allows ad-hoc config changes for tests. See also APPCONF. If APPCONF isn't
# used, then you must start this with "<?php" as below. If APPCONF is used,
# then it must start with "<?php".
BEGINAPPCONF
<?php

\$valid_php = "in here";
ENDAPPCONF

REPLACE=/pattern/replacement/
=================================================

URL      The URL to request from (request is sent when seen).
HEADER   An additional header for the request
TYPE     The type of request (e.g. GET/PUT/POST/REPORT/...)
HEAD     Whether to include the headers in the recorded response
VERBOSE  Whether to provide the full request / response headers.
DATA     The name of a different test in this suite to use data from.
REPLACE  A perl regex replacement to post-process the result through.
APPCONF  A file that will be insert into the DAViCal config file. This is
         inserted first, before any content in BEGINAPPCONF/ENDAPPCONF to
         allow a common config file for a set of tests, but also to allow
         for individual test overrides.

Additionally, if a file 'tests/<testsuite>/<testname>.data' exists
the contents of that file will be sent in the body of the request.

EOERROR
  exit(1);
}