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, }); #### #!/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(); } } }