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);