#!/usr/bin/perl

# <--- this is line 3
# Mutliplexing HTTP/S server to show IO::Socket::SSL problem.
#   for HTTP (working):
#     Comment lines 16,25,29,30,31,32
#     Uncomment lines 15,24
#   for HTTPS without peer cert authentication (working): 
#     Comment lines 15,24,30,32
#     Uncomment lines 16,25,29,31
#   for HTTPS with peer cert authentication (broken):
#     Comment lines 15,24,31
#     Uncomment lines 16,25,29,30,32

use IO::Socket::INET;
#use IO::Socket::SSL qw/debug4/;
use IO::Select;
use HTTP::Response;
use File::MMagic;
use strict;
use warnings;

my $magic = File::MMagic->new;
my $listen = IO::Socket::INET->new(
#my $listen = IO::Socket::SSL->new(
    LocalPort       => 2222,
    Listen          => 10,
    Reuse           => 1,
#    SSL_use_cert     => 1,
#    SSL_verify_depth => 1,    # verify CA->server, server->client
#    SSL_verify_mode  => 0x00, # works  (no peer cert auth)
#    SSL_verify_mode  => 0x03  # broken (peer cert auth)
  );

my $timeout = 0.002;    
my $rlen    = 1024;
my $wlen    = 4096;
my $fblen   = 10240;

my $select = IO::Select->new($listen);

$|++;
while (1) {
  eval {

    # for all readable sockets
    for my $sock ($select->can_read($timeout)) {

      if ($sock == $listen) {

        # accept a new client socket
        my $client = $sock->accept; # = myAccept($sock);
        if (defined($client)) {
          @{*$client}{qw/sbuf size state/} = ('', 0, 'need_headers');
          $select->add($client);
        } else {
          print "accept error: $!\n";
        }

      } else {

        # already connected client socket
        my $props = *$sock;

        if ($props->{state} eq 'need_headers') {

          # reading incoming request...
          my $read = $sock->sysread(
            $props->{sbuf},$rlen,$props->{size});
          unless (defined $read) {
            $select->remove($sock);
            die "read error: $!\n";
          }
          $props->{size} += $read;

          if (my ($headers) = 
            ($props->{sbuf} =~ /^(.*?)\r\n\r\n(.*)/s)) {{

            # we've finished reading the HTTP header
            use bytes;

            my ($verb, $uri) = ($headers =~ /^(\w+)\s+(\S+)/);
            print "[$verb] [$uri]\n";

            # put any remaining bytes of request back into the buffer 
            # (likely HTTP message body)
            @{$props}{qw/headers verb uri sbuf size/} = (
                $headers, $verb, $uri, 
                substr($props->{sbuf}, length($headers)),
                length($props->{sbuf})
              );

            if (my ($bsize) = 
              ($headers =~ /Content-Length\s*:\s*(\d+)/s)) {
          
              # need to read HTTP message body of length $bsize
              @{$props}{qw/need state/} = ($bsize, 'need_body');

            } else {

              # no HTTP message body follows, done reading request
              @{$props}{qw/size sbuf body state/} = 
                (0, '', '', 'request_done');

            }
          }}

        } elsif ($props->{state} eq 'need_body') {

          # reading body...
          my $size = $props->{need} < $rlen ? $props->{need} : $rlen;
          my $read = $sock->sysread(
            $props->{sbuf},$size,$props->{size});
          $props->{size} += $read;
          $props->{need} -= $read;

          # done reading body (if we've read enough bytes) 
          @{$props}{qw/size sbuf body state/} = 
            (0, '', $props->{sbuf}, 'request_done') 
            unless $props->{need};

        }
      }
    } # -- readable sockets

    # for all writable sockets
    for my $sock ($select->can_write($timeout)) {

      next if $sock == $listen;
      my $props = *$sock;

      # we only want to write to sockets with from which we've read 
      # a full request
      if ($props->{state} eq 'request_done') {

        # request read, build response...
        my $msg;
        
        #
        # YES: I'm aware the path is tainted/insecure.
        #      This is just an example to demonstrate failure.
        #
        if (-f ".".$props->{uri}) {

          # the requested file was found, so...
          # determine mime-type
          my $type = $magic->checktype_filename(
            ".".$props->{uri}) || "text/html";

          # read local file
          open F, "<.".$props->{uri};
          my ($buf, $len) = ('', 0);
          while (my $read = sysread(F, $buf, $fblen, $len)) { 
            $len += $read;      
          }
          close F;

          # will send positive response
          $msg = [200, 'OK', $type, $buf];

        } else {

          # will send negative response
          $msg = [404, 'File Not Found', 'text/html', 'What file?!?'];

        }

        {
          use bytes;

          # construct HTTP response as a string
          $props->{wbuf} =
            'HTTP/1.1 '.
            HTTP::Response->new(
                $msg->[0] => $msg->[1],
                ['Content-Type'   => $msg->[2],
                 'Content-Length' => length($msg->[3]),
                 'Connection'     => 'close'],
                $msg->[3]
              )->as_string;
          $props->{wdone} = 0;
          $props->{wsize} = length($props->{wbuf});
          $props->{state} = 'response_pending';
        }

      } elsif ($props->{state} eq 'response_pending') {

        # writing outgoing response...
        my $size = $props->{wsize} < $wlen ? $props->{wsize} : $wlen;
        my $wrote = $sock->syswrite(
          $props->{wbuf},$size,$props->{wdone});
        unless (defined $wrote) {
          $select->remove($sock);
          die "write error: $!\n";
        }
        $props->{wdone} += $wrote;

        if ($props->{wdone} == $props->{wsize}) {

          # we're done sending the request, ready for another
          # NOTE: IO::Socket::SSL docs say we can't do multiple 
          # requests, but it does work in the absense of 
          # peer cert authentication.
          $props->{wdone} = 0;
          $props->{wsize} = 0;
          $props->{wbuf}  = '';
          $props->{state} = 'need_headers';
          
          # seemingly correct, but blocks listener socket
          #$sock->close(SSL_no_shutdown => 1);  
        }

      }

    } # -- writable sockets

  };
  # print any perl-level exception
  print "uncaught error: $@\n" if $@;

}

# this is something HTTP::Daemon::SSL does...
# seems to be a work-around for premature return 
# from IO::Socket::SSL::accept
sub myAccept
{
  my $self = shift;
  while (1) {
    # I hope this doesn't block too long
    my $sock = IO::Socket::SSL::accept($self);
    return $sock if ($sock || 
      $self->errstr =~ /^IO::Socket[^\n]* accept failed$/);
  }
}