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