#!/usr/bin/perl
#
# This script exposes access to the Perl modules written for the Anvil! system.
# It can be executed on Anvil! nodes, DR hosts, or strikers.
#
# Upon execution, creates an instance of Anvil::Tools which provides reference
# to all *.pm instances under the Anvil/Tools/ directory. With these
# references, proceed to execute 1 operation specified by one of --query,
# --sub, or --data flags.
#
#
# --- Notes ---
#
# * In this documentation, a "JSON object" does NOT include array.
#
#
# --- Usages ---
#   To use interactively or process a script:
#   anvil-access-module [--script <file path>]
#
#   * Inputs are processed by lines. Each line must satisfy one of the
#     following format:
#
#     [<line UUID> ]r[ uuid=<database UUID>] <SQL script>
#
#       Performs a data query script (SELECT) on the database. Targets the
#       specified database if "uuid=" is provided.
#
#     [<line UUID> ]w[ uuid=<database UUID>] <SQL script, i.e., >
#
#       Performs a data definition or manipulation script on the database.
#
#     [<line UUID> ]x <module->subroutine, or hash available in Anvil::Tools class> [space-separated positional subroutine parameters...]
#
#       Executes an Anvil module subroutine OR retrieves a hash value. This is
#       designed to expose the most-used parts of "$anvil->..." to the
#       interactive/script function of this tool.
#
#       * A quoted string is treated as one positional parameter with the
#         wrapping quotes removed.
#
#       ! The tool will attempt to decode each positional parameter as JSON.
#         Parameters that fail the decoding will be passed to the subroutine
#         as-is.
#
#   * The response will be prefixed with line UUID if provided. Line UUID must
#     be followed by a space to be recognized.
#
#   * Lines that fail to meet the format above are ignored.
#
#   To read from database:
#   anvil-access-module --query <SQL query> [--uuid <database UUID>]
#   > [ [row0_value0, row0_value1, row0_value2, ...],
#       [row1_value0, row1_value1, row1_value2, ...],
#       [row2_value0, row2_value1, row2_value2, ...], ... ]
#
#   To write to database:
#   anvil-access-module --mode write --query <SQL command> [--uuid <database UUID>]
#   > { write_code: 0 | 1 | "!!error!!" }
#
#   * The --query flag is required for specifying the SQL query (or command)
#     for both read and write.
#
#   * To perform a write, the --mode flag must be set to 'write' (quotes are
#     optional).
#
#   * It's possible to specify which database to access by providing the
#     UUID; this can be ignored most of the time because it's rare to only
#     target one database in a redundant system.
#
#   ! A non-zero 'write_code' means the write failed. Try running the same
#     subroutine with a lower debug value, for example:
#
#     anvil-access-module --sub 'write' --sub-params '{ "query": <SQL command>, "debug": 2 }'
#
#
#   To execute a Perl subroutine:
#   anvil-access-module --sub <subroutine name> [--sub-module <module name>] [--sub-params <JSON object>]
#   > { sub_results: only_value | [value0, value1, value2, ...] }
#
#   * The --sub flag is required for specifying the chain to the target
#     subroutine. The usual format is:
#
#     <.pm module name>-><subroutine name>
#
#     The chain separator can be arrow (->), or dot (.), for example:
#
#     ... --sub "Database->query" ...
#
#   * The --sub-params flag accepts a JSON object which will be converted to a
#     Perl hash and passed to the target subroutine as parameters.
#
#     This flag defaults to '{}' (blank JSON object).
#
#   ! In the case where the target subroutine returns a tuple or array, the
#     'sub_results' key in the output JSON object will be an array.
#
#
#   To access the data hash:
#   anvil-access-module --data <JSON object> [--predata <JSON array>]
#   > { ... }
#
#   * The --data flag is required for specifying the data structure to copy
#     from the data hash. The script will recursively traverse each of the
#     given JSON object's properties and pick values from the data hash for
#     each property key that exists.
#
#     JSON object:
#     {
#       [key: string]: boolean | number | null | <JSON object>;
#     }
#
#   * The --predata flag is a 2 dimentional JSON array for speficying 1 or more
#     subroutines to execute in ascending-index-order before extracting data
#     from the data hash. Each element of the top-level array contains a
#     2nd-level array.
#
#     Each 2nd-level array contains:
#     * in element 0, a string in Perl syntax that identifies the target
#       subroutine, and
#     * in element 1, a JSON object with parameters to supply to the target
#       subroutine.
#
#     JSON array:
#     [subroutine: string, parameters: object][];
#
#
# --- Example usages ---
#
#   Select hosts from database:
#   $ anvil-access-module --query "SELECT host_uuid, host_name FROM hosts;"
#   [["09a3ac2f-5904-42a6-bb5e-28cffc7fa4af","mockhost01"],["df3653e3-7378-43e2-be2a-ead1b8aee881","mockhost02"],...]
#
#   Get local host name:
#   $ anvil-access-module --sub 'host_name' --sub-module 'Get' --sub-params '{ "debug": 1 }'
#   {"sub_results":"..."}
#
#   Get database data and 1 path from data hash:
#   $ anvil-access-module --data '{ "database": true, "path": { "exe": { "grep": true } } }'
#   {"database":{...},"path":{"exe":{"grep":"/usr/bin/grep"}}}
#
#   Get network data collected and recorded by the Network->get_ips() subroutine:
#   $ anvil-access-module --predata '[ ["Network->get_ips", { "debug": 1 }] ]' --data '{ "network": true }'
#   {"network":{...}}
#

use strict;
use warnings;

use Anvil::Tools;
use Cwd;
use Data::Dumper;
use File::Spec::Functions;
use File::Temp qw(tempdir);
use IO::Socket::UNIX;
use JSON;
use Text::ParseWords;

$| = 1;

my $THIS_FILE           =  ($0 =~ /^.*\/(.*)$/)[0];
my $running_directory   =  ($0 =~ /^(.*?)\/$THIS_FILE$/)[0];

$running_directory =~ s/^\./$ENV{PWD}/ if $running_directory =~ /^\./ && $ENV{PWD};

my $scmd_db_read  = "r";
my $scmd_db_write = "w";
my $scmd_execute  = "x";

main();

##################################################
# Functions
##################################################

sub access_chain
{
	my $parameters = shift;
	# required:
	my $anvil      = $parameters->{anvil};
	my $chain_str  = $parameters->{chain};
	# optional:
	my $chain_args = $parameters->{chain_args} // [];

	my @chain        = split(/->|[.]/, $chain_str);
	my $key_index    = 0;
	my $intermediate = $anvil;
	my @results      = (1);

	$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => { chain => prettify(\@chain) } });

	foreach my $key (@chain)
	{
		my $is_intermediate_hash = is_hash($intermediate);
		my $is_last_key          = $key_index == $#chain;

		$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => {
			is_intermediate_hash => $is_intermediate_hash,
			is_last_key          => $is_last_key,
			key                  => $key,
			key_index            => $key_index,
		} });

		if ($is_intermediate_hash) # Left-hand is hash; treat it as reading data
		{
			last if (not exists $intermediate->{$key});

			if ($is_last_key)
			{
				# Allow operators on hash children. Mainly used for cleaning up before refreshing children of $anvil->data.
				my $op = $chain_args->[0] // "";

				if ($op eq "=")
				{
					my $op_value = $chain_args->[1];

					$intermediate->{$key} = $op_value if (defined $op_value);
				}

				@results = ($intermediate->{$key});

				last;
			}

			$intermediate = $intermediate->{$key};
		}
		else # Left-hand is not hash; treat it as blessed/class object (module) and try to call a method from it
		{
			# Don't continue follow the chain when key if not found
			# Note: can() results in truthy when key refers to something that can return a value
			eval { $intermediate->can($key) } or last;

			# On the last key of the chain; try to execute the subroutine if it exists
			if ($is_last_key)
			{
				# Go through each argument and replace any 'anvil->' strings with their real value.
				# At the time of writing, the only expected use case is calling $anvil->_make_hash_reference
				for my $arg_i (0 .. $#{$chain_args})
				{
					my $arg = $chain_args->[$arg_i];

					if ($arg =~ s/^anvil(->|\.)//)
					{
						my ($replacement) = access_chain({ anvil => $anvil, chain => $arg });

						$chain_args->[$arg_i] = $replacement;
					}
				}

				# Trailing 1 means the eval block will return success if the subroutine and assign succeeded
				eval { (@results) = $intermediate->${key}(@$chain_args); 1; };

				last;
			}

			$intermediate = $intermediate->${key};
		}

		$key_index += 1;
	}

	return (@results);
}

# only used by child processes to clone the parent's database handles
sub clone_database_handles
{
	my $parameters = shift;
	my $anvil      = $parameters->{anvil};

	foreach my $uuid (sort { $a cmp $b } keys %{$anvil->data->{database}})
	{
		if ((not exists $anvil->data->{cache}{database_handle}{$uuid}) or (not $anvil->data->{cache}{database_handle}{$uuid}))
		{
			# Useless handle, skip it.
			next;
		}
		# get the copied parent's database handle, which was made when fork()
		my $dbh = $anvil->data->{cache}{database_handle}{$uuid};
		# clone the parent's database handle for child use
		my $child_dbh = $dbh->clone();
		# destroy the copied parent's dbh; this will not close the parent's original database handle because auto_inactive_destroy is set
		undef $anvil->data->{cache}{database_handle}{$uuid};
		# add the cloned child's dbh
		$anvil->data->{cache}{database_handle}{$uuid} = $child_dbh;
	}
}

sub db_access
{
	my $parameters = shift;
	# required:
	my $anvil      = $parameters->{anvil};
	my $sql        = $parameters->{sql};
	# optional:
	my $mode       = $parameters->{db_access_mode} // "";
	my $uuid       = $parameters->{db_uuid};

	$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => {
		mode => $mode,
		sql  => $sql,
		uuid => $uuid,
	}, prefix => "db_access" });

	my $access_parameters = { query => $sql, uuid => $uuid, source => $THIS_FILE, line => __LINE__ };

	if ($mode eq "write")
	{
		my $result = $anvil->Database->write($access_parameters);

		return { write_code => $result };
	}
	else
	{
		my $result = $anvil->Database->query($access_parameters);

		return $result;
	}
}

sub emit
{
	#
	# Events in this context are simply printing the event name before
	# and/or after operations. The output should enable other programs to
	# parse and activate additional logic as necessary.
	#
	# Event names should be present-tense before an operation, and
	# past-tense after.
	#
	pstdout("event=".$_[0]);
}

sub get_scmd_args
{
	my $parameters = shift;
	# required:
	my $anvil      = $parameters->{anvil};
	my $input      = $parameters->{input};
	my $get_values = $parameters->{get_values};
	# optional:
	my $cmd        = $parameters->{cmd};
	my $arg_names  = $parameters->{names} // [];

	$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => {
		cmd        => $cmd,
		get_values => $get_values,
		input      => $input,
		arg_names  => $arg_names,
	}, prefix => "get_scmd_args" });

	my $i       = 0;
	my $args    = {};
	my @matches = $get_values->($input, $cmd);

	foreach (@matches)
	{
		my $arg_name = $arg_names->[$i++] // "".$i;

		$args->{$arg_name} = $_ if defined $arg_name;
	}

	return $args;
}

sub handle_connections
{
	my $parameters = shift;
	my $anvil      = $parameters->{anvil};
	my $server     = $parameters->{server};

	local $SIG{INT}  = sub {
		emit("sigint");

		close($server);

		emit("exit");

		$anvil->catch_sig({ signal => "INT" });
	};

	local $SIG{TERM} = sub {
		emit("sigterm");

		close($server);

		emit("exit");

		$anvil->catch_sig({ signal => "TERM" });
	};

	emit("listening");

	while (my $responder = $server->accept() or do {
		pstderr("failed to accept connections; cause: ".$!);

		close($server);

		$anvil->nice_exit({ exit_code => 1 });
	})
	{
		my $request_line = <$responder>;

		# responder is done reading
		$responder->shutdown(SHUT_RD);

		$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => { request_line => $request_line } });

		last if ($request_line =~ /^(?:q|quit)\s*$/);

		my $pid = fork;

		if (not defined $pid)
		{
			pstderr("failed to fork on receive; cause: ".$!);

			next;
		}

		if ($pid)
		{
			emit("responder:".$pid."-forked");

			next;
		}

		#############
		### BEGIN ### responder block
		#############

		# close the server because the child doesn't need it
		close($server);

		# disconnect from the parent's outputs to avoid interference

		close(STDOUT);
		close(STDERR);

		# redirect outputs to the responder for transport

		open(STDOUT, ">&", $responder) or do {
			print $responder "failed to open STDOUT; cause: ".$!."\n";

			$responder->shutdown(SHUT_RDWR);

			$anvil->nice_exit({ db_disconnect => 0, exit_code => 1 });
		};

		open(STDERR, ">&", $responder) or do {
			print $responder "failed to open STDERR; cause: ".$!."\n";

			$responder->shutdown(SHUT_RDWR);

			$anvil->nice_exit({ db_disconnect => 0, exit_code => 1 });
		};

		# clone the database handle for this child to avoid interfering with another process that needs to use the database
		clone_database_handles({ anvil => $anvil });

		my @cmd_lines = split(/;;/, $request_line);

		foreach my $cmd_line (@cmd_lines)
		{
			$cmd_line =~ s/^\s+//;
			$cmd_line =~ s/\s+$//;

			my $cmd_line_id;

			if ($cmd_line =~ s/^([[:xdigit:]]{8}-(?:[[:xdigit:]]{4}-){3}[[:xdigit:]]{12})\s+//)
			{
				$cmd_line_id = $1;
			}

			$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => {
				cmd_line    => $cmd_line,
				cmd_line_id => $cmd_line_id,
			} });

			if ($cmd_line =~ /^$scmd_db_read\s+/)
			{
				process_scmd_db({ anvil => $anvil, cmd => $scmd_db_read, input => $cmd_line, lid => $cmd_line_id });
			}
			elsif ($cmd_line =~ /^$scmd_db_write\s+/)
			{
				process_scmd_db({ anvil => $anvil, cmd => $scmd_db_write, input => $cmd_line, lid => $cmd_line_id });
			}
			elsif ($cmd_line =~ /^$scmd_execute\s+/)
			{
				process_scmd_execute({ anvil => $anvil, input => $cmd_line, lid => $cmd_line_id });
			}
		}

		# responder is done writing
		$responder->shutdown(SHUT_WR);

		emit("responder:".$$."-exit");

		$anvil->nice_exit({ db_disconnect => 0, exit_code => 0 });

		#############
		#### END #### responder block
		#############
	}

	close($server);

	emit("exit");

	$anvil->nice_exit({ exit_code => 0 });
}

sub is_array
{
	return ref($_[0]) eq "ARRAY";
}

sub is_hash
{
	return ref($_[0]) eq "HASH";
}

sub main
{
	my $anvil = Anvil::Tools->new();

	$anvil->Get->switches;

	my $daemonize   = $anvil->data->{switches}{'daemonize'}   // 0;
	my $script_file = $anvil->data->{switches}{'script'}      // "-";
	my $working_dir = $anvil->data->{switches}{'working-dir'} // cwd();

	emit("initialized");

	$anvil->Database->connect({ auto_inactive_destroy => 1 });
	$anvil->Log->entry({ source => $THIS_FILE, line => __LINE__, level => 2, secure => 0, key => "log_0132" });
	if (not $anvil->data->{sys}{database}{connections})
	{
		# No databases, exit.
		$anvil->Log->entry({ source => $THIS_FILE, line => __LINE__, level => 0, 'print' => 1, priority => "err", key => "error_0003" });
		$anvil->nice_exit({ exit_code => 1 });
	}

	emit("connected");

	my $tmp_dir;

	eval {
		$tmp_dir = tempdir(
			CLEANUP => 1,
			DIR     => $working_dir,
		);
	} or do {
		pstderr("failed to create server directory; cause: ".$@);

		$anvil->nice_exit({ exit_code => 1 });
	};

	my $socket_path = catfile($tmp_dir, "socket");

	emit("socket:".$socket_path);

	my $server = IO::Socket::UNIX->new(
		Blocking => 1,
		Local    => $socket_path,
		Listen   => 100,
		Type     => SOCK_STREAM,
	) or do {
		pstderr("failed to create server using ".$socket_path."; cause: ".$@);

		$anvil->nice_exit({ exit_code => 1 });
	};

	# make child processes start-and-forget because we don't need to wait for them
	local $SIG{CHLD} = "IGNORE";

	if ($daemonize)
	{
		return handle_connections({ anvil => $anvil, server => $server });
	}

	# make 1 child to interact on stdio
	my $interface_pid = fork;

	if (not defined $interface_pid)
	{
		pstderr("failed to fork IO interface; cause: ".$!);

		close($server);

		$anvil->nice_exit({ exit_code => 1 });
	}

	if ($interface_pid)
	{
		emit("interface:".$interface_pid."-forked");

		handle_connections({ anvil => $anvil, server => $server });
	}

	#############
	### BEGIN ### interface block
	#############

	# close the server because the child doesn't need it
	close($server);

	my $script_file_handle;

	local $SIG{INT}  = sub {
		emit("interface:".$$."-sigint");

		close($script_file_handle);

		emit("interface:".$$."-exit");

		$anvil->catch_sig({ signal => "INT" });
	};

	local $SIG{TERM} = sub {
		emit("interface:".$$."-sigterm");

		close($script_file_handle);

		emit("interface:".$$."-exit");

		$anvil->catch_sig({ signal => "TERM" });
	};

	eval {
		# TODO: make this script read piped input

		$script_file = "-" if ($script_file =~ /^#!SET!#$/);

		$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => { script_file => $script_file } });

		if ($script_file =~ /^-$/)
		{
			open($script_file_handle, "-");
		}
		else
		{
			open($script_file_handle, "< :encoding(UTF-8)", $script_file);
		}
	} or do {
		# open() sets $! upon error, different from the database module failure (which sets $@)
		pstderr("failed to open ".$script_file." as script input; cause: ".$!);

		$anvil->nice_exit({ exit_code => 1 });
	};

	emit("interface:".$$."-ready");

	while (my $script_line = <$script_file_handle>)
	{
		$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => { script_line => $script_line } });

		if ($script_line =~ /^(?:q|quit)\s*$/)
		{
			my $quitter = IO::Socket::UNIX->new(
				Peer => $socket_path,
				Type => SOCK_STREAM,
			) or do {
				pstderr("failed to create QUIT connection to ".$socket_path."; cause: $@");

				$anvil->nice_exit({ exit_code => 1 });
			};

			print $quitter $script_line;

			$quitter->shutdown(SHUT_RDWR);

			last;
		}

		my $pid = fork; # the child process starts here when spawned successfully:

		# - fork returns `undef` when it fails to spawn the child
		# - fork returns the child's pid to the parent
		# - fork returns `0` to the child

		if (not defined $pid) {
			pstderr("failed to fork on send; cause: ".$!);

			next;
		}

		if ($pid)
		{
			emit("requester:".$pid."-forked");

			next;
		}

		#############
		### BEGIN ### requester block
		#############

		# the child doesn't need to process input
		close($script_file_handle);

		my $requester = IO::Socket::UNIX->new(
			Peer => $socket_path,
			Type => SOCK_STREAM,
		) or do {
			pstderr("failed to create connection to ".$socket_path."; cause: ".$@);

			$anvil->nice_exit({ db_disconnect => 0, exit_code => 1 });
		};

		print $requester $script_line;

		$requester->shutdown(SHUT_WR);

		while (my $line = <$requester>)
		{
			chomp($line);

			eval {
				my $decoded = decode_json($line);
				my $encoded = JSON->new->utf8->allow_blessed->pretty->encode($decoded);

				pstdout($encoded);
			} or do {
				pstdout($line);
			}
		}

		$requester->shutdown(SHUT_RD);

		emit("requester:".$$."-exit");

		$anvil->nice_exit({ db_disconnect => 0, exit_code => 0 });

		#############
		#### END #### requester block
		#############
	}

	close($script_file_handle);

	emit("interface:".$$."-exit");

	$anvil->nice_exit({ db_disconnect => 0, exit_code => 0 });

	#############
	#### END #### interface block
	#############
}

sub prettify
{
	my $var_value = shift;
	my $var_name  = shift;

	local $Data::Dumper::Indent  = 1;
	local $Data::Dumper::Varname = $var_name;
	local $Data::Dumper::Terse = (defined $var_name) ? 0 : 1;

	return Dumper($var_value);
}

sub process_scmd_db
{
	my $parameters = shift;
	# required:
	my $anvil      = $parameters->{anvil};
	my $cmd        = $parameters->{cmd};
	my $input      = $parameters->{input};
	# optional:
	my $lid        = $parameters->{lid} // "";

	my $mode;

	if ($cmd eq $scmd_db_write)
	{
		$mode = "write";
	}

	$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => {
		cmd   => $cmd,
		input => $input,
		lid   => $lid,
		mode  => $mode,
	}, prefix => "process_scmd_db" });

	my $sargs = get_scmd_args({
		anvil      => $anvil,
		cmd        => $cmd,
		input      => $input,
		get_values => sub { my $c = $_[1]; return $_[0] =~ /^$c\s+(?:uuid=([^\s]+))?\s*(.*)$/; },
		names      => ["uuid", "script"],
	});

	$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => { sargs => prettify($sargs) } });

	eval {
		my $results = db_access({ anvil => $anvil, db_uuid => $sargs->{uuid}, sql => $sargs->{script}, db_access_mode => $mode });

		$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => { results => prettify($results) } });

		my $output = $lid.JSON->new->utf8->encode($results);

		pstdout($output);
	} or do {
		my $error = "failed to access database; cause: ".$@;

		pstderr($error);
	}
}

sub process_scmd_execute
{
	my $parameters = shift;
	# required:
	my $anvil      = $parameters->{anvil};
	my $input      = $parameters->{input};
	# optional:
	my $lid        = $parameters->{lid} // "";

	$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => {
		input => $input,
		lid   => $lid,
	}, prefix => "process_scmd_execute" });

	my @sargs = parse_line('\s+', 0, $input);

	$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => { sargs => prettify(\@sargs) } });

	return if $#sargs < 1;

	my $chain_str  = $sargs[1];
	my @chain_args = $#sargs > 1 ? @sargs[2..$#sargs] : ();

	for my $i (0..$#chain_args)
	{
		my $param             = $chain_args[$i];
		my $is_decode_success = eval { $param = decode_json($param); };

		$chain_args[$i] = $param if $is_decode_success;
	}

	$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => {
		chain_args => prettify(\@chain_args),
		chain_str  => $chain_str,
	} });

	eval {
		my (@results) = access_chain({ anvil => $anvil, chain => $chain_str, chain_args => \@chain_args });

		$anvil->Log->variables({ source => $THIS_FILE, line => __LINE__, level => 2, list => { results => prettify(\@results) } });

		my $output = $lid.JSON->new->utf8->allow_blessed->encode({ sub_results => \@results });

		pstdout($output);
	} or do {
		my $error = "failed to access chain; cause: ".$@;

		pstderr($error);
	}
}

sub pstdout
{
	print STDOUT $_[0]."\n" if defined $_[0];
}

sub pstderr
{
	print STDERR "error: ".$_[0]."\n" if defined $_[0];
}
