view release on metacpan or  search on metacpan

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

## Methods: Generic Server API
##==============================================================================

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

  ##-- setup HTTP::Daemon object
  $srv->{daemonArgs}{Listen} ||= SOMAXCONN;
  if (!($srv->{daemon}=$srv->daemonClass->new(%{$srv->{daemonArgs}}))) {
    $srv->logconfess("could not create ", $srv->daemonClass, " daemon object: $!");
  }
  my $daemon = $srv->{daemon};

  ##-- register path handlers
  my ($path,$ph);
  while (($path,$ph)=each %{$srv->{paths}}) {
    $ph = $srv->registerPathHandler($path,$ph)
      or $srv->logconfess("registerPathHandler() failed for path '$path': $!");
    $srv->vlog($srv->{logRegisterPath}, "registered path handler: '$path' => ".(ref($ph)||$ph));
  }

  ##-- compile allow/deny regexes
  foreach my $policy (qw(allow deny)) {
    my $re = $srv->{$policy} && @{$srv->{$policy}} ? join('|', map {"(?:$_)"} @{$srv->{$policy}}) : '^$';
    $srv->{"_".$policy} = qr/$re/;
  }

  ##-- setup cache
  $srv->{cache} = DTA::CAB::Cache::LRU->new(max_size=>$srv->{cacheSize}) if (!$srv->{cache} && $srv->{cacheSize}>0);

  ##-- setup mode-specific options
  $srv->{daemonMode} //= 'serial';
  $srv->{pid}        //= $$;
  if ($srv->{daemonMode} eq 'fork') {
    $srv->{children} //= {};
    $SIG{CHLD} = $srv->reaper();
  }

  return 1;
}

## $rc = $srv->run()
##  + run the server
sub run {
  my $srv = shift;
  $srv->prepare() if (!$srv->{daemon}); ##-- sanity check
  $srv->logcroak("run(): no underlying daemon object!") if (!$srv->{daemon});

  my $daemon = $srv->{daemon};
  my $mode   = $srv->{daemonMode} || 'serial';
  my $cclass = $srv->clientClass;
  my $bgConnectTimeout = $srv->{bgConnectTimeout} || 0;
  $srv->info("server starting in $mode mode on ", $srv->daemonLabel, "\n");

  ##-- setup SIGPIPE handler (avoid heinous death)
  ##  + following suggestion on http://www.perlmonks.org/?node_id=580411
  $SIG{PIPE} = sub { ++$srv->{nErrors}; $srv->vlog('warn',"got SIGPIPE (ignoring)"); };

  ##-- HACK: set HTTP::Daemon protocol to HTTP 1.0 (avoid keepalive)
  $HTTP::Daemon::PROTO = "HTTP/1.0";

  my ($csock,$chost,$hreq,$urikey,$forkable,$cacheable,$handler,$localPath,$pid,$rsp);
  my ($fdset);
  while (1) {
    ##-- track total processing time for *last* query
    $srv->qtfinish();

    ##-- call accept() within the loop to avoid breaking out in fork mode
    if (!defined($csock=$daemon->accept())) {
      #sleep(1);
      next;
    }

    ##-- query processing starts
    $srv->{qt0} = [gettimeofday];

    ##-- re-bless client socket (for UNIX-domain server)
    bless($csock,$cclass) if ($cclass);

    ##-- got client $csock (HTTP::Daemon::ClientConn object; see HTTP::Daemon(3pm))
    $chost = $csock->peerhost();

    ##-- avoid blocking on weird EOF sockets sent e.g. by chromium: no joy
    if ($bgConnectTimeout > 0) {
      vec(($fdset=""), $csock->fileno, 1) = 1;
      if (!select($fdset,undef,undef,$bgConnectTimeout)) {
	$srv->vlog($srv->{logAttempt}, "ignoring background connection from client $chost");
	#++$srv->{nErrors};
	next;
      }
    }

    ##-- access control
    $srv->vlog($srv->{logAttempt}, "attempted connect from client $chost");
    if (!$srv->clientAllowed($csock,$chost)) {
      $srv->denyClient($csock);
      next;
    }

    ##-- track number of requests
    ++$srv->{nRequests};

    ##-- serve client: parse HTTP request
    ##
    ## Strangeness Fri, 17 May 2013 14:14:56 +0200
    ## + returning true from demo.js cabUpload() causes weird 'Client closed' errors on post-upload 'Back' clicks from chromium
    ## + problem maybe related to bizarre closed-client crashes for HTTP::Daemon::ClientConn observed elsewhere: persists even within eval BLOCK
    ## + symptom(s):
    ##   - get_request() fails after ca. 10sec
    ##   - HTTP::Daemon::DEBUG output shows "Need more data for complete header\nsysread()\n"
    ##   - no data is actually read into $csock buffer (checked with debugger)
    ##   - $csock invalidates with $csock->reason='Client closed', but $csock->opened()==1
    ##   - attempting to write to $csock in this state (e.g. by clientError()) causes immediate termination of the running server!
    ##
    ##DEBUG
    #$srv->vlog($srv->{logAttempt}, "get_request() for client $chost");
    #$HTTP::Daemon::DEBUG=1;
    ${*$csock}{'io_socket_timeout'} = 5;
    ${*$csock}{'httpd_client_proto'} = HTTP::Daemon::ClientConn::_http_version("HTTP/1.0"); ##-- HACK: force status line on send_error() from $csock->get_request()