package Patro::Server;
use strict;
use warnings;
use Carp;
eval "use Sys::HostAddr";
use Socket ();
use Scalar::Util 'reftype';
use POSIX ':sys_wait_h';
require overload;

# TODO: more expressive "security" policy, which must now cover whether
#       advisory locks may be stolen.

our $archy_avail = eval "use Patro::Archy;1";
#$Patro::Archy::DEBUG = 1;
our $threads_avail;
*sxdiag = sub {};
if ($ENV{PATRO_SERVER_DEBUG}) {
    *sxdiag = *::xdiag;
    our $DEBUG = 1;
}
our $VERSION = '0.16';
our @SERVERS :shared;
our %OPTS;

$OPTS{keep_alive} //= 30;
$OPTS{idle_timeout} //= 30;
$OPTS{fincheck_freq} //= 5;

$OPTS{secure_filehandles} //= 1;
$OPTS{steal_lock_ok} //= 1;


sub new {
    my $pkg = shift;
    my $opts = shift;

    my $host = $ENV{HOSTNAME} // qx(hostname) // "localhost";
    if ($INC{'Sys/HostAddr.pm'}) {
	my $host2 = Sys::HostAddr->new->main_ip;
	$host = $host2 if $host2;
    }
    chomp($host);

    socket(my $socket, Socket::PF_INET(), Socket::SOCK_STREAM(),
	   getprotobyname("tcp")) || croak __PACKAGE__, " socket: $!";
    setsockopt($socket, Socket::SOL_SOCKET(), Socket::SO_REUSEADDR(),
	       pack("l",1)) || croak __PACKAGE__, " setsockopt: $!";
    my $sockaddr = Socket::pack_sockaddr_in(0, Socket::inet_aton($host));
    bind($socket, $sockaddr) || croak __PACKAGE__, " bind: $!";
    listen($socket, Socket::SOMAXCONN()) || croak __PACKAGE__, " listen: $!";
    $sockaddr = getsockname($socket);
    my ($port,$addr) = Socket::unpack_sockaddr_in($sockaddr);

    my $meta = {
	sockaddr => $sockaddr,
	socket => $socket,
	host => $host,
	host2 => Socket::inet_aton($addr),
	port => $port,

	creator_pid => $$,
	creator_tid => $threads_avail && threads->tid,
	style => $threads_avail ? 'threaded' : 'forked',

	keep_alive => $OPTS{keep_alive},
	idle_timeout => $OPTS{idle_timeout},
	version => $Patro::Server::VERSION,
    };

    $Patro::SERVER_VERSION = $Patro::Server::VERSION;

    my $obj = {};
    my @store;

    if ($threads_avail) {
	for (@_) {
	    local $threads::shared::clone_warn = undef;
	    eval { $_ = threads::shared::shared_clone($_) };
	    if ($@ =~ /CODE|GLOB/) {
		require Patro::LeumJelly;
		warn $@;
		$threads::shared::clone_warn = 0;
		$_ = threads::shared::shared_clone($_);
	    }
	}
    }
    foreach my $o (@_) {
	my ($num,$str);
	{
	    no overloading;
	    no warnings 'portable';
	    $str = "$o";
	    ($num) = $str =~ /x(\w+)/;
	    $num = hex($num);
	}
	$obj->{$num} = $o;
	my $reftype = Scalar::Util::reftype($o);
	my $ref = CORE::ref($o);
	if ($ref eq 'threadsx::shared::code') {
	    $ref = $reftype = 'CODE*';
	} elsif ($ref eq 'threadsx::shared::glob') {
	    $ref = $reftype = 'GLOB';
	}
	my $store = {
	    ref => $ref,
	    reftype => $reftype,
	    id => $num
	};
	if (overload::Overloaded($o)) {
	    if ($ref ne 'CODE' && $ref ne 'CODE*' && $ref ne 'GLOB') {
		$store->{overload} = _overloads($o);
	    }
	}
	push @store, $store;
    }
    my $self = bless {
	meta => $meta,
	store => \@store,
	obj => $obj
    }, __PACKAGE__;
    $self->{config} = $self->config;
    $self->start_server;
    push @SERVERS, threadsx::shared::_shared_clone($self);
    warn $@ if $@;
    if (@SERVERS == 1) {
	eval q~END {
            if ($Patro::Server::threads_avail) {
                $_->detach for threads->list(threads::running);
	    }
	}~;
    }
    return $self;
}


sub start_server {
    my $self = shift;
    my $meta = $self->{meta};
    if ($meta->{style} eq 'threaded') {
	my $server_thread;
	$server_thread = threads->create(
	    sub {
		$SIG{KILL} = sub { exit };
		$SIG{CHLD} = sub { $self->watch_for_finishers(@_) };
		$SIG{ALRM} = sub { $self->watch_for_finishers(@_) };
		if ($self->{meta}{pid_file}) {
		    open my $fh, '>>', $self->{meta}{pid_file};
		    flock $fh, 2;
		    seek $fh, 0, 2;
		    print {$fh} "$$-", threads->tid, "\n";
		    close $fh;
		}
		$self->accept_clients;
		return;
	    } );
	$self->{meta}{server_thread} = $server_thread;
	$self->{meta}{server_pid} = $$;
	$self->{meta}{server_tid} = $server_thread->tid;
	#$server_thread->detach;
    } else {
	my $pid = CORE::fork();
	if (!defined($pid)) {
	    croak __PACKAGE__, " fork: $!";
	}
	if ($pid == 0) {
	    if ($self->{meta}{pid_file}) {
		open my $fh, '>>', $self->{meta}{pid_file};
		flock $fh, 2;
		seek $fh, 0, 2;
		print {$fh} "$$\n";
		close $fh;
	    }
	    $self->accept_clients;
	    exit;
	}
	$self->{meta}{server_pid} = $pid;
    }
}

# return list of operators that are overloaded on the given object
my @oplist;
sub _overloads {
    my $obj = shift;
    return unless overload::Overloaded($obj);
    if (!@oplist) {
	@oplist = split ' ',join(' ',values %overload::ops);
    }

    my %ops = map { $_ => 1 } grep { overload::Method($obj,$_) } @oplist;

    # we also need to account for the operations that are *implicitly*
    # overloaded.

    # Many ops can be generated out of 0+, "", or bool
    if ($ops{"0+"} || $ops{'""'} || $ops{bool}) {
	$ops{$_}++ for qw(0+ "" bool int ! qr . x .= x= <> -X);
    }

    # assignment ops can be generated from binary ops
    foreach my $binop (qw(. x + - * / ** % & | ^ << >> &. |. ^.)) {
	$ops{$binop . "="}++ if $ops{$binop};
    }

    # all comparison ops can be generated from <=> and cmp
    @ops{qw{< <= > >= == !=}} = (1) x 6 if $ops{"<=>"};
    @ops{qw(le lt ge gt eq ne)} = (1) x 6 if $ops{cmp};

    $ops{neg}++ if $ops{"-"};
    $ops{"--"}++ if $ops{"-="};
    $ops{abs}++ if $ops{"<"} && $ops{neg};
    $ops{"++"}++ if $ops{"+="};

    # all ops are overloaded if there is a 'nomethod' specified
    @ops{@oplist} = (1) x @oplist if $ops{nomethod};
    return [keys %ops];
}

sub config {
    my $self = shift;
    my $config_data = {
	host => $self->{meta}{host},
	port => $self->{meta}{port},
	store => $self->{store},
	style => $self->{meta}{style},
	version => $Patro::Server::VERSION
    };
    return bless $config_data, 'Patro::Config';
}

########################################

sub Patro::Config::to_string {
    my ($self) = @_;
    return Patro::LeumJelly::serialize({%$self});
}

sub Patro::Config::to_file {
    my ($self,$file) = @_;
    if (!$file) {
	# TODO: select a temp filename
    }
    my $fh;
    if (!open($fh, '>', $file)) {
	croak "Patro::Config::to_file: could not write cfga file '$file': $!";
    }
    print {$fh} $self->to_string;
    close $fh;
    return $file;
}

sub Patro::Config::from_string {
    my ($self, $string) = @_;
    my $cfg = Patro::LeumJelly::deserialize($string);
    return bless $cfg, 'Patro::Config';
}

sub Patro::Config::from_file {
    my ($self, $file) = @_;
    if (!defined($file) && !CORE::ref($self) && $self ne 'Patro::Config') {
	$file = $self;
    }
    my $fh;
    if (CORE::ref($file) eq 'GLOB') {
	$fh = $file;
    } elsif (!open $fh, '<' ,$file) {
	croak "Patro::Config::fron_file: could not read cfg file '$file': $!";
    }
    my $data = <$fh>;
    close $fh;
    return Patro::Config->from_string($data);
}

########################################

sub accept_clients {
    # accept connection from client
    # spin off connection to separate thread or process
    # perform request_response_loop on the client connection
    my $self = shift;
    my $meta = $self->{meta};

    $meta->{last_connection} = time;
    $meta->{finished} = 0;

    while (!$meta->{finished}) {
	$SIG{CHLD} = sub { $self->watch_for_finishers(@_) };
	$SIG{ALRM} = sub { $self->watch_for_finishers(@_) };
	alarm ($OPTS{fincheck_freq} || 5);
	my $client;
	my $server = $meta->{socket};
	my $paddr = accept($client,$server);
	if (!$paddr) {
	    next if $!{EINTR};
	    next if $!{ECHILD} || $!==10;  # !?! why $!{ECHILD} not suff on Lin?
	    ::xdiag("accept failure, %errno is",\%!);
	    croak __PACKAGE__, ": accept ", 0+$!," $!";
	}
	$meta->{last_connection} = time;

	$self->start_subserver($client);
	$self->watch_for_finishers('MAIN');
    }
}

sub start_subserver {
    my ($self,$client) = @_;
    # monitor id is not shared across forks or threads,
    # so each server will have a unique value

    our $monitor_id;
    $monitor_id //= 0;
    $monitor_id = sprintf "%010X", hex($monitor_id) + 10 + 1014 * rand;

    if ($self->{meta}{style} eq 'forked') {
	my $pid = CORE::fork();
	if (!defined($pid)) {
	    croak __PACKAGE__,": fork after accept $!";
	}
	if ($pid != 0) {
	    $monitor_id = sprintf "%010X", hex($monitor_id) + 5 + 256 * rand;
	    if ($self->{meta}{pid_file}) {
		open my $fh, '>>', $self->{meta}{pid_file};
		flock $fh, 2;
		seek $fh, 0, 2;
		print {$fh} "$pid\n";
		close $fh;
	    }
	    $self->{meta}{pids}{$pid}++;
	    return;
	}
	$self->request_response_loop($client);
	exit;
    } else {
	my $subthread = threads->create(
	    sub {
		$self->request_response_loop($client);
		threads->self->detach;
		return;
	    } );
	if ($self->{meta}{pid_file}) {
	    open my $fh, '>>', $self->{meta}{pid_file};
	    flock $fh, 2;
	    seek $fh, 0, 2;
	    print {$fh} "$$-", $subthread->tid, "\n";
	    close $fh;
	}
	$self->{meta}{pids}{"$$-" . $subthread->tid}++;
	push @{$self->{meta}{subthreads}}, $subthread;

	# $subthread->detach ?

	return;
    }
}

sub watch_for_finishers {
    my ($self,$sig) = @_;
    alarm 0;

    # XXX - how do you know when a thread is finished?
    # what if it is a detached thread?

    while ((my $pid = waitpid(-1,WNOHANG())) > 0 && WIFEXITED($?)) {
	delete $self->{meta}{pids}{$pid};
    }
    if ($self->{meta}{subthreads}) {
	my $n = @{$self->{meta}{subthreads}};
	my $n1 = threads->list(threads::all());
	my $n2 = threads->list(threads::running());
	my @joinable = threads->list(threads::joinable());
	if (@joinable) {
	    foreach my $subthread  (@joinable) {
		my ($i) = grep {
		    my $is = eval {$self->{meta}{subthreads}{$_} == $subthread};
		    if ($@ && 0) {
			::xdiag("Server: exception checking for finishers: ",
				$@,"\n",$self->{meta},$self->{meta}{subthreads});
		    }
		    $is;
		} 0 .. $n-1;
		if (!defined($i)) {
		    # this is not unusual if the Patro user is using threads
#		    warn "subthread $subthread ",0+$subthread,
#			" not found on this server!";
		    next;
		}
		$self->{meta}{subthreads}[$i]->join;
		$self->{meta}{subthreads}[$i] = undef;
	    }
	    $self->{meta}{subthreads} =
		[ grep { defined } @{$self->{meta}{subthreads} } ];
	}
    }
    unless ($self->still_active) {
	$self->{meta}{finished}++;
    }
    $SIG{ALRM} = sub { $self->watch_for_finishers(@_) };
    $SIG{CHLD} = sub { $self->watch_for_finishers(@_) };
    alarm ($OPTS{fincheck_freq} || 5);
}

sub still_active {
    my $self = shift;
    my $meta = $self->{meta};
    if (time <= $meta->{keep_alive}) {
	return 1;
    }
    if (time < $meta->{last_connection} + $meta->{idle_timeout}) {
	return 1;
    }
    if (keys %{$meta->{pids}}) {
	return 1;
    }
    return;
}

sub request_response_loop {
    my ($self, $client) = @_;

    local $Patro::Server::disconnect = 0;
    my $fh0 = select $client;
    $| = 1;
    select $fh0;

    while (my $req = readline($client)) {
	next unless $req =~ /\S/;
	sxdiag("server: got request '$req'");
	my $resp = $self->process_request($req);
	sxdiag("server: response to request is ",$resp);
	$resp = $self->serialize_response($resp);
	sxdiag("server: serialized response to request is ",$resp);
	print {$client} $resp,"\n";
	last if $Patro::Server::disconnect;
    }
    close $client;
    return;
}

our $SIDES;    # for the server to activate or suppress some
               # side-effects from the lower levels of the
               # request handler

sub process_request {
    my ($self,$request) = @_;
    croak "process_request: expected scalar request" if ref($request);

    $request = Patro::LeumJelly::deserialize($request);
    my $topic = $request->{topic};
    if (!defined($topic)) {
	return $self->error_response("bad topic in request '$_[1]'");
    }
    
    my $has_args = $request->{has_args};
    my $args = $request->{args};
    if ($request->{has_args}) {
	local $@;
	$args = [ map {
	    if (CORE::ref($_) eq '.Patroon') {
		eval { $self->{obj}{$$_} };
	    } else {
		$_
	    } } @{$request->{args}} ];
	if ($@) {
	    return $self->error_response($@);
	}
    }
    my $id = $request->{id};
    my $cmd = $request->{command};
    my $ctx = $request->{context};
    my @orig_args = $has_args ? @$args : ();
    my @orig_refs = $has_args ? \ (@$args) : ();
    my @orig_dump = map Patro::LeumJelly::serialize([$_]), @$args;
    local $! = 0;
    local $? = 0;
    local $SIDES = {};
    my @r;
    our $DEBUG;
    local $DEBUG = $DEBUG || $request->{_debug} || 0;

    if ($topic eq 'META') {
	@r = $self->process_request_META($id,$cmd,$ctx,$has_args,$args);
    } elsif ($topic eq 'HASH') {
	@r = $self->process_request_HASH($id,$cmd,$ctx,$has_args,$args);
    } elsif ($topic eq 'ARRAY') {
	@r = $self->process_request_ARRAY($id,$cmd,$ctx,$has_args,$args);
    } elsif ($topic eq 'SCALAR') {
	@r = $self->process_request_SCALAR($id,$cmd,$ctx,$has_args,$args);
    } elsif ($topic eq 'METHOD') {
	@r = $self->process_request_METHOD($id,$cmd,$ctx,$has_args,$args);
    } elsif ($topic eq 'CODE') {
	@r = $self->process_request_CODE($id,undef,$ctx,$has_args,$args);
    } elsif ($topic eq 'HANDLE') {
	@r = $self->process_request_HANDLE($id,$cmd,$ctx,$has_args,$args);
    } elsif ($topic eq 'SYNC') {
	@r = $self->process_request_SYNC($id,$cmd,$ctx,$has_args,$args);
    } elsif ($topic eq 'OVERLOAD') {
	my $obj = $self->{obj}{$id};
	@r = $self->process_request_OVERLOAD($obj,$cmd,$args,$ctx);
    } elsif ($topic eq 'REF') {
	@r = $self->process_request_REF($id,$cmd,$ctx,$has_args,$args);
    } else {
	@r = ();
	$@ = __PACKAGE__ . ": unrecognized topic '$topic' in proxy request";
    }
    if (@r && CORE::ref($r[0]) eq '.Patroclus') {
	return $r[0];
    }
    my $sides = bless {}, '.Patroclus';

    $sides->{errno} = 0 + $! if $!;
    $sides->{errno_extended} = $^E if $^E;
    $sides->{child_error} = $? if $?;
    $sides->{error} = $@ if $@;

    # how to update elements of @_ that have changes?
    # three implementations below. Pick one.
    #   1. "side A" - return all elements of @_. You will have to
    #      filter out "Modification of a read-only element attempted ..."
    #      messages
    #   2. "side B" - do a deep comparison of original and final
    #      elements of @_, return the ones that mismatch I CHOOSE YOU!
    #   3. original implementation - do shallow comparison of original
    #      and final elements of @_. Insufficient for code that updates
    #      nested data of the inputs
    my (@out,@outref);

    # "sideB" - do a deep compare for all arguments
    for (my $j=0; $j<@$args && !$SIDES->{no_out}; $j++) {
	my $dj = Patro::LeumJelly::serialize([$args->[$j]]);
	for (my $i=0; $i<@orig_refs; $i++) {
	    next if $orig_refs[$i] != \$args->[$j];
	    if ($orig_dump[$i] ne $dj) {
		push @out, $i, $args->[$j];
	    }
	}
    }
    $sides->{sideB} = 1;

    $sides->{out} = \@out if @out;
    $sides->{outref} = \@outref if @outref;
    if ($ctx >= 2) {
	return $self->list_response($sides, @r);
    } elsif ($ctx == 1 && defined $r[0]) {
	my $y = $self->scalar_response($sides, $r[0]);
#	if ($topic eq 'REF') { ::xdiag("response:",$y) }
	return $y;
    } else {
	return $self->void_response($sides);
    }
}

sub process_request_META {
    my ($self,$id,$cmd,$ctx,$has_args,$args) = @_;
    if ($cmd eq 'disconnect') {
	$Patro::Server::disconnect = 1;
	return bless { disconnect_ok => 1 }, '.Patroclus';
    }
    my $obj = $self->{obj}{$id};
    if ($cmd eq 'ref') {
	return CORE::ref($obj);
    } elsif ($cmd eq 'reftype') {
	return Scalar::Util::reftype($obj);
    } elsif ($cmd eq 'destroy') {
	delete $self->{obj}{$id};
	my @ids = keys %{$self->{obj}};
	if (@ids == 0) {
	    $Patro::Server::disconnect = 1;
	    return bless { disconnect_ok => 1 }, '.Patroclus';
	} else {
	    return bless { disconnect_ok => 0,
		     num_reminaing_objs => 0+@ids }, '.Patroclus';
	}
    } else {
	$@ = "Patro: unsupported meta command '$cmd'";
	return;
    }
}

sub process_request_SYNC {
    my ($self,$id,$cmd,$ctx,$has_args,$args) = @_;
    if (!$archy_avail) {
	$! = 999;
	$SIDES->{warn} = "Patro synchronization feature not available";
	return;
    }
    my $obj = $self->{obj}{$id};
    if (!defined($obj)) {
	our $SIDES;
	$SIDES->{_fatal} = "Server: object id $id is not associated "
	    . "with a known reference\n"
	    . "Known ids: " . join(" ",sort keys %{$self->{obj}});
	return;
    }
    our $monitor_id;
    if ($cmd eq 'lock') {
	our $SIDES;
	if ($has_args) {
	    if (!$OPTS{steal_lock_ok}) {
		if ($args->[1]) {
		    $SIDES->{warn} = "Patro::lock: steal=true not allowed "
				   . "by server";
		    $args->[1] = 0;
		}
	    }
	    return Patro::Archy::plock($obj, $monitor_id, @$args);
	} else {
	    return Patro::Archy::plock($obj, $monitor_id);
	}
    } elsif ($cmd eq 'unlock') {
	if ($has_args) {
	    return Patro::Archy::punlock($obj, $monitor_id, $args->[0]);
	} else {
	    return Patro::Archy::punlock($obj, $monitor_id);
	}
    } elsif ($cmd eq 'wait') {
	if ($has_args) {
	    return Patro::Archy::pwait($obj,$monitor_id,$args->[0]);
	} else {
	    return Patro::Archy::pwait($obj,$monitor_id);
	}
    } elsif ($cmd eq 'notify') {
	if ($has_args) {
	    return Patro::Archy::pnotify($obj,$monitor_id,$args->[0]);
	} else {
	    return Patro::Archy::pnotify($obj,$monitor_id);
	}
    } elsif ($cmd eq 'state') {
	my $state = Patro::Archy::pstate($obj, $monitor_id);
	if ($state == Patro::Archy::STATE_NULL()) {
	    return "0,NULL";
	} elsif ($state == Patro::Archy::STATE_WAIT()) {
	    return "1,WAIT";
	} elsif ($state == Patro::Archy::STATE_NOTIFY()) {
	    return "2,NOTIFY";
	} elsif ($state == Patro::Archy::STATE_STOLEN()) {
	    return "3,STOLEN";
	} else {
	    return "$state,LOCK";
	}
    } else {
	$@ = "Unrecognized SYNC command '$cmd'";
	return;
    }
}

sub process_request_HASH {
    my ($self,$id,$cmd,$ctx,$has_args,$args) = @_;
    my $obj = $self->{obj}{$id};
    if (reftype($obj) ne 'HASH') {
	$@ = "Not a HASH reference";
	return;
	# !!! what if '%{}' op is overloaded?
    }
    if ($cmd eq 'STORE') {
	my ($key,$val) = @$args;
	my $old_val = $obj->{$key};
	$obj->{$key} = threads::shared::shared_clone($val);
	return $old_val;
    } elsif ($cmd eq 'FETCH') {
	my $key = $args->[0];
	return $obj->{$key};
    } elsif ($cmd eq 'DELETE') {
	return delete $obj->{$args->[0]};
    } elsif ($cmd eq 'EXISTS') {
	return exists $obj->{$args->[0]};
    } elsif ($cmd eq 'CLEAR') {
	%$obj = ();
	return;
    } elsif ($cmd eq 'FIRSTKEY') {
	keys %$obj;
	my ($k,$v) = each %$obj;
	return $k;
    } elsif ($cmd eq 'NEXTKEY') {
	my ($k,$v) = each %$obj;
	return $k;
    } elsif ($cmd eq 'SCALAR') {
	return scalar %$obj;
    } else {
	$@ = "HASH function '$cmd' not recognized";
	return;
    }
}

sub process_request_ARRAY {
    my ($self,$id,$cmd,$ctx,$has_args,$args) = @_;
    my $obj = $self->{obj}{$id};
    if (reftype($obj) ne 'ARRAY') {
	$@ = "Not an ARRAY ref";
	return;
    }
    if ($cmd eq 'STORE') {
	my ($index,$val) = @$args;
	my $old_val = $obj->[$index];
	# ?!!!? does $val have to be shared?
	eval { $obj->[$index] = threads::shared::shared_clone($val) };
	return $old_val;
    } elsif ($cmd eq 'FETCH') {
	return eval { $obj->[$args->[0]] };
    } elsif ($cmd eq 'FETCHSIZE') {
	return scalar @$obj;
    } elsif ($cmd eq 'STORESIZE' || $cmd eq 'EXTEND') {
	my $n = $#{$obj} = $args->[0]-1;
	return $n+1;
    } elsif ($cmd eq 'SPLICE') {
	my ($off,$len,@list) = @$args;
	if ($off < 0) {
	    $off += @$obj;
	    if ($off < 0) {
		$@ = "Modification of non-createable array value attempted, "
		    . "subscript $off";
		return;
	    }
	}
	if (!defined($len) || $len eq 'undef') {
	    $len = @{$obj} - $off;
	}
	if ($len < 0) {
	    $len += @{$obj} - $off;
	    if ($len < 0) {
		$len = 0;
	    }
	}
	my @val = splice @{$obj}, $off, $len, @list;
	$SIDES->{no_out} = 1; # don't try to update @_
	# SPLICE is the only ARRAY function that doesn't assume scalar context
	if ($ctx == 1) {
	    return @val > 0 ? $val[-1] : undef;
	} else {
	    return @val;
	}
    } elsif ($cmd eq 'PUSH') {
	return push @{$obj}, map threads::shared::shared_clone($_), @$args;
    } elsif ($cmd eq 'UNSHIFT') {
	return unshift @{$obj}, map threads::shared::shared_clone($_), @$args;
    } elsif ($cmd eq 'POP') {
	return pop @{$obj};
    } elsif ($cmd eq 'SHIFT') {
	return shift @{$obj};
    } elsif ($cmd eq 'EXISTS') {
	return exists $obj->[$args->[0]];
    } else {
	$@ = "tied ARRAY function '$cmd' not recognized";
	return;
    }
}

sub process_request_SCALAR {
    my ($self,$id,$cmd,$ctx,$has_args,$args) = @_;
    my $obj = $self->{obj}{$id};
    if (reftype($obj) ne 'SCALAR') {
	$@ = "Not a SCALAR reference";
	return;
    }
    if ($cmd eq 'STORE') {
	my $val = ${$obj};
	${$obj} = threads::shared::shared_clone($args->[0]);
	return $val;	
    } elsif ($cmd eq 'FETCH') {
	return ${$obj};
    } else {
	$@ = "tied SCALAR function '$cmd' not recognized";
	return;
    }
}

sub process_request_METHOD {
    my ($self,$id,$command,$context,$has_args,$args) = @_;
    my $obj = $self->{obj}{$id};
    if (!$obj) {
	$@ = "Bad object id '$id' in proxy method call";
	return;
    }
    my @r;
    if ($command =~ /::/) {
	no strict 'refs';
	if ($context < 2) {
	    @r = scalar eval { $has_args ? &$command($obj,@$args)
				   : &$command($obj) };
	} else {
	    @r = eval { $has_args ? &$command($obj,@$args)
			          : &$command($obj) };
	}
    } elsif ($context < 2) {
	@r = scalar eval { $has_args ? $obj->$command(@$args)
			             : $obj->$command };
    } else {
	@r = eval { $has_args ? $obj->$command(@$args)
			      : $obj->$command };
    }
    return @r;
}

sub process_request_HANDLE {
    my ($self,$id,$command,$context,$has_args,$args) = @_;
    my $obj = $self->{obj}{$id};
    my $fh = CORE::ref($obj) eq 'threadsx::shared::glob' ? $obj->glob : $obj;
    if ($command eq 'PRINT') {
	my $z = print {$fh} @$args;
	return $z;
    } elsif ($command eq 'PRINTF') {
	if ($has_args) {
	    my $template = shift @$args;
	    my $z = printf {$fh} $template, @$args;
	    return $z;
	} else {
	    # I don't think we can get here through the proxy
	    my $z = printf {$fh} "";
	    return $z;
	}
    } elsif ($command eq 'WRITE') {
	if (@$args < 2) {
	    return $self->error_response("Not enough arguments for syswrite");
	}
	return syswrite($fh, $args->[0],
	                     $args->[1] // undef, $args->[2] // undef);
    } elsif ($command eq 'READLINE') {
	my @val;
	if ($context > 1) {
	    my @val = readline($fh);
	    return @val;
	} else {
	    my $val = readline($fh);
	    return $val;
	}
    } elsif ($command eq 'GETC') {
	my $ch = getc($fh);
	return $ch;
    } elsif ($command eq 'READ' || $command eq 'READ?' ||
	     $command eq 'SYSREAD') {
	local $Patro::read_sysread_flag;  # don't clobber
	if (@$args < 2) {
	    # I don't think we can get here through the proxy
	    $@ = "Not enough arguments for " . lc($command);
	    return;
	}
	my (undef, $len, $off) = @$args;
	my $z;
	if ($command eq 'SYSREAD' ||
	    ($command eq 'READ?' && fileno($fh) >= 0)) {
	    $z = sysread $fh, $args->[0], $len, $off || 0;
	} else {
	    # sysread doesn't work, for example, on file handles opened
	    # from a reference to a scalar
	    $z = read $fh, $args->[0], $len, $off || 0;
	}
	return $z;
    } elsif ($command eq 'EOF') {
	return eof($fh);
    } elsif ($command eq 'FILENO') {
	my $z = fileno($fh);
	return $z;
    } elsif ($command eq 'SEEK') {
	if (@$args < 2) {
	    $@ = "Not enough arguments for seek";
	    return;
	} elsif (@$args > 2) {
	    $@ = "Too many arguments for seek";
	    return;
	} else {
	    my $z = seek $fh, $args->[0], $args->[1];
	    return $z;
	}
    } elsif ($command eq 'TELL') {
	my $z = tell($fh);
	return $z;
    } elsif ($command eq 'BINMODE') {
	my $z;
	if (@$args) {
	    $z = binmode $fh, $args->[0];
	} else {
	    $z = binmode $fh;
	}
	return $z;
    } elsif ($command eq 'CLOSE') {
	if ($OPTS{secure_filehandles}) {
	    $@ = "Patro: insecure CLOSE operation on proxy filehandle";
	    return;
	}
	my $z = close $fh;
	return $z;    
    } elsif ($command eq 'OPEN') {
	if ($OPTS{secure_filehandles}) {
	    $@ = "Patro: insecure OPEN operation on proxy filehandle";
	    return;
	}
	my $z;
	my $mode = shift @$args;
	if (@$args == 0) {
	    $z = open $fh, $mode;
	} else {
	    my $expr = shift @$args;
	    if (@$args == 0) {
		$z = open $fh, $mode, $expr;
	    } else {
		$z = open $fh, $mode, $expr, @$args;
	    }
	}
	
	# it is hard to set autoflush from the proxy.
	# Since it is usually what you want, let's do it here.
	if ($z) {
	    my $fh_sel = select $fh;
	    $| = 1;
	    select $fh_sel;
	}
	return $z;
    }
    # commands that are not in the tied filehandle 
    elsif ($command eq 'TRUNCATE') {
	my $z = truncate $fh, $args->[0];
	return $z;
    } elsif ($command eq 'FCNTL') {
	my $z = fcntl $fh, $args->[0], $args->[1];
	return $z;
    } elsif ($command eq 'FLOCK') {
	my $z = flock $fh, $args->[0];
	return $z;
    } elsif ($command eq 'STAT') {
	if ($context < 2) {
	    return scalar stat $fh;
	} else {
	    return stat $fh;
	}
    } elsif ($command eq 'LSTAT') {
	if ($context < 2) {
	    return scalar lstat $fh;
	} else {
	    return lstat $fh;
	}
    } elsif ($command eq '-X') {
	my $key = $args->[0];
	# insecure unless $key is vetted
	if (length($key) != 1 || $key !~ /[A-Za-z]/) {
	    $@ = "Invalid filetest operator '-$key'";
	    return;
	}
	return eval "-$key \$fh";
    } elsif ($command eq 'SYSOPEN') {
	if ($OPTS{secure_filehandles}) {
	    $@ = "Patro: insecure SYSOPEN operation on proxy filehandle";
	    return;
	}
        my $z = @$args <= 2 ? sysopen $fh, $args->[0], $args->[1]
                            : sysopen $fh, $args->[0], $args->[1], $args->[2];
        return $z;

    # commands that operate on DIRHANDLEs
    } elsif ($command eq 'OPENDIR') {
        if ($OPTS{secure_filehandles}) {
            $@ = "Patro: insecure OPENDIR operation on proxy dirhandle";
            return;
        }
        return opendir $fh, $args->[0];
    } elsif ($command eq 'REWINDDIR') {
        return rewinddir $fh;
    } elsif ($command eq 'TELLDIR') {
        return telldir $fh;
    } elsif ($command eq 'READDIR') {
        if ($context < 2) {
            return scalar readdir $fh;
        } else {
            my @r = readdir $fh;
            return @r;
        }
    } elsif ($command eq 'SEEKDIR') {
        return seekdir $fh, $args->[0];
    } elsif ($command eq 'CLOSEDIR') {
        return closedir $fh;
    } elsif ($command eq 'CHDIR') {
        return chdir $fh;
	
    } else {
	$@ = "tied HANDLE function '$command' not found";
	return;
    }
}

sub process_request_CODE {
    my ($self,$id,$command_NOTUSED,$context,$has_args,$args) = @_;
    my $sub = $self->{obj}{$id};
    if (CORE::ref($sub) eq 'threadsx::shared::code') {
	$sub = $sub->code;
    }
    if ($context < 2) {
	return scalar eval { $has_args ? $sub->(@$args) : $sub->() };
    } else {
	return eval { $has_args ? $sub->(@$args) : $sub->() };
    }
}

sub process_request_OVERLOAD {
    my ($self,$x,$op,$args,$context) = @_;
    if ($op eq '@{}') {
	my $z = eval { \@$x };
	$@ &&= "Not an ARRAY reference";
	return $z;
    } elsif ($op eq '%{}') {
	my $z = eval { \%$x };
	$@ &&= "Not a HASH reference";
	return $z;
    } elsif ($op eq '&{}') {
	my $z = eval { \&$x };
	$@ &&= "Not a CODE reference";
	return $z;
    } elsif ($op eq '${}') {
	my $z = eval { \$$x };
	$@ &&= "Not a SCALAR reference";
	return $z;
    } # elsif ($op eq '*{}') { return \*$x; }
    my ($y,$swap) = @$args;
    if ($swap) {
	($x,$y) = ($y,$x);
    }
    local $@ = '';
    my $z;
    if ($op =~ /[&|~^][.]=?/) {
        $op =~ s/\.//;
    }
    if ($op eq '-X') {
	# !!! insecure unless $y is vetted
	if (length($y) != 1 || $y !~ /[A-Za-z]/) {
	    $@ = "Invalid filetest operator '$y'";
	    return;
	}
        $z = eval "-$y \$x";
    } elsif ($op eq 'neg') {
        $z = eval { -$x };
    } elsif ($op eq '!' || $op eq '~' || $op eq '++' || $op eq '--') {
	# string eval ok -- $op is vetted
        $z = eval "$op\$x";
    } elsif ($op eq 'qr') {
        $z = eval { qr/$x/ };
    } elsif ($op eq 'atan2') {
        $z = eval { atan2($x,$y) };
    } elsif ($op eq 'cos' || $op eq 'sin' || $op eq 'exp' || $op eq 'abs' ||
             $op eq 'int' || $op eq 'sqrt' || $op eq 'log') {
	# string eval ok -- $op is vetted
        $z = eval "$op(\$x)";
    } elsif ($op eq 'bool') {
        $z = eval { $x ? 1 : 0 };  # this isn't right
    } elsif ($op eq '0+') {
        $z = eval "0 + \$x"; # this isn't right, either
    } elsif ($op eq '""') {
        $z = eval { "$x" };
    } elsif ($op eq '<>') {
        # always scalar context readline
        $z = eval { readline($x) };
    } else {  # binary operator
	# !!! insecure unless $op is vetted
	if (!@oplist) {
	    @oplist = split ' ',join(' ',values %overload::ops);
	}
	my %ops = map {; $_ => 1 } @oplist;
	if (!defined $ops{$op}) {
	    $@ = "Invalid operator '$op'";
	    return;
	}
        $z = eval "\$x $op \$y";
    }
    if ($@) {
	return;
    }
    if ($threads_avail) {
	$z = threads::shared::shared_clone($z);
    }
    return $z;
}

sub process_request_REF {
    my ($self,$id,$command,$context,$has_args,$args) = @_;
    my $obj = $self->{obj}{$id};
    if (reftype($obj) ne 'REF') {
	$@ = "Not a REF";
	return;
    }
    if ($command eq 'deref') {
	return $$obj;
    }
    $@ = "$command is not an appropriate operation for REF";
    return;
}

########################################

sub void_response {
    my $addl = {};
    if (@_ > 0 && CORE::ref($_[-1]) eq '.Patroclus') {
	$addl = pop @_;
    }
    return +{ context => 0, response => undef, %$addl };
}

sub scalar_response {
    my ($self,$sides,$val) = @_;
    return +{
	context => 1,
	response => $val,
	%$sides
    };
}

sub list_response {
    my ($self,$sides,@val) = @_;
    return +{
	context => 2,
	response => \@val,
	%$sides
    };
}

sub error_response {
    my ($self,@msg) = @_;
    return { error => join('', @msg) };
}

########################################

sub serialize_response {
    my ($self, $resp) = @_;
    if ($resp->{context}) {
	if ($resp->{context} == 1) {
	    $resp->{response} = patrofy($self,$resp,$resp->{response});
	} elsif ($resp->{context} == 2) {
	    $resp->{response} = [
		map patrofy($self,$resp,$_), @{$resp->{response}} ];
	}
    }

    if ($resp->{out}) {
	$resp->{out} = [ map patrofy($self,$resp,$_), @{$resp->{out}} ];
    }

    sxdiag("Patro::Server: final response before serialization: ",$resp);
    $resp = Patro::LeumJelly::serialize($resp);
    return $resp;
}

# we should not send any serialized references back to the client.
# replace any references in the response with an
# object id.
sub patrofy {
    my ($self,$resp,$obj) = @_;
    sxdiag("patrofy: called on: ",defined($obj) ? "$obj" : "<undef>");
    return $obj unless ref($obj);

    if ($threads_avail) {
	if (CORE::ref($obj) eq 'CODE') {
	    $obj = threadsx::shared::code->new($obj);
	    sxdiag("patrofy: coderef converted");
	} elsif (CORE::ref($obj) eq 'GLOB') {
	    $obj = threadsx::shared::glob->new($obj);
	    sxdiag("patrofy: glob converted");
	}
    }

    my $id = do {
	no overloading;
	0 + $obj;
    };

    if (!$self->{obj}{$id}) {
	$self->{obj}{$id} = $obj;
	my $ref = CORE::ref($obj);
	my $reftype;
	if ($ref eq 'threadsx::shared::code') {
	    $ref = 'CODE';
	    $reftype = 'CODE';
	} elsif ($ref eq 'threadsx::shared::glob') {
	    $ref = 'GLOB';
	    $reftype = 'GLOB';
	} else {
	    $reftype = Scalar::Util::reftype($obj);
	}
	sxdiag("patrofy: ref types for $id are $ref,$reftype");
	$resp->{meta}{$id} = {
	    id => $id, ref => $ref, reftype => $reftype
	};
	if (overload::Overloaded($obj)) {
	    $resp->{meta}{$id}{overload} = _overloads($obj);
	}
	sxdiag("new response meta: ",$resp->{meta}{$id});
    } else {
	sxdiag("id $id has been seen before");
    }
    return bless \$id,'.Patrobras';
}

sub TEST_MODE {
    if ($INC{'perl5db.pl'}) {
	::xdiag("TEST_MODE adjusted for debugging");
	$OPTS{keep_alive} = 3600;
	$OPTS{fincheck_freq} = 3500;
	$OPTS{idle_timeout} = 3600;
	alarm 9999;
	return;
    }
    $OPTS{keep_alive} = 2;
    $OPTS{fincheck_freq} = 2;
    $OPTS{idle_timeout} = 1;
    if ($threads_avail) {
	$OPTS{fincheck_freq} = "0 but true";	    
    }
}

1;

=head1 NAME

Patro::Server - remote object server for Patro

=head1 VERSION

0.16

=head1 DESCRIPTION

A server class for making references available to proxy clients
in the L<Patro> distribution.
The server handles requests for any references that are being served,
manipulates references on the server, and returns the results of
operations to the proxy objects on the clients.

=head1 SERVER OPTIONS

Server options are configured through the global
C<%Patro::Server::OPTS> hash. Changes to this hash generally
only affect servers in threads and processes that are started
after the changes are made; any desired changes should be
made before the first call to L<Patro/"patronize">.

The server recognizes the following options in the
C<%Patro::Server::OPTS> hash:

=head2 Server operation options

In its original incarnation, I imagined that the servers and
clients would be tightly coupled. A server would start, and
then the same person that started the server would start one
or more clients on other machines in the same cluster. The
clients would perform some tasks, and then exit. When the last
client disconnected, and after a little bit of waiting to see
if any new clients would connect, the server would shut down.
Other server use cases are possible, but this is the use case
that informed these server settings.

=over 4

=item keep_alive => seconds

After the server starts, this is the number of seconds it is
guaranteed to stay up, even if no clients connect to it.
The default is 30 seconds; you could set this to a very
large value in order to have a persistent server.

=item idle_timeout => seconds

After all clients have disconnected, this is the number of
seconds to wait for another client to connect. If another
client does not connect before this time expires, then the
server will shut down (also subject to satisfying the
C<keep_alive> timeout, described above). The default is
30 seconds.

=item fincheck_freq => seconds

The number of seconds in between checks of which clients
are still active. When no active clients are detected,
the C<idle_timeout> count down will begin.

This check is implemented with a C<SIGALRM>. That may be
inconvenient to the many other programs and modules that
would use C<SIGALRM> though, so this may change in the future.

=back

=head2 Server security options

These options indicate whether certain operations that may
be insecure or impolite are allowed on the server.

=over 4

=item secure_filehandles => bool

If this option is true, then proxies to filehandles will
receive an error if they execute the C<open> or C<close>
functions on the filehandles. If the C<open> function is
allowed, the client will have read/write access (with
the userid of the server process) to any file on the
server filesystem. Worse, the client could use a pipe
open (C<open $proxy_fh, "| arbitrary command">) and
execute arbitrary code on the server. Calling C<close>
on a proxy filehandle is not so dangerous but it would still
not be allowed if this option is set.

=item steal_lock_ok => bool

C<Patro> provides advisory locking on remote references.
One option to the L<Patro::lock|Patro/"lock"> function is
to allow a lock to be stolen from another monitor. Whether
stealing locks should be allowed depends a lot on your
application. Some reasons you might want to allow it is if
you have slow and unreliable processes or if your application
is prone to deadlock.

=back

=head1 LICENSE AND COPYRIGHT

MIT License

Copyright (c) 2017, Marty O'Brien

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

=cut
