1use strict; 2use warnings; 3 4package HTTP::Server::Simple; 5use FileHandle; 6use Socket; 7use Carp; 8 9use vars qw($VERSION $bad_request_doc); 10$VERSION = '0.52'; 11 12=head1 NAME 13 14HTTP::Server::Simple - Lightweight HTTP server 15 16=head1 SYNOPSIS 17 18 use warnings; 19 use strict; 20 21 use HTTP::Server::Simple; 22 23 my $server = HTTP::Server::Simple->new(); 24 $server->run(); 25 26However, normally you will sub-class the HTTP::Server::Simple::CGI 27module (see L<HTTP::Server::Simple::CGI>); 28 29 package Your::Web::Server; 30 use base qw(HTTP::Server::Simple::CGI); 31 32 sub handle_request { 33 my ($self, $cgi) = @_; 34 35 #... do something, print output to default 36 # selected filehandle... 37 38 } 39 40 1; 41 42=head1 DESCRIPTION 43 44This is a simple standalone HTTP server. By default, it doesn't thread 45or fork. It does, however, act as a simple frontend which can be used 46to build a standalone web-based application or turn a CGI into one. 47 48It is possible to use L<Net::Server> classes to create forking, 49pre-forking, and other types of more complicated servers; see 50L</net_server>. 51 52By default, the server traps a few signals: 53 54=over 55 56=item HUP 57 58When you C<kill -HUP> the server, it lets the current request finish being 59processed, then uses the C<restart> method to re-exec itself. Please note that 60in order to provide restart-on-SIGHUP, HTTP::Server::Simple sets a SIGHUP 61handler during initialisation. If your request handling code forks you need to 62make sure you reset this or unexpected things will happen if somebody sends a 63HUP to all running processes spawned by your app (e.g. by "kill -HUP <script>") 64 65=item PIPE 66 67If the server detects a broken pipe while writing output to the client, 68it ignores the signal. Otherwise, a client closing the connection early 69could kill the server. 70 71=back 72 73=head1 EXAMPLE 74 75 #!/usr/bin/perl 76 { 77 package MyWebServer; 78 79 use HTTP::Server::Simple::CGI; 80 use base qw(HTTP::Server::Simple::CGI); 81 82 my %dispatch = ( 83 '/hello' => \&resp_hello, 84 # ... 85 ); 86 87 sub handle_request { 88 my $self = shift; 89 my $cgi = shift; 90 91 my $path = $cgi->path_info(); 92 my $handler = $dispatch{$path}; 93 94 if (ref($handler) eq "CODE") { 95 print "HTTP/1.0 200 OK\r\n"; 96 $handler->($cgi); 97 98 } else { 99 print "HTTP/1.0 404 Not found\r\n"; 100 print $cgi->header, 101 $cgi->start_html('Not found'), 102 $cgi->h1('Not found'), 103 $cgi->end_html; 104 } 105 } 106 107 sub resp_hello { 108 my $cgi = shift; # CGI.pm object 109 return if !ref $cgi; 110 111 my $who = $cgi->param('name'); 112 113 print $cgi->header, 114 $cgi->start_html("Hello"), 115 $cgi->h1("Hello $who!"), 116 $cgi->end_html; 117 } 118 119 } 120 121 # start the server on port 8080 122 my $pid = MyWebServer->new(8080)->background(); 123 print "Use 'kill $pid' to stop server.\n"; 124 125=head1 METHODS 126 127=head2 HTTP::Server::Simple->new($port, $family) 128 129API call to start a new server. Does not actually start listening 130until you call C<-E<gt>run()>. If omitted, C<$port> defaults to 8080, 131and C<$family> defaults to L<Socket::AF_INET>. 132The alternative domain is L<Socket::AF_INET6>. 133 134=cut 135 136sub new { 137 my ( $proto, $port, $family ) = @_; 138 my $class = ref($proto) || $proto; 139 140 if ( $class eq __PACKAGE__ ) { 141 require HTTP::Server::Simple::CGI; 142 return HTTP::Server::Simple::CGI->new( @_[ 1 .. $#_ ] ); 143 } 144 145 my $self = {}; 146 bless( $self, $class ); 147 $self->port( $port || '8080' ); 148 $self->family( $family || AF_INET ); 149 150 return $self; 151} 152 153 154=head2 lookup_localhost 155 156Looks up the local host's IP address, and returns it. For most hosts, 157this is C<127.0.0.1>, or possibly C<::1>. 158 159=cut 160 161sub lookup_localhost { 162 my $self = shift; 163 164 my $local_sockaddr = getsockname( $self->stdio_handle ); 165 my $local_family = sockaddr_family($local_sockaddr); 166 167 my ($host_err,$local_host, undef) = Socket::getnameinfo($local_sockaddr,0); 168 warn $host_err if ($host_err); 169 $self->host( $local_host || "localhost"); 170 171 my ($addr_err,$local_addr,undef) = Socket::getnameinfo($local_sockaddr,Socket::NI_NUMERICHOST); 172 warn $addr_err if ($addr_err); 173 $self->{'local_addr'} = $local_addr 174 || (($local_family == AF_INET6) ? "::1" : "127.0.0.1"); 175} 176 177 178=head2 port [NUMBER] 179 180Takes an optional port number for this server to listen on. 181 182Returns this server's port. (Defaults to 8080) 183 184=cut 185 186sub port { 187 my $self = shift; 188 $self->{'port'} = shift if (@_); 189 return ( $self->{'port'} ); 190 191} 192 193=head2 family [NUMBER] 194 195Takes an optional address family for this server to use. Valid values 196are Socket::AF_INET and Socket::AF_INET6. All other values are silently 197changed into Socket::AF_INET for backwards compatibility with previous 198versions of the module. 199 200Returns the address family of the present listening socket. (Defaults to 201Socket::AF_INET.) 202 203=cut 204 205sub family { 206 my $self = shift; 207 if (@_) { 208 if ($_[0] == AF_INET || $_[0] == AF_INET6) { 209 $self->{'family'} = shift; 210 } else { 211 $self->{'family'} = AF_INET; 212 } 213 } 214 return ( $self->{'family'} ); 215 216} 217 218=head2 host [address] 219 220Takes an optional host address for this server to bind to. 221 222Returns this server's bound address (if any). Defaults to C<undef> 223(bind to all interfaces). 224 225=cut 226 227sub host { 228 my $self = shift; 229 $self->{'host'} = shift if (@_); 230 return ( $self->{'host'} ); 231 232} 233 234=head2 background [ARGUMENTS] 235 236Runs the server in the background, and returns the process ID of the 237started process. Any arguments will be passed through to L</run>. 238 239=cut 240 241sub background { 242 my $self = shift; 243 my $child = fork; 244 croak "Can't fork: $!" unless defined($child); 245 return $child if $child; 246 247 srand(); # after a fork, we need to reset the random seed 248 # or we'll get the same numbers in both branches 249 if ( $^O !~ /MSWin32/ ) { 250 require POSIX; 251 POSIX::setsid() 252 or croak "Can't start a new session: $!"; 253 } 254 $self->run(@_); # should never return 255 exit; # just to be sure 256} 257 258=head2 run [ARGUMENTS] 259 260Run the server. If all goes well, this won't ever return, but it will 261start listening for C<HTTP> requests. Any arguments passed to this 262will be passed on to the underlying L<Net::Server> implementation, if 263one is used (see L</net_server>). 264 265=cut 266 267my $server_class_id = 0; 268 269use vars '$SERVER_SHOULD_RUN'; 270$SERVER_SHOULD_RUN = 1; 271 272sub run { 273 my $self = shift; 274 my $server = $self->net_server; 275 276 local $SIG{CHLD} = 'IGNORE'; # reap child processes 277 278 # $pkg is generated anew for each invocation to "run" 279 # Just so we can use different net_server() implementations 280 # in different runs. 281 my $pkg = join '::', ref($self), "NetServer" . $server_class_id++; 282 283 no strict 'refs'; 284 *{"$pkg\::process_request"} = $self->_process_request; 285 286 if ($server) { 287 require join( '/', split /::/, $server ) . '.pm'; 288 *{"$pkg\::ISA"} = [$server]; 289 290 # clear the environment before every request 291 require HTTP::Server::Simple::CGI; 292 *{"$pkg\::post_accept"} = sub { 293 HTTP::Server::Simple::CGI::Environment->setup_environment; 294 # $self->SUPER::post_accept uses the wrong super package 295 $server->can('post_accept')->(@_); 296 }; 297 } 298 else { 299 $self->setup_listener; 300 $self->after_setup_listener(); 301 *{"$pkg\::run"} = $self->_default_run; 302 } 303 304 local $SIG{HUP} = sub { $SERVER_SHOULD_RUN = 0; }; 305 306 $pkg->run( port => $self->port, @_ ); 307} 308 309=head2 net_server 310 311User-overridable method. If you set it to a L<Net::Server> subclass, 312that subclass is used for the C<run> method. Otherwise, a minimal 313implementation is used as default. 314 315=cut 316 317sub net_server {undef} 318 319sub _default_run { 320 my $self = shift; 321 322 # Default "run" closure method for a stub, minimal Net::Server instance. 323 return sub { 324 my $pkg = shift; 325 326 $self->print_banner; 327 328 while ($SERVER_SHOULD_RUN) { 329 local $SIG{PIPE} = 'IGNORE'; # If we don't ignore SIGPIPE, a 330 # client closing the connection before we 331 # finish sending will cause the server to exit 332 while ( accept( my $remote = new FileHandle, HTTPDaemon ) ) { 333 $self->stdio_handle($remote); 334 $self->lookup_localhost() unless ($self->host); 335 $self->accept_hook if $self->can("accept_hook"); 336 337 338 *STDIN = $self->stdin_handle(); 339 *STDOUT = $self->stdout_handle(); 340 select STDOUT; # required for HTTP::Server::Simple::Recorder 341 # XXX TODO glasser: why? 342 $pkg->process_request; 343 close $remote; 344 } 345 } 346 347 # Got here? Time to restart, due to SIGHUP 348 $self->restart; 349 }; 350} 351 352=head2 restart 353 354Restarts the server. Usually called by a HUP signal, not directly. 355 356=cut 357 358sub restart { 359 my $self = shift; 360 361 close HTTPDaemon; 362 363 $SIG{CHLD} = 'DEFAULT'; 364 wait; 365 366 ### if the standalone server was invoked with perl -I .. we will loose 367 ### those include dirs upon re-exec. So add them to PERL5LIB, so they 368 ### are available again for the exec'ed process --kane 369 use Config; 370 $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; 371 372 # Server simple 373 # do the exec. if $0 is not executable, try running it with $^X. 374 exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @ARGV ); 375} 376 377 378sub _process_request { 379 my $self = shift; 380 381 # Create a callback closure that is invoked for each incoming request; 382 # the $self above is bound into the closure. 383 sub { 384 385 $self->stdio_handle(*STDIN) unless $self->stdio_handle; 386 387 # Default to unencoded, raw data out. 388 # if you're sending utf8 and latin1 data mixed, you may need to override this 389 binmode STDIN, ':raw'; 390 binmode STDOUT, ':raw'; 391 392 # The ternary operator below is to protect against a crash caused by IE 393 # Ported from Catalyst::Engine::HTTP (Originally by Jasper Krogh and Peter Edwards) 394 # ( http://dev.catalyst.perl.org/changeset/5195, 5221 ) 395 396 my $remote_sockaddr = getpeername( $self->stdio_handle ); 397 my $family = sockaddr_family($remote_sockaddr); 398 399 my ( $iport, $iaddr ) = $remote_sockaddr 400 ? ( ($family == AF_INET6) ? sockaddr_in6($remote_sockaddr) 401 : sockaddr_in($remote_sockaddr) ) 402 : (undef,undef); 403 404 my $loopback = ($family == AF_INET6) ? "::1" : "127.0.0.1"; 405 my $peeraddr = $loopback; 406 if ($iaddr) { 407 my ($host_err,$addr, undef) = Socket::getnameinfo($remote_sockaddr,Socket::NI_NUMERICHOST); 408 warn ($host_err) if $host_err; 409 $peeraddr = $addr || $loopback; 410 } 411 412 413 my ( $method, $request_uri, $proto ) = $self->parse_request; 414 415 unless ($self->valid_http_method($method) ) { 416 $self->bad_request; 417 return; 418 } 419 420 $proto ||= "HTTP/0.9"; 421 422 my ( $file, $query_string ) 423 = ( $request_uri =~ /([^?]*)(?:\?(.*))?/s ); # split at ? 424 425 $self->setup( 426 method => $method, 427 protocol => $proto, 428 query_string => ( defined($query_string) ? $query_string : '' ), 429 request_uri => $request_uri, 430 path => $file, 431 localname => $self->host, 432 localport => $self->port, 433 peername => $peeraddr, 434 peeraddr => $peeraddr, 435 peerport => $iport, 436 ); 437 438 # HTTP/0.9 didn't have any headers (I think) 439 if ( $proto =~ m{HTTP/(\d(\.\d)?)$} and $1 >= 1 ) { 440 441 my $headers = $self->parse_headers 442 or do { $self->bad_request; return }; 443 444 $self->headers($headers); 445 446 } 447 448 $self->post_setup_hook if $self->can("post_setup_hook"); 449 450 $self->handler; 451 } 452} 453 454=head2 stdio_handle [FILEHANDLE] 455 456When called with an argument, sets the socket to the server to that arg. 457 458Returns the socket to the server; you should only use this for actual socket-related 459calls like C<getsockname>. If all you want is to read or write to the socket, 460you should use C<stdin_handle> and C<stdout_handle> to get the in and out filehandles 461explicitly. 462 463=cut 464 465sub stdio_handle { 466 my $self = shift; 467 $self->{'_stdio_handle'} = shift if (@_); 468 return $self->{'_stdio_handle'}; 469} 470 471=head2 stdin_handle 472 473Returns a filehandle used for input from the client. By default, 474returns whatever was set with C<stdio_handle>, but a subclass could do 475something interesting here. 476 477=cut 478 479sub stdin_handle { 480 my $self = shift; 481 return $self->stdio_handle; 482} 483 484=head2 stdout_handle 485 486Returns a filehandle used for output to the client. By default, 487returns whatever was set with C<stdio_handle>, but a subclass 488could do something interesting here. 489 490=cut 491 492sub stdout_handle { 493 my $self = shift; 494 return $self->stdio_handle; 495} 496 497=head1 IMPORTANT SUB-CLASS METHODS 498 499A selection of these methods should be provided by sub-classes of this 500module. 501 502=head2 handler 503 504This method is called after setup, with no parameters. It should 505print a valid, I<full> HTTP response to the default selected 506filehandle. 507 508=cut 509 510sub handler { 511 my ($self) = @_; 512 if ( ref($self) ne __PACKAGE__ ) { 513 croak "do not call " . ref($self) . "::SUPER->handler"; 514 } 515 else { 516 croak "handler called out of context"; 517 } 518} 519 520=head2 setup(name =E<gt> $value, ...) 521 522This method is called with a name =E<gt> value list of various things 523to do with the request. This list is given below. 524 525The default setup handler simply tries to call methods with the names 526of keys of this list. 527 528 ITEM/METHOD Set to Example 529 ----------- ------------------ ------------------------ 530 method Request Method "GET", "POST", "HEAD" 531 protocol HTTP version "HTTP/1.1" 532 request_uri Complete Request URI "/foobar/baz?foo=bar" 533 path Path part of URI "/foobar/baz" 534 query_string Query String undef, "foo=bar" 535 port Received Port 80, 8080 536 peername Remote name "200.2.4.5", "foo.com" 537 peeraddr Remote address "200.2.4.5", "::1" 538 peerport Remote port 42424 539 localname Local interface "localhost", "myhost.com" 540 541=cut 542 543sub setup { 544 my $self = shift; 545 while ( my ( $item, $value ) = splice @_, 0, 2 ) { 546 $self->$item($value) if $self->can($item); 547 } 548} 549 550=head2 headers([Header =E<gt> $value, ...]) 551 552Receives HTTP headers and does something useful with them. This is 553called by the default C<setup()> method. 554 555You have lots of options when it comes to how you receive headers. 556 557You can, if you really want, define C<parse_headers()> and parse them 558raw yourself. 559 560Secondly, you can intercept them very slightly cooked via the 561C<setup()> method, above. 562 563Thirdly, you can leave the C<setup()> header as-is (or calling the 564superclass C<setup()> for unknown request items). Then you can define 565C<headers()> in your sub-class and receive them all at once. 566 567Finally, you can define handlers to receive individual HTTP headers. 568This can be useful for very simple SOAP servers (to name a 569crack-fueled standard that defines its own special HTTP headers). 570 571To do so, you'll want to define the C<header()> method in your subclass. 572That method will be handed a (key,value) pair of the header name and the value. 573 574 575=cut 576 577sub headers { 578 my $self = shift; 579 my $headers = shift; 580 581 my $can_header = $self->can("header"); 582 return unless $can_header; 583 while ( my ( $header, $value ) = splice @$headers, 0, 2 ) { 584 $self->header( $header => $value ); 585 } 586} 587 588=head2 accept_hook 589 590If defined by a sub-class, this method is called directly after an 591accept happens. An accept_hook to add SSL support might look like this: 592 593 sub accept_hook { 594 my $self = shift; 595 my $fh = $self->stdio_handle; 596 597 $self->SUPER::accept_hook(@_); 598 599 my $newfh = 600 IO::Socket::SSL->start_SSL( $fh, 601 SSL_server => 1, 602 SSL_use_cert => 1, 603 SSL_cert_file => 'myserver.crt', 604 SSL_key_file => 'myserver.key', 605 ) 606 or warn "problem setting up SSL socket: " . IO::Socket::SSL::errstr(); 607 608 $self->stdio_handle($newfh) if $newfh; 609 } 610 611=head2 post_setup_hook 612 613If defined by a sub-class, this method is called after all setup has 614finished, before the handler method. 615 616=head2 print_banner 617 618This routine prints a banner before the server request-handling loop 619starts. 620 621Methods below this point are probably not terribly useful to define 622yourself in subclasses. 623 624=cut 625 626sub print_banner { 627 my $self = shift; 628 629 print( ref($self) 630 . ": You can connect to your server at " 631 . "http://localhost:" 632 . $self->port 633 . "/\n" ); 634 635} 636 637=head2 parse_request 638 639Parse the HTTP request line. Returns three values, the request 640method, request URI and the protocol. 641 642=cut 643 644sub parse_request { 645 my $self = shift; 646 my $chunk; 647 while ( sysread( STDIN, my $buff, 1 ) ) { 648 last if $buff eq "\n"; 649 $chunk .= $buff; 650 } 651 defined($chunk) or return undef; 652 $_ = $chunk; 653 654 m/^(\w+)\s+(\S+)(?:\s+(\S+))?\r?$/; 655 my $method = $1 || ''; 656 my $uri = $2 || ''; 657 my $protocol = $3 || ''; 658 659 # strip <scheme>://<host:port> out of HTTP/1.1 requests 660 $uri =~ s{^\w+://[^/]+/}{/}; 661 662 return ( $method, $uri, $protocol ); 663} 664 665=head2 parse_headers 666 667Parses incoming HTTP headers from STDIN, and returns an arrayref of 668C<(header =E<gt> value)> pairs. See L</headers> for possibilities on 669how to inspect headers. 670 671=cut 672 673sub parse_headers { 674 my $self = shift; 675 676 my @headers; 677 678 my $chunk = ''; 679 while ( sysread( STDIN, my $buff, 1 ) ) { 680 if ( $buff eq "\n" ) { 681 $chunk =~ s/[\r\l\n\s]+$//; 682 if ( $chunk =~ /^([^()<>\@,;:\\"\/\[\]?={} \t]+):\s*(.*)/i ) { 683 push @headers, $1 => $2; 684 } 685 last if ( $chunk =~ /^$/ ); 686 $chunk = ''; 687 } 688 else { $chunk .= $buff } 689 } 690 691 return ( \@headers ); 692} 693 694=head2 setup_listener 695 696This routine binds the server to a port and interface. 697 698=cut 699 700sub setup_listener { 701 my $self = shift; 702 703 my $tcp = getprotobyname('tcp'); 704 my $sockaddr; 705 socket( HTTPDaemon, $self->{'family'}, SOCK_STREAM, $tcp ) 706 or croak "socket: $!"; 707 setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) ) 708 or warn "setsockopt: $!"; 709 710 if ($self->host) { # Explicit listening address 711 my ($err, @res) = Socket::getaddrinfo($self->host, $self->port, { family => $self->{'family'}, socktype => SOCK_STREAM } ); 712 warn "$err!" 713 if ($err); 714 # we're binding only to the first returned address in the requested family. 715 while ($a = shift(@res)) { 716 # Be certain on the address family. 717 # TODO Accept AF_UNSPEC, reject SITE-LOCAL 718 next unless ($self->{'family'} == $a->{'family'}); 719 720 # Use the first plausible address. 721 $sockaddr = $a->{'addr'}; 722 last; 723 } 724 } 725 else { # Use the wildcard address 726 $sockaddr = ($self->{'family'} == AF_INET6) 727 ? sockaddr_in6($self->port(), Socket::IN6ADDR_ANY) 728 : sockaddr_in($self->port(), INADDR_ANY); 729 } 730 731 bind( HTTPDaemon, $sockaddr) 732 or croak "bind to @{[$self->host||'*']}:@{[$self->port]}: $!"; 733 listen( HTTPDaemon, SOMAXCONN ) or croak "listen: $!"; 734} 735 736 737=head2 after_setup_listener 738 739This method is called immediately after setup_listener. It's here just 740for you to override. 741 742=cut 743 744sub after_setup_listener { 745} 746 747=head2 bad_request 748 749This method should print a valid HTTP response that says that the 750request was invalid. 751 752=cut 753 754$bad_request_doc = join "", <DATA>; 755 756sub bad_request { 757 my $self = shift; 758 759 print "HTTP/1.0 400 Bad request\r\n"; # probably OK by now 760 print "Content-Type: text/html\r\nContent-Length: ", 761 length($bad_request_doc), "\r\n\r\n", $bad_request_doc; 762} 763 764=head2 valid_http_method($method) 765 766Given a candidate HTTP method in $method, determine if it is valid. 767Override if, for example, you'd like to do some WebDAV. The default 768implementation only accepts C<GET>, C<POST>, C<HEAD>, C<PUT>, C<PATCH>, 769C<DELETE> and C<OPTIONS>. 770 771=cut 772 773sub valid_http_method { 774 my $self = shift; 775 my $method = shift or return 0; 776 return $method =~ /^(?:GET|POST|HEAD|PUT|PATCH|DELETE|OPTIONS)$/; 777} 778 779=head1 AUTHOR 780 781Best Practical Solutions, LLC E<lt>modules@bestpractical.comE<gt> 782 783=head1 CONTRIBUTORS 784 785Jesse Vincent, <jesse@bestpractical.com>. Original author. 786 787Marcus Ramberg <drave@thefeed.no> contributed tests, cleanup, etc 788 789Sam Vilain, <samv@cpan.org> contributed the CGI.pm split-out and 790header/setup API. 791 792Example section by almut on perlmonks, suggested by Mark Fuller. 793 794=head1 BUGS 795 796There certainly are some. Please report them via rt.cpan.org 797 798=head1 LICENSE 799 800This software is Copyright (c) 2004-2015 Best Practical Solutions 801 802This library is free software; you can redistribute it and/or modify 803it under the same terms as Perl itself. 804 805=cut 806 8071; 808 809__DATA__ 810<html> 811 <head> 812 <title>Bad Request</title> 813 </head> 814 <body> 815 <h1>Bad Request</h1> 816 817 <p>Your browser sent a request which this web server could not 818 grok.</p> 819 </body> 820</html> 821