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