view release on metacpan or  search on metacpan

CAB/Server/HTTP/UNIX.pm  view on Meta::CPAN

		   "TCP-LISTEN:${port},bind=${addr},backlog=".IO::Socket->SOMAXCONN.",reuseaddr,fork",
		   ##
		   #"UNIX-CLIENT:$sockpath",
		   qq{EXEC:socat -d -ly - 'UNIX-CLIENT:$sockpath'}, ##-- use EXEC:socat idiom to populate socat environment variables (SOCAT_PEERADDR,SOCAT_PEERPORT)
		  ]);

    $srv->vlog('trace', "RELAY: ", join(' ', @$cmd));
    exec(@$cmd)
      or $srv->logconfess("prepareLocal(): failed to start TCP socket relay: $!");
  }

  return 1; ##-- never reached
}


##==============================================================================
## Methods: Local: spawn and reap

## \&reaper = $srv->reaper()
##  + zombie-harvesting code; installed to local %SIG
sub reaper {
  my $srv = shift;
  return sub {
    my ($child);
    while (($child = waitpid(-1,WNOHANG)) > 0) {

      ##-- check whether required subprocess bailed on us
      if ($srv->{relayPid} && $child == $srv->{relayPid}) {
	delete $srv->{relayPid};
	$srv->logdie("TCP relay process ($child) exited with status ".($?>>8));
      }

      ##-- normal case: handle client-level forks (e.g. for POST)
      $srv->vlog($srv->{logReap},"reaped subprocess pid=$child, status=".($?>>8));
      delete $srv->{children}{$child};
    }

    #$SIG{CHLD}=$srv->reaper() if ($srv->{installReaper}); ##-- re-install reaper for SysV
  };
}



##==============================================================================
## Methods: Local: Path Handlers: inherited

##==============================================================================
## Methods: Local: Access Control: inherited

##======================================================================
## Methods: Local: error handling: inherited

##==============================================================================
## PACKAGE: DTA::CAB::Server::HTTP::UNIX::ClientConn
package DTA::CAB::Server::HTTP::UNIX::ClientConn;
use File::Basename qw(basename);
use DTA::CAB::Utils qw(:proc);
our @ISA = qw(HTTP::Daemon::ClientConn);

## ($pid,$uid,$gid) = $sock->peercred()
##  + gets peer credentials; returns (-1,-1,-1) on failure
sub peercred {
  my $sock = shift;
  if ($sock->can('SO_PEERCRED')) {
    my $buf = $sock->sockopt($sock->SO_PEERCRED);
    return unpack('lll',$buf);
  }
  return (-1,-1,-1);
}

## \%env = $sock->peerenv()
## \%env = $sock->peerenv($pid)
##  + gets environment variables for peer process, if possible
##  + uses cached value in ${*sock}{peerenv} if present
##  + returns undef on failure
sub peerenv {
  my ($sock,$pid) = @_;
  return ${*$sock}{'peerenv'} if (${*$sock}{'peerenv'});
  ($pid) = $sock->peercred if (!$pid);
  my ($fh,%env);
  if (open($fh,"</proc/$pid/environ")) {
    local $/ = "\0";
    my ($key,$val);
    while (defined($_=<$fh>)) {
      chomp($_);
      ($key,$val) = split(/=/,$_,2);
      $env{$key} = $val;
    }
    close($fh);
  }

  ##-- debug
  #print STDERR "PEERENV($sock): $_=$env{$_}\n" foreach (sort keys %env);

  ${*$sock}{'peerenv'} = \%env;
}

## $str = $sock->peerstr()
## $str = $sock->peerstr($uid,$gid,$pid)
##  + returns stringified unix peer credentials: "${USER}.${GROUP}[${PID}]"
sub peerstr {
  my ($sock,$pid,$uid,$gid) = @_;
  ($pid,$uid,$gid) = $sock->peercred() if (@_ < 4);
  return (
	  (defined($uid) ? (getpwuid($uid)//'?') : '?')
	  .'.'
	  .(defined($gid) ? (getgrgid($gid)//'?') : '?')
	  .':'
	  .(defined($pid) ? (basename(pid_cmd($pid)//'?')."[$pid]") : '?[?]')
	 );
}

## $host = peerhost()
##  + for relayed connections, gets underlying TCP peer via socat environment
##  + for unix connections, returns UNIX credentials as as for peerstr()
sub peerhost {
  my $sock = shift;

  ##-- get UNIX socket credentials
  my ($pid,$uid,$gid) = $sock->peercred();
  if (defined($pid) && basename(pid_cmd($pid)//'?') eq 'socat') {
    ##-- get socat environment variable if applicable
    my $env = $sock->peerenv();
    return $env->{DTA_CAB_RELAY_PEERADDR} if ($env && $env->{DTA_CAB_RELAY_PEERADDR});
  }

  ##-- return UNIX socket credentials
  return $sock->peerstr($pid,$uid,$gid);
}

## $port = peerport()
##  + for relayed connections, gets underlying TCP port via socat environment
##  + for unix connections, returns socket path
sub peerport {
  my $sock = shift;

  ##-- get UNIX socket credentials
  my ($pid,$uid,$gid) = $sock->peercred();
  if (defined($pid) && basename(pid_cmd($pid)//'?') eq 'socat') {
    ##-- get socat environment variable if applicable
    my $env = $sock->peerenv();
    return $env->{DTA_CAB_RELAY_PEERPORT} if ($env && $env->{DTA_CAB_RELAY_PEERPORT});
  }

  ##-- return UNIX socket path
  return $sock->peerpath();
}



1; ##-- be happy

__END__
##========================================================================
## POD DOCUMENTATION, auto-generated by podextract.perl

##========================================================================
## NAME
=pod

=head1 NAME

DTA::CAB::Server::HTTP::UNIX - DTA::CAB standalone HTTP server using HTTP::Daemon::UNIX

=cut

##========================================================================
## PACKAGES
=pod

=head1 PACKAGES

=over 4

=item DTA::CAB::Server::HTTP::UNIX

=item DTA::CAB::Server::HTTP::UNIX::ClientConn

=back

=cut

##========================================================================
## SYNOPSIS
=pod

=head1 SYNOPSIS

 ##========================================================================
 ## PRELIMINARIES
 
 use DTA::CAB::Server::HTTP::UNIX;
 

=cut

##------------------------------------------------------------------------

CAB/Server/HTTP/UNIX.pm  view on Meta::CPAN

and calls the L<prepareRelay()|/prepareRelay> method to optionally set up a
TCP relay subprocess.

=item prepareRelay

 $bool = $srv->prepareRelay();

Starts a TCP listener subprocess to relay incoming
TCP messages to the server's UNIX socket if requested.
A TCP listener process will be started on ADDR:PORT
if a TCP address+port pair (ADDR,PORT) is specified
in $srv-E<gt>{daemonArgs} (keys "LocalAddr","LocalPort")
or $srv itself (keys "relayAddr","relayPort").  You must
have the L<socat(1)|socat> program installed on your system
for this to work.

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Server::HTTP::UNIX: Methods: Local: spawn and reap
=pod

=head3 Methods: Local: spawn and reap

=over 4

=item reaper

 \&reaper = $srv->reaper();

Zombie-harvesting code; installed to local %SIG.
Override returns a reaper sub which die()s if it harvests
the TCP relay subprocess started by the L<prepareRelay()|/prepareRelay>
method.

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Server::HTTP::UNIX: PACKAGE: DTA::CAB::Server::HTTP::UNIX::ClientConn
=pod

=head3 PACKAGE: DTA::CAB::Server::HTTP::UNIX::ClientConn

=over 4

=item Variable: @ISA

L<DTA::CAB::Server::HTTP::UNIX|DTA::CAB::Server::HTTP::UNIX::ClientConn>
inherits from
L<HTTP::Daemon::ClientConn|HTTP::Daemon>
and should support most HTTP::Daemon::ClientConn methods.

=item peercred

 ($pid,$uid,$gid) = $sock->peercred();

Gets UNIX socket peer credentials; returns (-1,-1,-1) on failure.

=item peerenv

 \%env = $sock->peerenv();
 \%env = $sock->peerenv($pid);

Attempts to retrieve environment variables for peer process, if possible.
Uses cached value in ${*sock}{peerenv} if present,
otherwise attempts to open and parse F</proc/$pid/environ>.
Returns undef on failure.

=item peerstr

 $str = $sock->peerstr();
 $str = $sock->peerstr($uid,$gid,$pid);

Returns stringified unix peer credentials, "${USER}.${GROUP}[${PID}]".

=item peerhost

 $host = peerhost();

For relayed connections, gets underlying TCP peer via socat environment (INET emulation);
for unix connections, returns UNIX credentials as as for peerstr().

=item peerport

 $port = peerport();

For relayed connections, gets underlying TCP port via socat environment (INET emulation);
for unix connections, returns socket path:

=back

=cut

##======================================================================
## Footer
##======================================================================
=pod

=head1 AUTHOR

Bryan Jurish E<lt>moocow@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2017-2019 by Bryan Jurish

This package is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.24.1 or,
at your option, any later version of Perl 5 you may have available.

=head1 SEE ALSO

L<dta-cab-analyze.perl(1)|dta-cab-analyze.perl>,
L<dta-cab-convert.perl(1)|dta-cab-convert.perl>,
L<dta-cab-http-server.perl(1)|dta-cab-http-server.perl>,
L<dta-cab-http-client.perl(1)|dta-cab-http-client.perl>,
L<dta-cab-xmlrpc-server.perl(1)|dta-cab-xmlrpc-server.perl>,
L<dta-cab-xmlrpc-client.perl(1)|dta-cab-xmlrpc-client.perl>,
L<DTA::CAB::Server(3pm)|DTA::CAB::Server>,
L<DTA::CAB::Server::UNIX(3pm)|DTA::CAB::Server::UNIX>,
L<DTA::CAB::Client(3pm)|DTA::CAB::Client>,
L<DTA::CAB::Format(3pm)|DTA::CAB::Format>,
L<DTA::CAB(3pm)|DTA::CAB>,
L<perl(1)|perl>,
...



=cut