File Coverage

blib/lib/HTTP/Server/Singlethreaded.pm

Criterion	Covered	Total	%
statement	67	258	25.9
branch	19	122	15.5
condition	0	6	0.0
subroutine	12	17	70.5
pod	0	5	0.0
total	98	408	24.0

package HTTP::Server::Singlethreaded;

BEGIN{
	eval ( $ENV{OS}=~/win/i ? <

	sub BROKENSYSWRITE(){1}

WIN

	sub BROKENSYSWRITE(){0}

NOTWIN

}


use 5.006;
use strict;
use warnings;
use vars qw/

%Static
%Function
%CgiBin
%Path


$DefaultMimeType
%MimeType

@Port
$Timeout
$MaxClients
$ServerType
$VERSION
$RequestTally
$uid $gid $forkwidth @kids
$WebEmail
$StaticBufferSize
@Cport
@Caddr
@Sport
@Saddr
/;

sub DEBUG() {
#	1
	0
};

$RequestTally = 0;
$StaticBufferSize ||= 50000;

# file number of request
my $fn;
# arrays indexed by $fn
my @Listeners;    # handles to listening sockets
my @PortNo;       # listening port numbers indexed by $fn
my @Clients;      # handles to client sockets
my @inbuf;        # buffered information read from clients
my @outbuf;       # buffered information for writing to clients
my @LargeFile;    # handles to large files being read, indexed by
                  # $fn of the client they are being read for
my @continue;     # is there a continuation defined for this fn?
my @PostData;     # data for POST-style requests

#lists of file numbers
my @PollMe;       #continuation functions associated with empty output buffers

$VERSION = '0.12';

# default values:
$ServerType ||= __PACKAGE__." $VERSION (Perl $])";
@Port or @Port = (80,8000);
$Timeout ||= 5;
$MaxClients ||= 10;
$DefaultMimeType ||= 'text/plain';
keys(%MimeType ) or
  @MimeType{qw/txt htm html jpg gif png/} =
  qw{text/plain text/html text/html image/jpeg image/gif image/png};

sub Serve();
# use IO::Socket::INET;
use Socket  qw(:DEFAULT :crlf);
BEGIN{
	use Fcntl;
        # determine if O_NONBLOCK is available,
        # for use in fcntl($l, F_SETFL, O_NONBLOCK)
        eval{
          # print "O_NONBLOCK is ",O_NONBLOCK,
          #      " and F_SETFL is ",F_SETFL,"\n";
          no warnings; O_NONBLOCK; F_SETFL;
        };
        if ($@){
           warn "O_NONBLOCK is broken, but a workaround is in place.\n";
	   eval'sub BROKEN_NONBLOCKING(){1}';
        }else{
	   eval'sub BROKEN_NONBLOCKING(){0}';
        };
}

sub makeref($){
	ref($_[0]) ? $_[0] : \$_[0]
};

sub import(){

  DEBUG and print __PACKAGE__," import called\n";

  shift; # we don't need to know __PACKAGE__

  # DYNAMIC RECONFIGURATION SECTION
  my %args = @_;
  DEBUG and do{
	print "$_ is $args{$_}\n" foreach sort keys %args

  };
  exists $args{port} and *Port = $args{port};
  exists $args{timeout} and *Timeout = $args{timeout};
  exists $args{maxclients} and *MaxClients = $args{maxclients};
  exists $args{static} and *Static = $args{static};
  exists $args{function} and *Function = $args{function};
  exists $args{cgibin} and *CgiBin = $args{cgibin};
  exists $args{servertype} and *ServerType = $args{servertype};
  exists $args{webemail} and *WebEmail = makeref($args{webemail});
  exists $args{path} and *Path = $args{path};

  @Port or die __PACKAGE__." invoked with empty \@Port array";

  @Listeners = ();
  for (@Port) {
     my $l;
     socket($l, PF_INET, SOCK_STREAM,getprotobyname('tcp'))
        || die "socket: $!";
     unless (BROKEN_NONBLOCKING){
       fcntl($l, F_SETFL, O_NONBLOCK)
        || die "can't set non blocking: $!";
     };
     setsockopt($l, SOL_SOCKET,
                SO_REUSEADDR,
                pack("l", 1))
        || die "setsockopt: $!";
     bind($l, sockaddr_in($_, INADDR_ANY))
        || do {warn "bind: $!";next};
     listen($l,SOMAXCONN)
        || die "listen: $!";
     if (defined $l){
        print "bound listener to $_\n";
        $PortNo[fileno($l)] = $_;
        push @Listeners,$l;
     }else{
         print "Could not bind listener to $_\n";
     };
  } ;

  @Listeners or die __PACKAGE__." could not bind any listening sockets among @Port";

###########################################################################
#   uncomment the following if so desired
###########################################################################
#   if($defined $uid){
#      $> = $< = $uid
#   };
#
#   if($defined $gid){
#      $) = $( = $gid
#   };
#
#   if($defined $forkwidth){
#      my $pid; my $i=0;
#      while (++$i < $forkwidth){
#         $pid = fork or last;
#         unshift @kids, $pid
#      };
#      unless($kids[0] ){
#        @kids=();
#      };
#      $forkwidth = "$i of $forkwidth";
#   };
#   END{ kill 'TERM', $_ for @kids };
############################################################################



   for (keys %Function){
      die "$Function{$_} is not a coderef"
        unless (ref $Function{$_} eq 'CODE');
      $Path{$_} = $Function{$_};
   }
   for (keys %Static){
      die "path $_ already defined" if exists $Path{$_};
      $Path{$_} = "STATIC $Static{$_}";
   }
   for (keys %CgiBin){
      die "path $_ already defined" if exists $Path{$_};
      $Path{$_} = "CGI $CgiBin{$_}";
   }

   {
      # import Serve into caller's package
      no strict;
      *{caller().'::Serve'} = \&Serve;
   }


};

my %RCtext =(
    100=> 'Continue',
    101=> 'Switching Protocols',
    200=> 'OK',
    201=> 'Created',
    202=> 'Accepted',
    203=> 'Non-Authoritative Information',
    204=> 'No Content',
    205=> 'Reset Content',
    206=> 'Partial Content',
    300=> 'Multiple Choices',
    301=> 'Moved Permanently',
    302=> 'Found',
    303=> 'See Other',
    304=> 'Not Modified',
    305=> 'Use Proxy',
    306=> '(Unused)',
    307=> 'Temporary Redirect',
    400=> 'Bad Request',
    401=> 'Unauthorized',
    402=> 'Payment Required',
    403=> 'Forbidden',
    404=> 'Not Found',
    405=> 'Method Not Allowed',
    406=> 'Not Acceptable',
    407=> 'Proxy Authentication Required',
    408=> 'Request Timeout',
    409=> 'Conflict',
    410=> 'Gone',
    411=> 'Length Required',
    412=> 'Precondition Failed',
    413=> 'Request Entity Too Large',
    414=> 'Request-URI Too Long',
    415=> 'Unsupported Media Type',
    416=> 'Requested Range Not Satisfiable',
    417=> 'Expectation Failed',
    500=> 'Internal Server Error',
    501=> 'Not Implemented',
    502=> 'Bad Gateway',
    503=> 'Service Unavailable',
    504=> 'Gateway Timeout',
    505=> 'HTTP Version Not Supported'
);


our @Moustache;  # per-fn %_ references

sub dispatch(){
# based on the request, which is in $_,
# figure out what to do, and do it.
# return a numeric resultcode in $ResultCode
# and data in $Data

   if(DEBUG){
     print "Request on fn $fn:\n${_}END_REQUEST\n";
   };

   # defaults:
   *_ = $Moustache[$fn] = {
       Data => undef,
       ResultCode => 200
   };

   $continue[$fn] = undef;

   # rfc2616 section 5.1
   /^(\w+) (\S+) HTTP\/(\S+)\s*(.*)$CRLF$CRLF/s
      or do { $_{ResultCode} = 400;
              return <
Content-type:text/plain

This server only accepts requests that
match the perl regex
/^(\\w+) (\\S+) HTTP\\/(\\S+)/

EOF
   };
   @_{qw/
      REQUEST_METHOD REQUEST_URI HTTPver RequestHeader
      REMOTE_ADDR REMOTE_PORT SERVER_ADDR SERVER_PORT/
   } = (
      $1,$2,$3,$4,
      $Caddr[$fn], $Cport[$fn],
      $Saddr[$fn], $Sport[$fn]
   );
   if(DEBUG){for( sort keys %_ ){
      print "$_ is $_{$_}\n";
   }};

   # REQUEST_URI is
   # equivalent to SCRIPT_NAME . PATH_INFO . '?' . QUERY_STRING

   my $shortURI;
   ($shortURI ,$_{QUERY_STRING}) = $_{REQUEST_URI}=~m#(/[^\?]*)\??(.*)$#;
   $shortURI =~ s/%(..)/chr hex $1/ge; # RFC2616 sec. 3.2
   if (uc($_{REQUEST_METHOD}) eq 'POST'){
      $_{POST_DATA} = $PostData[$fn];
   };

   my @URIpath = split '/',$shortURI,-1;
   my @Castoffs;
   my $mypath;
   while (@URIpath){
      $mypath = join '/',@URIpath;
      DEBUG and warn "considering $mypath\n";
      if (exists $Path{$mypath}){
         $_{SCRIPT_NAME} = $mypath;
         print "PATH $mypath is $Path{$mypath}";
         $_{PATH_INFO} = join '/', @Castoffs;
         print " and PATH_INFO is $_{PATH_INFO}\n";
         if (ref $Path{$mypath}){
            my $DynPage;
            eval {
               $DynPage = &{$Path{$mypath}};
            };
            $@ or return $DynPage;
            $_{ResultCode} = 500;
            return <
Content-type:text/plain

Internal server error while processing routine
for $mypath:

$@
EOF
         };
         if ($Path{$mypath} =~/^STATIC (.+)/){
            my $FILE;
            my $filename = "$1/$_{PATH_INFO}";
            print "filename: $filename\n";
            $filename =~ s/\/\.\.\//\//g; # no ../../ attacks
            my ($ext) = $filename =~ /\.(\w+)$/;
            my $ContentType = $MimeType{$ext}||$DefaultMimeType;
            # unless (-f $filename and -r _ ){
            unless(open $FILE, "<", $filename){
               $_{ResultCode} = 404;
               return <
Content-type: text/plain

Could not open $filename for reading
$!

for $mypath: $Path{$mypath}

Request:

$_

EOF
            };
            # range will go here when supported
            my $size = -s $filename;
            my $slurp;
            my $read = sysread $FILE, $slurp, $StaticBufferSize ;

            if ($read < $size){
               $LargeFile[$fn] = $FILE;
            };

            return "Content-type: $ContentType\n\n$slurp";

         };
         $_{ResultCode} = 404;
         return <
Content-type:text/plain

This version of Singlethreaded does not understand
how to serve

$mypath

$Path{$mypath}

Responsible person: $WebEmail

We received this request:

$_

EOF
      };
      if((length $URIpath[$#URIpath]) > 0){
         unshift @Castoffs, pop @URIpath;
      }else{
         $URIpath[$#URIpath] = '/'
      };
   };


   $_{ResultCode} = 404;
   <
Content-type:text/plain

$$ $RequestTally handling fileno $fn

apparently this Singlethreaded server does not
have a default handler installed at its
virtual root.

Castoffs: [@Castoffs]

Responsible person: [$WebEmail]

$_

EOF

};


sub HandleRequest(){
   $RequestTally++;
   print "Handling request $RequestTally on fn $fn\n";
   DEBUG and warn "Inbuf:\n$inbuf[$fn]\n";
   *_ = \delete $inbuf[$fn]; # tight, huh? (the scalar slot)

   my $dispatchretval = dispatch;
   $dispatchretval or return undef;
   $outbuf[$fn]=<
HTTP/1.1 $_{ResultCode} $RCtext{$_{ResultCode}}
Server: $ServerType
Connection: close
EOF
   # *_ = $Moustache[$fn];  # also, the hash slot -- this is done in &dispatch, never mind
   HandleDRV($dispatchretval);
   DEBUG and warn "Outbuf:\n$outbuf[$fn]\n";
};
sub HandleDRV{
   my $dispatchretval = shift;
   @_ and $dispatchretval = [$dispatchretval,shift]; # support old-style
   $continue[$fn] = undef;
   { no warnings; length $_{Data} and $outbuf[$fn] .= $_{Data}; }
   if(ref($dispatchretval)){
      $continue[$fn] = $dispatchretval;

   }else{
	$outbuf[$fn].=$dispatchretval
   }

};

my $client_tally = 0;
sub Serve(){
   DEBUG and print "L: (@Listeners) C: (@Clients)\n";
   my ($rin,$win,$ein,$rout,$wout,$eout);
   my $nfound;

BEGIN_SERVICE:

  # support for continuation coderefs to empty outbufs
  @PollMe = grep {
	 $fn = $_;
         DEBUG and warn "polling $_";
         if ( $continue[$_] ) {
           *_ = $Moustache[$_]; # the hash slot
	   DEBUG and warn "still working with $_";
           $_{Data} = '';
   	   HandleDRV( &{$continue[$_]} );
	   $continue[$_];
         }
  } @PollMe;



   # poll for new connections?
   my $Accepting = ($client_tally < $MaxClients);
   $rin = $win = $ein = '';
   if($Accepting){
      for(@Listeners){
         $fn = fileno($_);
         vec($rin,$fn,1) = 1;
         vec($win,$fn,1) = 1;
         vec($ein,$fn,1) = 1;
      };
   };


   my @Outs;
   my @CompleteRequests;
   # list all clients in $ein and $rin
   # list connections with pending outbound data in $win;
   for(@Clients){
      $fn = fileno($_);
      vec($rin,$fn,1) = 1;
      vec($ein,$fn,1) = 1;
      if( length $outbuf[$fn]){
         vec($win,$fn,1) = 1;
         push @Outs, $_;
      }
   };

   # Select.
   $nfound = select($rout=$rin, $wout=$win, $eout=$ein, $Timeout);
   $nfound > 0 or return;
   my $Services = 0; # goes true when writing outbound bytes
   # accept new connections
   if($Accepting){
      for(@Listeners){
         my $paddr;
         vec($rout,fileno($_),1) or next;
         # relies on listeners being nonblocking
         # thanks, thecap
         # (at http://www.perlmonks.org/index.pl?node_id=6535)
#BLAH         if (BROKEN_NONBLOCKING){ # this is a constant so the unused one
#BLAH                                  # will be optimized away
#BLAH          acc:
#BLAH          $paddr=accept(my $NewServer, $_);
#BLAH          if ($paddr){
#BLAH            $fn =fileno($NewServer);
#BLAH	    ($Cport[$fn], my $iaddr) = sockaddr_in($paddr);
#BLAH	    $Caddr[$fn] = inet_ntoa($iaddr);
#BLAH            $inbuf[$fn] = $outbuf[$fn] = '';
#BLAH            print "Accepted $NewServer (",
#BLAH                  $fn,") ",
#BLAH                  ++$client_tally,
#BLAH                  "/$MaxClients on $_ ($fn) port $PortNo[fileno($_)]\n";
#BLAH            push @Clients, $NewServer;
#BLAH
#BLAH
#BLAH          }
#BLAH
#BLAH	  # select again to see if there's another
#BLAH          # client enqueued on $_
#BLAH          my $rvec;
#BLAH          vec($rvec,fileno($_),1) = 1;
#BLAH          select($rvec,undef,undef,0);
#BLAH          vec($rvec,fileno($_),1) and goto acc;
#BLAH
#BLAH         }else{  # WORKING NON_BLOCKING
          while ($paddr=accept(my $NewServer, $_)){
            $fn =fileno($NewServer);
	    $continue[$fn] = undef;
	    $Moustache[$fn] = {};
            $inbuf[$fn] = $outbuf[$fn] = '';
	    ($Cport[$fn], my $iaddr) = sockaddr_in($paddr);
	    $Caddr[$fn] = inet_ntoa($iaddr);

	    my $mysockaddr = getsockname($NewServer);
	    ($Sport[$fn], $iaddr) = sockaddr_in($mysockaddr);
	    $Saddr[$fn] = inet_ntoa($iaddr);

            print "Accepted $NewServer (",
                  $fn,") ",
                  ++$client_tally,
                  "/$MaxClients on $_ ($fn) port $PortNo[fileno($_)]\n";
            push @Clients, $NewServer;

	    BROKEN_NONBLOCKING and last; # much simpler
          }
#BLAH   }
      }
   } # if accepting connections

   # Send outbound data from outbufs
   my $wlen;
   for my $OutFileHandle (@Outs){
      $fn = fileno($OutFileHandle);
      ((defined $fn) and vec($wout,$fn,1)) or next;
         $Services++;
      $wlen = syswrite $OutFileHandle, $outbuf[$fn], (BROKENSYSWRITE ? 1 : length($outbuf[$fn]));
      if(defined $wlen){
        DEBUG and print "wrote $wlen of ",length($outbuf[$fn])," to ($fn)\n";
        substr $outbuf[$fn], 0, $wlen, '';

        if(
           length($outbuf[$fn]) < $StaticBufferSize
        ){
	 # then we would like to add some more to our outbuf
         if(
           # support for chunking large files (not HTTP1.1 chunking, just
           # reading as we go
           defined($LargeFile[$fn])
         ){
             my $slurp;
             my $read = sysread $LargeFile[$fn], $slurp, $StaticBufferSize ;
             # zero for EOF and undef on error
             if ($read){
               $outbuf[$fn].= $slurp;
             }else{
                print "sysread error: $!" unless defined $read;
                delete $LargeFile[$fn];
             };
         }elsif(
           # support for continuation coderefs
           $continue[$fn]
         ){
           *_ = $Moustache[$fn]; # the hash slot
           $_{Data} = '';
   	   HandleDRV( &{$continue[$fn]} );
           length ($outbuf[$fn]) or push @PollMe, $fn;
           next;
         };
        }
      }else{
         warn "Error writing to socket $OutFileHandle ($fn): $!";
         $outbuf[$fn] = '';
      }

      # rewrite this when adding keepalive support
      length($outbuf[$fn]) or close $OutFileHandle;
   }

   # read incoming data to inbufs and list inbufs with complete requests
   # close bad connections
   for(@Clients){
      defined($fn = fileno($_)) or next;
      if(vec($rout,$fn,1)){

         my $char;
         sysread $_,$char,64000;
	 if(length $char){
                DEBUG and print "$fn: read [$char]\n";
		$inbuf[$fn] .= $char;
                # CompleteRequest or not?
                if($inbuf[$fn] =~
/^POST .*?Content-Length: ?(\d+)[\015\012]+(.*)$/is){
                   DEBUG and print "posting $1 bytes\n";
                   if(length $2 >= $1){
                      push @CompleteRequests, $fn;
                      $PostData[$fn] = $2;
                   }else{
                      if(DEBUG){
                       print "$fn: Waiting for $1 octets of POST data\n";
                       print "$fn: only have ",length($2),"\n";
                      }
                   }
		}elsif(substr($inbuf[$fn],-4,4) eq "\015\012\015\012"){
                   push @CompleteRequests, $fn;
                }elsif(DEBUG){
                   print "Waiting for request completion. So far have\n[",
                   $inbuf[$fn],"]\n";

                };
	 }else{
            print "Received empty packet on $_ ($fn)\n";
		 print "CLOSING fd $fn\n";
                 close $_ or print "error on close: $!\n";
                 $client_tally--;
                 print "down to $client_tally / $MaxClients\n";
	 };
      }
      if(vec($eout,$fn,1)){
         # close this one
         print "error on $_ ($fn)\n";
	 print "CLOSING fd $fn\n";
         close $_ or print "error on close: $!\n";
      };
   }

   # prune @Clients array

   @Clients = grep { defined fileno($_) } @Clients;
   $client_tally = @Clients;
   DEBUG and print "$client_tally / $MaxClients\n";

   # handle complete requests
   # (outbound data will get written next time)
   for $fn (@CompleteRequests){

      HandleRequest

   };

   $Services and goto BEGIN_SERVICE; # keep selecting while we actually do something


};




1;
__END__