1package FusionInventory::Test::Server; 2 3use warnings; 4use strict; 5use parent qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::Authen); 6 7use English qw(-no_match_vars); 8use IO::Socket::SSL; 9 10use FusionInventory::Test::Auth; 11 12my $dispatch_table = {}; 13 14=head1 OVERLOADED METHODS 15 16=cut 17 18our $pid; 19 20sub new { 21 die 'An instance of Test::Server has already been started.' if $pid; 22 23 my $class = shift; 24 my %params = ( 25 port => 8080, 26 ssl => 0, 27 crt => undef, 28 key => undef, 29 @_ 30 ); 31 32 my $self = $class->SUPER::new($params{port}); 33 34 $self->{user} = $params{user}; 35 $self->{password} = $params{password}; 36 $self->{ssl} = $params{ssl}; 37 $self->{crt} = $params{crt}; 38 $self->{key} = $params{key}; 39 40 $self->host('127.0.0.1'); 41 42 return $self; 43} 44 45# Fixed and very simplified run method refactored from HTTP::Server::Simple run & _default_run methods 46sub run { 47 my $self = shift; 48 49 local $SIG{CHLD} = 'IGNORE'; # reap child processes 50 51 $self->setup_listener; 52 $self->after_setup_listener(); 53 54 local $SIG{PIPE} = 'IGNORE'; # If we don't ignore SIGPIPE, a 55 # client closing the connection before we 56 # finish sending will cause the server to exit 57 58 while ( accept( my $remote = new FileHandle, HTTP::Server::Simple::HTTPDaemon ) ) { 59 $self->stdio_handle($remote); 60 61 # This is the point, we must not continue processing the request if SSL failed !!! 62 if ($self->accept_hook || !$self->{ssl}) { 63 *STDIN = $self->stdin_handle(); 64 *STDOUT = $self->stdout_handle(); 65 select STDOUT; 66 &{$self->_process_request}; 67 } 68 close $self->stdio_handle; 69 } 70} 71 72sub authen_handler { 73 my ($self) = @_; 74 return FusionInventory::Test::Auth->new( 75 user => $self->{user}, 76 password => $self->{password} 77 ); 78} 79 80sub handle_request { 81 my $self = shift; 82 my $cgi = shift; 83 84 my $path = $cgi->path_info(); 85 my $handler = $dispatch_table->{$path}; 86 87 if ($handler) { 88 if (ref($handler) eq "CODE") { 89 $handler->($self, $cgi); 90 } else { 91 print "HTTP/1.0 200 OK\r\n"; 92 print "\r\n"; 93 print $handler; 94 } 95 } else { 96 print "HTTP/1.0 404 Not found\r\n"; 97 print 98 $cgi->header(), 99 $cgi->start_html('Not found'), 100 $cgi->h1('Not found'), 101 $cgi->end_html(); 102 } 103 104 # fix for strange bug under Test::Harness 105 # where HTTP::Server::Simple::CGI::Environment::header 106 # keep appending value to this variable 107 delete $ENV{CONTENT_LENGTH}; 108} 109 110# overriden to add status to return code in the headers 111sub authenticate { 112 my $self = shift; 113 my $user = $self->do_authenticate(); 114 unless (defined $user) { 115 my $realm = $self->authen_realm(); 116 print "HTTP/1.0 401 Authentication required\r\n"; 117 print qq(WWW-Authenticate: Basic realm="$realm"\r\n\r\n); 118 print "Authentication required."; 119 return; 120 } 121 return $user; 122} 123 124sub print_banner { 125} 126 127sub accept_hook { 128 my $self = shift; 129 130 return unless $self->{ssl}; 131 my $fh = $self->stdio_handle; 132 133 $self->SUPER::accept_hook(@_); 134 135 my $newfh = IO::Socket::SSL->start_SSL($fh, 136 SSL_server => 1, 137 SSL_use_cert => 1, 138 SSL_cert_file => $self->{crt}, 139 SSL_key_file => $self->{key}, 140 ); 141 142 $self->stdio_handle($newfh) if $newfh; 143} 144 145=head1 METHODS UNIQUE TO TestServer 146 147=cut 148 149sub set_dispatch { 150 my $self = shift; 151 $dispatch_table = shift; 152 153 return; 154} 155 156sub background { 157 my $self = shift; 158 159 $pid = $self->SUPER::background() 160 or Carp::confess( q{Can't start the test server} ); 161 162 sleep 1; # background() may come back prematurely, so give it a second to fire up 163 164 return $pid; 165} 166 167sub root { 168 my $self = shift; 169 my $port = $self->port; 170 my $hostname = $self->host; 171 172 return "http://$hostname:$port"; 173} 174 175sub stop { 176 my $signal = ($OSNAME eq 'MSWin32') ? 9 : 15; 177 if ($pid) { 178 kill($signal, $pid) unless $EXCEPTIONS_BEING_CAUGHT; 179 waitpid($pid, 0); 180 undef $pid; 181 } 182 183 return; 184} 185 1861; 187