Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
Well, I am suggesting it because the documentation recommends it.

I tried it out and it seems to work, with one change, that it needs SSL_server => 1 here:

my $sslaccept = IO::Socket::SSL->start_SSL($acceptsock, {SSL_startHandshake => 0, SSL_server => 1, SSL_use_cert => 1, SSL_verify_depth => 1, SSL_verify_mode => 0x03, });
Otherwise it will try to authenticate as a client.

Here's a restructured program:

#!/usr/bin/perl 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 $listenport = 2222; my $listen = IO::Socket::INET->new( LocalPort => $listenport, Listen => 10, Reuse => 1, ); my $timeout = undef; my $rlen = 1024; my $wlen = 4096; my $fblen = 10240; *$listen->{callback} = \&accepter; my $rselect = IO::Select->new($listen); my $wselect = IO::Select->new(); $|++; while (1) { eval { # for all readable sockets my @socks = IO::Select::select($rselect, $wselect, undef, $timeout); my $processed = 0; for my $aref (@socks) { if ($aref) { for my $sock (@{$aref}) { if (*$sock->{callback}) { *$sock->{callback}($sock, $rselect, $wselect); } else { die "Internal error no callback on socket: $sock\n"; } ++$processed; } } } if ($processed == 0) { # do timeout } }; print "uncaught error: $@\n" if $@; } sub accepter { my ($sock, $rselect, $wselect) = @_; my $acceptsock = $sock->accept; my $sslaccept = IO::Socket::SSL->start_SSL($acceptsock, {SSL_startHandshake => 0, SSL_server => 1, SSL_use_cert => 1, SSL_verify_depth => 1, SSL_verify_mode => 0x03, }); $rselect->add($sslaccept); @{*$sslaccept}{qw/sbuf size state callback/} = ('', 0, 'handshake', \&do_handshake); # then go back to your select() } sub do_handshake { my ($sock, $rselect, $wselect) = @_; my $sslclient = $sock->accept_SSL(); if (defined($sslclient)) { # success! # advance the state of socket to connected, etc. *$sock->{state} = 'need_headers'; *$sock->{callback} = \&proc_headers; } elsif ($SSL_ERROR == SSL_WANT_READ ) { $rselect->add($sock); $wselect->remove($sock); } elsif ($SSL_ERROR == SSL_WANT_WRITE) { $rselect->remove($sock); $wselect->add($sock); } else { # connect failed # maybe log it .. $rselect->remove($sock); $wselect->remove($sock); $sock->close(); } } sub proc_headers { my ($sock, $rselect, $wselect) = @_; my $props = *$sock; # reading incoming request... my $read = $sock->sysread( $props->{sbuf},$rlen,$props->{size}); unless (defined $read) { $rselect->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 callback/} = ($bsize, 'need_body', \&read_body); # already in $rselect } else { $rselect->remove($sock); request_done($sock, $rselect, $wselect, ''); } } } sub read_body { my ($sock, $rselect, $wselect) = @_; my $props = *$sock; # 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) request_done($sock, $rselect, $wselect, $props->{sbuf}) unless $props->{need}; } sub request_done { my ($sock, $rselect, $wselect, $body) = @_; my $props = *$sock; @{$props}{qw/size sbuf body/} = (0, '', $body); # 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'; $props->{callback} = \&send_response; } send_response($sock, $rselect, $wselect); } sub send_response { # writing outgoing response... my ($sock, $rselect, $wselect) = @_; my $props = *$sock; my $size = $props->{wsize} < $wlen ? $props->{wsize} : $wlen; $wselect->add($sock); my $wrote = $sock->syswrite( $props->{wbuf},$size,$props->{wdone}); unless (defined $wrote) { $wselect->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. $wselect->remove($sock); if ($props->{keepalive}) { $rselect->add($sock); $props->{wdone} = 0; $props->{wsize} = 0; $props->{wbuf} = ''; $props->{state} = 'need_headers'; $props->{callback} = \&proc_headers; # seemingly correct, but blocks listener socket #$sock->close(SSL_no_shutdown => 1); } else { $sock->close(); } } }

In reply to Re^3: Multiplexing HTTPS server, peer cert authentication problem. by Thelonius
in thread Multiplexing HTTPS server, peer cert authentication problem. by erroneousBollock

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others browsing the Monastery: (10)
    As of 2014-08-01 12:39 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      Who would be the most fun to work for?















      Results (16 votes), past polls