1########################################################## 2# example HTTPS server using nonblocking sockets 3# requires Event::Lib 4# at the moment the response consists only of the HTTP 5# request, send back as text/plain 6########################################################## 7 8use strict; 9use IO::Socket; 10use IO::Socket::SSL; 11use Event::Lib; 12use Errno ':POSIX'; 13 14#$Net::SSLeay::trace=3; 15 16eval 'use Debug'; 17*{DEBUG} = sub {} if !defined(&DEBUG); 18 19# create server socket 20my $server = IO::Socket::INET->new( 21 LocalAddr => '0.0.0.0:9000', 22 Listen => 10, 23 Reuse => 1, 24 Blocking => 0, 25) || die $!; 26 27event_new( $server, EV_READ|EV_PERSIST, \&_s_accept )->add(); 28event_mainloop; 29 30########################################################## 31### accept new client on server socket 32########################################################## 33sub _s_accept { 34 my $fds = shift->fh; 35 my $fdc = $fds->accept || return; 36 DEBUG( "new client" ); 37 38 $fdc = IO::Socket::SSL->start_SSL( $fdc, 39 SSL_startHandshake => 0, 40 SSL_server => 1, 41 ) || die $!; 42 43 $fdc->blocking(0); 44 _ssl_accept( undef,$fdc ); 45} 46 47########################################################## 48### ssl handshake with client 49### called again and again until the handshake is done 50### this is called first from _s_accept w/o an event 51### and later enters itself as new event until the 52### handshake is done 53### if the handshake is done it inits the buffers for the 54### client socket and adds an event for reading the HTTP header 55########################################################## 56sub _ssl_accept { 57 my ($event,$fdc) = @_; 58 $fdc ||= $event->fh; 59 if ( $fdc->accept_SSL ) { 60 DEBUG( "new client ssl handshake done" ); 61 # setup the client 62 ${*$fdc}{rbuf} = ${*$fdc}{wbuf} = ''; 63 event_new( $fdc, EV_READ, \&_client_read_header )->add; 64 } elsif ( $! != EAGAIN ) { 65 die "new client failed: $!|$SSL_ERROR"; 66 } else { 67 DEBUG( "new client need to retry accept: $SSL_ERROR" ); 68 my $what = 69 $SSL_ERROR == SSL_WANT_READ ? EV_READ : 70 $SSL_ERROR == SSL_WANT_WRITE ? EV_WRITE : 71 die "unknown error"; 72 event_new( $fdc, $what, \&_ssl_accept )->add; 73 } 74} 75 76 77########################################################## 78### read http header 79### this will re-add itself as an event until the full 80### http header was read 81### after reading the header it will setup the response 82### which will for now just send the header back as text/plain 83########################################################## 84sub _client_read_header { 85 my $event = shift; 86 my $fdc = $event->fh; 87 DEBUG( "reading header" ); 88 my $rbuf_ref = \${*$fdc}{rbuf}; 89 my $n = sysread( $fdc,$$rbuf_ref,8192,length($$rbuf_ref)); 90 if ( !defined($n)) { 91 die $! if $! != EAGAIN; 92 DEBUG( $SSL_ERROR ); 93 if ( $SSL_ERROR == SSL_WANT_WRITE ) { 94 # retry read once I can write 95 event_new( $fdc, EV_WRITE, \&_client_read_header )->add; 96 } else { 97 $event->add; # retry 98 } 99 } elsif ( $n == 0 ) { 100 DEBUG( "connection closed" ); 101 close($fdc); 102 } else { 103 # check if we have the whole http header 104 my $i = index( $$rbuf_ref,"\r\n\r\n" ); # check \r\n\r\n 105 $i = index( $$rbuf_ref,"\n\n" ) if $i<0; # bad clients send \n\n only 106 if ( $i<0 ) { 107 $event->add; # read more from header 108 return; 109 } 110 111 # got full header, send request back (we don't serve real pages yet) 112 my $header = substr( $$rbuf_ref,0,$i,'' ); 113 DEBUG( "got header:\n$header" ); 114 my $wbuf_ref = \${*$fdc}{wbuf}; 115 $$wbuf_ref = "HTTP/1.0 200 Ok\r\nContent-type: text/plain\r\n\r\n".$header; 116 DEBUG( "will send $$wbuf_ref" ); 117 event_new( $fdc, EV_WRITE, \&_client_write_response )->add; 118 } 119} 120 121########################################################## 122### this is called to write the response to the client 123### this will re-add itself as an event as until the full 124### response was send 125### if it's done it will just close the socket 126########################################################## 127sub _client_write_response { 128 my $event = shift; 129 DEBUG( "writing response" ); 130 my $fdc = $event->fh; 131 my $wbuf_ref = \${*$fdc}{wbuf}; 132 my $n = syswrite( $fdc,$$wbuf_ref ); 133 if ( !defined($n) && $! == EAGAIN) { 134 # retry 135 DEBUG( $SSL_ERROR ); 136 if ( $SSL_ERROR == SSL_WANT_READ ) { 137 # retry write once we can read 138 event_new( $fdc, EV_READ, \&_client_write_response )->add; 139 } else { 140 $event->add; # retry again 141 } 142 } elsif ( $n == 0 ) { 143 DEBUG( "connection closed: $!" ); 144 close($fdc); 145 } else { 146 DEBUG( "wrote $n bytes" ); 147 substr($$wbuf_ref,0,$n,'' ); 148 if ($$wbuf_ref eq '') { 149 DEBUG( "done" ); 150 close($fdc); 151 } else { 152 # send more 153 $event->add 154 } 155 } 156} 157 158