package LIMS::Local::QueryLog;

#===============================================================================
# see logs/README.txt for file permission settings
#===============================================================================

{ # mst fix for failure to re-chmod files after rotation in absence of server restart:
    package Log::Dispatch::File;
    use Class::Method::Modifiers;
    after log_message => sub { delete $_[0]->{chmodded} } # safe to retain after LDF fixed
}

# TODO: see __PACKAGE__ensure_warn_handler_capture if using Apache FastCgiServer

use strict;
use feature 'say';

use Local::DB;
use Try::Tiny;
use SQL::Abstract::Tree; # for pretty-formatting queries
use Data::Printer alias => 'p';

use Readonly;
Readonly::Array my @QUERY_STATEMENTS => qw( SELECT INSERT UPDATE DELETE SHOW );
Readonly::Array my @ENV_OK => qw( DEVEL_SERVER RDBO_DEBUG_ON );

our $SKIP_LOG_QUERY; # allow specific queries to be exempted from log files (eg user msgs)

$|++;

BEGIN {
    # declare var names to make available to _warn():
    use vars qw($LogArgs $cfg $dispatcher $path_to_app $mode $db);
    use POSIX qw(strftime);

    use IO::All;
    use LIMS::DB; # only required by format_query()
    use Data::Printer;
    use LIMS::Local::Utils;
    use LIMS::Local::Config;

    use Log::Dispatch;
    use Log::Dispatch::File;

    use Sub::Exporter -setup =>
        { exports => [ qw(set_querylog_args clear_querylog_args) ] };
    # create new Log::Dispatch::File object (needs to be inside BEGIN block):
    my $new_ldf = sub { Log::Dispatch::File->new(@_) };

    $db  = LIMS::DB->new_or_cached; # only required by format_query()
    $cfg = LIMS::Local::Config->instance;
    $path_to_app = $cfg->{path_to_app_root};

    $dispatcher = Log::Dispatch->new;

    # are we running under fastcgi (deployment) or lims_server (development) mode?
    $mode = $ENV{ROSEDB_DEVINIT} =~ /devinit_prod/
        ? 'deployment' : 'development';

    { # debug level log for SELECT/SHOW queries (fixed filename, rotated file):
        # deployment file needs to be cron-user-writable to allow script to rotate
        # (if www-data:www-data then it needs to be 666):
        my $permission = ( $mode eq 'deployment' ) ? 0666 : 0640;
        my %args = (
            name => 'queries',
            mode => 'append', # happens anyway if close_after_write set to 1
            filename  => "${path_to_app}/logs/${mode}.sql",
            min_level => 'debug',
            permissions => $permission,
            # required to force file to be created after rotation, forces append mode:
            close_after_write => ( $mode eq 'deployment' ), # not required otherwise
        );
        my $o = &$new_ldf(%args);
        $dispatcher->add($o);
    }

    { # info level log for UPDATE/INSERT/DELETE statements (deployment only)
        # production system = archived date-stamped file
        my %args = (
            name => 'edits',
            mode => 'append', # happens anyway with close_after_write set to 1
            filename  => "${path_to_app}/logs/today.sql",
            min_level => 'info',
            # needs to be cron-user-readable to allow script to archive:
            permissions => 0644, # 640 or if www-data:www-data then it needs to be 644
            # required to force file to be created after rotation, forces append mode:
            close_after_write => 1,
        );
        my $o = &$new_ldf(%args);
        $dispatcher->add($o);
    }

    $SIG{__WARN__} = \&_warn_handler;
}


sub set_querylog_args {
    $LogArgs = shift;
#    $LogArgs{username} = $username;
}

sub clear_log_args {
#    %LogArgs = ();
}

sub substitute_placeholders { # p $_[0];
    chomp( my $str = shift ); # p $str; # remove any trailing new-line (eg haem data)
    # remove & capture vars at end of string, matching across multiple lines
    # queries either have "bind params: foo, bar, etc", or "(foo, bar, etc)"
=begin # 2nd regex doesn't work for parens-within-parens, have to use a sub
    $str =~ s/(- bind params: (.*))//s; # bind params captured in $2
    $str =~ s/\(([^(]*)\)$//s; # bind params captured in $1;
=cut
    my ($query, $params) = extract_bind_params($str); # p $query; p $params;
    # RDBO hacked to use \0 to delimit placeholders (also Local::DBIxSimple):
    my @bind = split "\0", $params; # p \@bind; # split /,\s*/, $params;

    # expand omniholders if present (?? -> ?,?,?...) - pass query as ref so
    # changes persist:
    Local::DB::expand_omniholder($db, \$query, \@bind); # p $query;
  # uncomment this to fill in placeholders by SQL::Abstract::Tree:
  # return $query, @bind; # ? doesn't work for text file

    { # append undef's to end of @bind to match no. of placeholders for trailing
      # cols with db default vals which are not supplied in query eg created_at,
      # updated_at, etc; will be converted to 'NULL' later:
        my $n = () = $query =~ /\Q?/g; # warn $n; warn scalar @bind;
        push @bind, undef for ( 1 .. $n - scalar @bind ); # p \@bind;
    }
    # successively replace each '?' in query with next element of @bind array:
    for my $val (@bind) { # warn '=' x 20; p "val:$val; length:". length $val;
        if ( length $val ) { # "defined $val" doesn't work here
            # quote anything other than numbers
            unless ( Scalar::Util::looks_like_number($val) ) {
                # temporarily replace any '?' in $val (confuses the placeholder substitution):
                $val =~ s/\Q?/%%question_mark%%/g; # eg '? myeloproliferative disorder'
                $val = $db->dbh->quote($val);
            }
        }
        else { $val = 'NULL' } # warn $val; # p $query;
        # do placeholder substitution:
        my $ok = $query =~ s/\Q?/$val/; # warn $ok;
    } # p $query; warn '=' x 20;
    $query =~ s/= NULL\b/IS NULL/g; # if query contained '= ?' for an empty placeholder
    # replace temporary question-mark symbols:
    $query =~ s/%%question_mark%%/?/g;
        # warn $query;
    return $query;
}

sub format_query {
    my ($type, $str, @bind) = @_; # console or console_monochrome (for files)
=begin # done by SQL::Abstract::Tree now
    $str =~ s/(FROM|WHERE|ORDER BY|GROUP BY)/\n$1/g;
    $str =~ s/((?<!(OUTER|INNER) )JOIN)/\n\t$1/g;
    my $lh_parens = "\Q("; # p $lh_parens;
    my $rh_parens = "\Q)";
    $str =~ s/(OR $lh_parens)/\n\t$1/g; # p $str;
    # remove blank lines (including just spaces):
    my $query = join "\n", grep { $_ !~ /^\s*$/ } split "\n", $str; # p $query;
    return $query;
=cut
    # my %args = ( fill_in_placeholders => 0/1, profile => $type ); # if needed
    my $formatter = SQL::Abstract::Tree->new({ profile => $type });
    # customise:
    $formatter->indentmap->{from} = 0; # don't indent 'FROM'
    # $formatter->indentmap->{'left outer join'} = 1; # indents but doesn't
    # colorise - delete 'OUTER' instead:
    $str =~ s/(LEFT) OUTER (JOIN)/$1 $2/g; # for colour coding
    delete $formatter->indentmap->{on}; # don't insert new-line before 'ON'
    { # hide some characters which confuse SQLAT:
        $str =~ s/\Q?/%%question_mark%%/g; # eg '? myeloproliferative disorder'
        $str =~ s/\Q(/%%L_paren%%/g; # eg 'Follow-up CML (PB)'
        $str =~ s/\Q)/%%R_paren%%/g; # eg 'Follow-up CML (PB)'
    }
    # protect SQLAT from broken queries, return undef on error (so caller uses
    # original $warn instead); @bind only needed if fill_in_placeholders() required:
    my $query = try { $formatter->format($str, \@bind) } || return undef; # p $query;
    { # reverse hidden chars:
        $query =~ s/%%question_mark%%/?/g;
        $query =~ s/%%L_paren%%/(/g;
        $query =~ s/%%R_paren%%/)/g;
    }
    return $query;
}

# need to call this from app per-request (eg in cgiapp_prerun) if using fastcgi
# in non-external mode - CGI::Fast calls FCGI which re-defines $SIG{__WARN__};
# doesn't cause the same problem when app run as FastCgiExternalServer process
sub ensure_warn_handler_capture { $SIG{__WARN__} = \&_warn_handler; }

# queries either have "- bind params: foo, bar, etc", or "(foo, bar, etc)"
sub extract_bind_params {
    my $string = shift; # warn $string;

    # easiest is "- bind params: foo, bar, etc"
    if ( $string =~ s/(- bind params: (.*))//s ) { # bind params captured in $2
        return ($string, $2);
    }
    # otherwise have to be able to deal with parentheses-within-parentheses
    # eg "(Follow-up CML (PB))":
    my $str_length = length $string; # say $string_length;

    my $gnirts = reverse $string; # warn $gnirts;
    my $start  = my $end = my $i = 0; # set all at zero
    CHAR: # working backwards from original string, eg:
        # (4)                     )4(
        # (2,doi)                 )iod,2(
        # (Follow-up CML (PB))    ))BP( LMC pu-wolloF(
    while ( $gnirts =~ m!( [()] )!gx ) { # capture left-parens & right-parens
        if ( $1 eq ')' ) { # warn "\): \$i:$i; pos: " . pos($gnirts);
            # set end position in original string, ignore any further ')' instances:
            $end = $str_length - pos($gnirts) unless $i;
            $i++; # increment parens counter for each ')'
        }
        elsif ( $1 eq '(' ) { # warn "\(: \$i:$i; pos: " . pos($gnirts);
            $i--; # decrement parens counter for each '('
            # set start position in original string, unless another opened
            # parens remains unclosed (parens counter will still be true):
            next CHAR if $i;
            $start = $str_length - pos($gnirts);
        }
        # finished if we've reached counterpart to initial ')' in reversed string:
        last CHAR if ! $i;
    } # say "start: $start"; say "end: $end";

    # calculate length of params component of string:
    my $params_length = $end - $start - 1; # say "params_length: $params_length";
    # extract params component of string:
    my $params = substr($string, $start + 1, $params_length); # say $params;
    # my $ok = $original_string =~ s/\($params\)//; warn $ok; # can't cope with parens-within-parens
    # remove captured params component from string:
    my $query = substr($string, 0, $start); # say $query;
    return ($query, $params);
}

sub _warn_handler {
    my $warn = shift || return; # warn $SKIP_LOG_QUERY;

    my $sql_statement = grep { $warn =~ /\A$_/ } @QUERY_STATEMENTS;
    my $permitted_env = grep $ENV{$_}, @ENV_OK;

    # nothing required if it's an sql statement & skip logging configured, or
    # RDBO 'Making method ...' and not a permitted ENV:
    return 0 if ( $sql_statement && $SKIP_LOG_QUERY )
        || ( $warn =~ /^Making method/ && not $permitted_env );

    my $time_now = LIMS::Local::Utils::date_and_time_now;

    # write queries to log file:
    if ( $sql_statement ) {
        my ($query, @bind) = substitute_placeholders($warn);
        my $divider = '-+-' x 20;
        # $warn =~ s/\s{2}(JOIN)/\n\t$1/g; # line-break & tab JOIN's
        my $msg = sub { # reading pid id & size kills print run (timeout):
            # sprintf "[%s] %s [%s|%s|%s]\n%s\n", # [time] user [centre, pid ID & size] query:
            #    $time_now, uc $LogArgs->{user}, uc $cfg->{settings}{_centre},
            #    $$, format_number(`ps -p $$ -o size=`+0), $warn;
            sprintf "[%s] %s [%s]\n%s\n/* $divider */\n", # [time] user [centre] query:
                $time_now,
                uc ( $LogArgs->{user} || 'unknown' ),
                uc $cfg->{settings}{_centre},
                # using eval to protect formatter, returns undef on error, so just use $warn:
                format_query('console_monochrome', $query, @bind) || $warn; # monochrome for file
        };
        # deployment db edits go to 'info' level log for archiving:
        if ( $mode eq 'deployment' && $warn =~ /^(INSERT|UPDATE|DELETE)/ ) {
            $dispatcher->log(level => 'info', message => &$msg); # warn 'here';
        }
        $dispatcher->log(level => 'debug', message => &$msg);

        # dump colorised query to stdout if one of permitted envs:
        if ( $permitted_env ) {
            my $stdout = sprintf "%s\n%s", # coloured for console:
                # using eval to protect formatter, returns undef on error, so just use $warn:
                format_query('console', $query, @bind) || $warn, $divider;
            CORE::warn($stdout, "\n"); # \n suppresses "at line #"
        }
    }
    else { CORE::warn($warn) } # warn everything else

=begin # uncomment to dump process size info:
    # my $process_size = `ps -p $$ -o size=`+0;  # moved to 'else' Nov/2016
    if ( $ENV{FAST_CGI} ) {
        my $logfile = $path_to_app . '/logs/processes/' . $$ . '.csv'; # warn $logfile;
        # my $line = join ',', $time_now, $process_size;
        my $line = join ',', $time_now, 'warn:'.$warn; # eg will get here for script errs
        # io($logfile)->append($line, "\n"); # stopped logging Nov/2016
    }
    else {
        my $process_size = `ps -p $$ -o size=`+0;
        CORE::warn sprintf "* process-size=%s\n", $process_size;
    }
=cut
}

=begin # FileRotate causes serious performance hit here
    $dispatcher->add(
        Log::Dispatch::FileRotate->new(
            name        => 'query',
            min_level   => 'debug',
            filename    => "$path_to_app_root/logs/sql.txt",
            permissions => 0666,
            mode        => 'append',
            DatePattern => 'yyyy-MM-dd', # every day # or size => 1, # operates in date or size mode
        )
    );
=cut

1;