view release on metacpan or  search on metacpan

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

}

##==============================================================================
## Methods: Generic Server API: mostly inherited
##==============================================================================

##--------------------------------------------------------------
## $bool = $srv->ensureSocketDir()
## $bool = $srv->ensureSocketDir($socketPath)
##  + ensures that directory of $socketPath exists
##  + sets $srv->{_socketDirs} if any directories are created
sub ensureSocketDir {
  my ($srv,$sockpath) = @_;
  $sockpath ||= ($srv->{_socketPath}
		 || ($srv->{daemon} ? $srv->{daemon}->hostpath : undef)
		 || $srv->{daemonArgs}{Local});
  $srv->logconfess("ensureSocketDir(): no socket path defined")
    if (!$sockpath);

  my $sockdir = dirname($sockpath);
  if (!-d $sockdir) {
    my @created = make_path($sockdir)
      or $srv->logconfess("ensureSocketDir(): failed to create socket directory '$sockdir': $!");
    $srv->{_socketDirs} = \@created;
  }

  return 1;
}

##--------------------------------------------------------------
## $rc = $srv->prepareLocal()
##  + subclass-local initialization
sub prepareLocal {
  my $srv = shift;

  ##-- ensure socket path directory
  my $sockpath = $srv->{daemonArgs}{Local}
    or $srv->logconfess("prepareLocal(): no socket path defined in {daemonArgs}{Local}");
  $srv->ensureSocketDir($sockpath)
    or $srv->logconfess("prepareLocal(): failed to create directory for socket $sockpath: $!");

  ##-- Server::HTTP initialization
  my $rc  = $srv->SUPER::prepareLocal(@_);
  return $rc if (!$rc);
  $srv->{daemon}->listen( $srv->{daemonArgs}{Listen}||SOMAXCONN ); ##-- workaround for missing option pass-through HTTP::Daemon::UNIX v0.06

  ##-- get socket path
  $sockpath = $srv->{_socketPath} = $srv->{daemon}->hostpath()
    or $srv->logconfess("prepareLocal(): daemon returned bad socket path");

  ##-- setup socket ownership
  my $sockuid = (($srv->{socketUser}//'') =~ /^[0-9]+$/
		 ? $srv->{socketUser}
		 : getpwnam($srv->{socketUser}//''));
  my $sockgid = (($srv->{socketGroup}//'') =~ /^[0-9]+$/
		 ? $srv->{socketGroup}
		 : getgrnam($srv->{socketGroup}//''));
  if (defined($sockuid) || defined($sockgid)) {
    $sockuid //= $>;
    $sockgid //= $);
    $srv->vlog('info', "setting socket ownership (".scalar(getpwuid $sockuid).".".scalar(getgrgid $sockgid).") on $sockpath");
    chown($sockuid, $sockgid, $sockpath)
      or $srv->logconfess("prepareLocal(): failed to set ownership for socket '$sockpath': $!");

    foreach my $dir (reverse @{$srv->{_socketDirs}||[]}) {
      $srv->vlog('info', "setting directory ownership (".scalar(getpwuid $sockuid).".".scalar(getgrgid $sockgid).") on $dir");
      chown($sockuid, $sockgid, $dir)
	or $srv->logconfess("prepareLocal(): failed to set ownership for directory '$dir': $!");
    }
  }

  ##-- setup socket permissions
  if ( ($srv->{socketPerms}//'') ne '' ) {
    my $sockperms = oct($srv->{socketPerms});
    $srv->vlog('info', sprintf("setting socket permissions (0%03o) on %s", $sockperms, $sockpath));
    chmod($sockperms, $sockpath)
      or $srv->logconfess("prepareLocal(): failed to set permissions for socket '$sockpath': $!");
    foreach my $dir (reverse @{$srv->{_socketDirs}||[]}) {
      $srv->vlog('info', sprintf("setting directory permissions (0%03o) on %s", ($sockperms|0111), $dir));
      chmod(($sockperms|0111), $dir)
	or $srv->logconfess("prepareLocal(): failed to set permissions for directory '$dir': $!");
    }
  }

  ##-- setup TCP relay subprocess
  $rc &&= $srv->prepareRelay(@_);

  ##-- ok
  return $rc;
}

##--------------------------------------------------------------
## $bool = $srv->prepareRelay()
##  + sets up TCP relay subprocess
##  + returns -1 if relay process couldn't be started
sub prepareRelay {
  my $srv = shift;
  my $addr = $srv->relayAddr;
  my $port = $srv->relayPort;
  return 1 if (!$addr && !$port); ##-- no relay required

  my $sockpath = $srv->{_socketPath};
  $addr ||= '0.0.0.0';
  @$srv{qw(relayAddr relayPort)} = ($addr,$port);

  ##-- check whether relay address is already bound
  if (!$srv->SUPER::canBindSocket({LocalAddr=>($srv->relayAddr||'0.0.0.0'), LocalPort=>$srv->relayPort})) {
    $srv->logwarn("WARNING: cannot bind TCP socket relay on ${addr}:${port} (is there a stale relay still running?): $!");
    return -1;
  }

  $srv->vlog('trace',"starting TCP socket relay on ${addr}:${port}");
  $SIG{CHLD} ||= $srv->reaper();

  ##-- set main server process as group leader (kill whole process group with `pkill -g $SERVER_PID`)
  POSIX::setpgid(0,0);
  my $pgid = POSIX::getpgrp();

  if ( ($srv->{relayPid}=fork()) ) {
    ##-- parent
    $srv->vlog('info', "started TCP socket relay process for ${addr}:${port} on pid=$srv->{relayPid}");
  } else {
    ##-- child (relay)

    ##-- cleanup: close file desriptors
    POSIX::close($_) foreach (3..1024);

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

## 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