git.maemo.org Git - dh-make-perl/blob - dev/i386/libio-socket-ssl-perl/libio-socket-ssl-perl-1.16/example/async_https_server.pl

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