~ubuntu-branches/ubuntu/saucy/bugzilla/saucy

« back to all changes in this revision

Viewing changes to testserver.pl

  • Committer: Bazaar Package Importer
  • Author(s): Alexis Sukrieh
  • Date: 2006-11-15 07:54:08 UTC
  • mfrom: (3.1.4 feisty)
  • Revision ID: james.westby@ubuntu.com-20061115075408-wlbl33r80yh9q3uo
Tags: 2.22.1-2
* Depends on mysql-client as we provide mysql support with dbconfig-common.
  (closes: #398621)
* Urgency set to high to fix the etch RC bug.
* Updated the Bugzilla version (debian minor) in Bugzilla/Config.pm.

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
#!/usr/bin/perl -w
 
2
# -*- Mode: perl; indent-tabs-mode: nil -*-
 
3
#
 
4
# The contents of this file are subject to the Mozilla Public
 
5
# License Version 1.1 (the "License"); you may not use this file
 
6
# except in compliance with the License. You may obtain a copy of
 
7
# the License at http://www.mozilla.org/MPL/
 
8
#
 
9
# Software distributed under the License is distributed on an "AS
 
10
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 
11
# implied. See the License for the specific language governing
 
12
# rights and limitations under the License.
 
13
#
 
14
# Contributor(s): Joel Peshkin <bugreport@peshkin.net>
 
15
#                 Byron Jones <byron@glob.com.au>
 
16
 
 
17
# testserver.pl is invoked with the baseurl of the Bugzilla installation
 
18
# as its only argument.  It attempts to troubleshoot as many installation
 
19
# issues as possible.
 
20
 
 
21
use Socket;
 
22
use Bugzilla::Config qw($datadir);
 
23
my $envpath = $ENV{'PATH'};
 
24
use lib ".";
 
25
use strict;
 
26
require "globals.pl";
 
27
eval "require LWP; require LWP::UserAgent;";
 
28
my $lwp = $@ ? 0 : 1;
 
29
 
 
30
$ENV{'PATH'}= $envpath;
 
31
 
 
32
if ((@ARGV != 1) || ($ARGV[0] !~ /^https?:/))
 
33
{
 
34
    print "Usage: $0 <URL to this Bugzilla installation>\n";
 
35
    print "e.g.:  $0 http://www.mycompany.com/bugzilla\n";
 
36
    exit(1);
 
37
}
 
38
 
 
39
 
 
40
# Try to determine the GID used by the webserver.
 
41
my @pscmds = ('ps -eo comm,gid', 'ps -acxo command,gid', 'ps -acxo command,rgid');
 
42
my $sgid = 0;
 
43
if ($^O !~ /MSWin32/i) {
 
44
    foreach my $pscmd (@pscmds) {
 
45
        open PH, "$pscmd 2>/dev/null |";
 
46
        while (my $line = <PH>) {
 
47
            if ($line =~ /^(?:\S*\/)?(?:httpd|apache)2?\s+(\d+)$/) {
 
48
                $sgid = $1 if $1 > $sgid;
 
49
            }
 
50
        }
 
51
        close(PH);
 
52
    }
 
53
}
 
54
 
 
55
# Determine the numeric GID of $webservergroup
 
56
my $webgroupnum = 0;
 
57
if ($::webservergroup =~ /^(\d+)$/) {
 
58
    $webgroupnum = $1;
 
59
} else {
 
60
    eval { $webgroupnum = (getgrnam $::webservergroup) || 0; };
 
61
}
 
62
 
 
63
# Check $webservergroup against the server's GID
 
64
if ($sgid > 0) {
 
65
    if ($::webservergroup eq "") {
 
66
        print 
 
67
"WARNING \$webservergroup is set to an empty string.
 
68
That is a very insecure practice. Please refer to the
 
69
Bugzilla documentation.\n";
 
70
    } elsif ($webgroupnum == $sgid) {
 
71
        print "TEST-OK Webserver is running under group id in \$webservergroup.\n";
 
72
    } else {
 
73
        print 
 
74
"TEST-WARNING Webserver is running under group id not matching \$webservergroup.
 
75
This if the tests below fail, this is probably the problem.
 
76
Please refer to the webserver configuration section of the Bugzilla guide. 
 
77
If you are using virtual hosts or suexec, this warning may not apply.\n";
 
78
    }
 
79
} elsif ($^O !~ /MSWin32/i) {
 
80
   print
 
81
"TEST-WARNING Failed to find the GID for the 'httpd' process, unable
 
82
to validate webservergroup.\n";
 
83
}
 
84
 
 
85
 
 
86
# Try to fetch a static file (front.png)
 
87
$ARGV[0] =~ s/\/$//;
 
88
my $url = $ARGV[0] . "/skins/standard/index/front.png";
 
89
if (fetch($url)) {
 
90
    print "TEST-OK Got front picture.\n";
 
91
} else {
 
92
    print 
 
93
"TEST-FAILED Fetch of skins/standard/index/front.png failed
 
94
Your webserver could not fetch $url.
 
95
Check your webserver configuration and try again.\n";
 
96
    exit(1);
 
97
}
 
98
 
 
99
# Try to execute a cgi script
 
100
my $response = fetch($ARGV[0] . "/testagent.cgi");
 
101
if ($response =~ /^OK/) {
 
102
    print "TEST-OK Webserver is executing CGIs.\n";
 
103
} elsif ($response =~ /^#!/) {
 
104
    print 
 
105
"TEST-FAILED Webserver is fetching rather than executing CGI files.
 
106
Check the AddHandler statement in your httpd.conf file.\n";
 
107
    exit(1);
 
108
} else {
 
109
    print "TEST-FAILED Webserver is not executing CGI files.\n"; 
 
110
}
 
111
 
 
112
# Make sure that webserver is honoring .htaccess files
 
113
$::localconfig =~ s~^\./~~;
 
114
$url = $ARGV[0] . "/$::localconfig";
 
115
$response = fetch($url);
 
116
if ($response) {
 
117
    print 
 
118
"TEST-FAILED Webserver is permitting fetch of $url.
 
119
This is a serious security problem.
 
120
Check your webserver configuration.\n";
 
121
    exit(1);
 
122
} else {
 
123
    print "TEST-OK Webserver is preventing fetch of $url.\n";
 
124
}
 
125
 
 
126
# Test chart generation
 
127
eval 'use GD';
 
128
if ($@ eq '') {
 
129
    undef $/;
 
130
 
 
131
    # Ensure major versions of GD and libgd match
 
132
    # Windows's GD module include libgd.dll, guaranteed to match
 
133
    if ($^O !~ /MSWin32/i) {
 
134
        my $gdlib = `gdlib-config --version 2>&1` || "";
 
135
        $gdlib =~ s/\n$//;
 
136
        if (!$gdlib) {
 
137
            print "TEST-WARNING Failed to run gdlib-config; can't compare " .
 
138
                  "GD versions.\n";
 
139
        }
 
140
        else {
 
141
            my $gd = $GD::VERSION;
 
142
    
 
143
            my $verstring = "GD version $gd, libgd version $gdlib";
 
144
    
 
145
            $gdlib =~ s/^([^\.]+)\..*/$1/;
 
146
            $gd =~ s/^([^\.]+)\..*/$1/;
 
147
    
 
148
            if ($gdlib == $gd) {
 
149
                print "TEST-OK $verstring; Major versions match.\n";
 
150
            } else {
 
151
                print "TEST-FAILED $verstring; Major versions do not match.\n";
 
152
            }
 
153
        }
 
154
    }
 
155
 
 
156
    # Test GD
 
157
    eval {
 
158
        my $image = new GD::Image(100, 100);
 
159
        my $black = $image->colorAllocate(0, 0, 0);
 
160
        my $white = $image->colorAllocate(255, 255, 255);
 
161
        my $red = $image->colorAllocate(255, 0, 0);
 
162
        my $blue = $image->colorAllocate(0, 0, 255);
 
163
        $image->transparent($white);
 
164
        $image->rectangle(0, 0, 99, 99, $black);
 
165
        $image->arc(50, 50, 95, 75, 0, 360, $blue);
 
166
        $image->fill(50, 50, $red);
 
167
 
 
168
        if ($image->can('png')) {
 
169
            create_file("$datadir/testgd-local.png", $image->png);
 
170
            check_image("$datadir/testgd-local.png", 'GD');
 
171
        } else {
 
172
            print "TEST-FAILED GD doesn't support PNG generation.\n";
 
173
        }
 
174
    };
 
175
    if ($@ ne '') {
 
176
        print "TEST-FAILED GD returned: $@\n";
 
177
    }
 
178
 
 
179
    # Test Chart
 
180
    eval 'use Chart::Lines';
 
181
    if ($@) {
 
182
        print "TEST-FAILED Chart::Lines is not installed.\n";
 
183
    } else {
 
184
        eval {
 
185
            my $chart = Chart::Lines->new(400, 400);
 
186
 
 
187
            $chart->add_pt('foo', 30, 25);
 
188
            $chart->add_pt('bar', 16, 32);
 
189
 
 
190
            $chart->png("$datadir/testchart-local.png");
 
191
            check_image("$datadir/testchart-local.png", "Chart");
 
192
        };
 
193
        if ($@ ne '') {
 
194
            print "TEST-FAILED Chart returned: $@\n";
 
195
        }
 
196
    }
 
197
 
 
198
    eval 'use Template::Plugin::GD::Image';
 
199
    if ($@) {
 
200
        print "TEST-FAILED Template::Plugin::GD is not installed.\n";
 
201
    }
 
202
    else {
 
203
        print "TEST-OK Template::Plugin::GD is installed.\n";
 
204
    }
 
205
}
 
206
 
 
207
sub fetch {
 
208
    my $url = shift;
 
209
    my $rtn;
 
210
    if ($lwp) {
 
211
        my $req = HTTP::Request->new(GET => $url);
 
212
        my $ua = LWP::UserAgent->new;
 
213
        my $res = $ua->request($req);
 
214
        $rtn = ($res->is_success ? $res->content : undef);
 
215
    } elsif ($url =~ /^https:/i) {
 
216
        die("You need LWP installed to use https with testserver.pl");
 
217
    } else {
 
218
        my($host, $port, $file) = ('', 80, '');
 
219
        if ($url =~ m#^http://([^:]+):(\d+)(/.*)#i) {
 
220
            ($host, $port, $file) = ($1, $2, $3);
 
221
        } elsif ($url =~ m#^http://([^/]+)(/.*)#i) {
 
222
            ($host, $file) = ($1, $2);
 
223
        } else {
 
224
            die("Cannot parse url");
 
225
        }
 
226
 
 
227
        my $proto = getprotobyname('tcp');
 
228
        socket(SOCK, PF_INET, SOCK_STREAM, $proto);
 
229
        my $sin = sockaddr_in($port, inet_aton($host));
 
230
        if (connect(SOCK, $sin)) {
 
231
            binmode SOCK;
 
232
            select((select(SOCK), $| = 1)[0]);
 
233
 
 
234
            # get content
 
235
            print SOCK "GET $file HTTP/1.0\015\012host: $host:$port\015\012\015\012";
 
236
            my $header = '';
 
237
            while (defined(my $line = <SOCK>)) {
 
238
                last if $line eq "\015\012";
 
239
                $header .= $line;
 
240
            }
 
241
            my $content = '';
 
242
            while (defined(my $line = <SOCK>)) {
 
243
                $content .= $line;
 
244
            }
 
245
 
 
246
            my ($status) = $header =~ m#^HTTP/\d+\.\d+ (\d+)#;
 
247
            $rtn = (($status =~ /^2\d\d/) ? $content : undef);
 
248
        }
 
249
    }
 
250
    return($rtn);
 
251
}
 
252
 
 
253
sub check_image {
 
254
    my ($local_file, $library) = @_;
 
255
    my $filedata = read_file($local_file);
 
256
    if ($filedata =~ /^\x89\x50\x4E\x47\x0D\x0A\x1A\x0A/) {
 
257
        print "TEST-OK $library library generated a good PNG image.\n";
 
258
        unlink $local_file;
 
259
    } else {
 
260
        print "TEST-WARNING $library library did not generate a good PNG.\n";
 
261
    }
 
262
}
 
263
 
 
264
sub create_file {
 
265
    my ($filename, $content) = @_;
 
266
    open(FH, ">$filename")
 
267
        or die "Failed to create $filename: $!\n";
 
268
    binmode FH;
 
269
    print FH $content;
 
270
    close FH;
 
271
}
 
272
 
 
273
sub read_file {
 
274
    my ($filename) = @_;
 
275
    open(FH, $filename)
 
276
        or die "Failed to open $filename: $!\n";
 
277
    binmode FH;
 
278
    my $content = <FH>;
 
279
    close FH;
 
280
    return $content;
 
281
}