1package ProFTPD::Tests::HTTP;
2
3use lib qw(t/lib);
4use base qw(ProFTPD::TestSuite::Child);
5use strict;
6
7use File::Spec;
8use IO::Handle;
9
10use ProFTPD::TestSuite::FTP;
11use ProFTPD::TestSuite::Utils qw(:auth :config :running :test :testsuite);
12
13$| = 1;
14
15my $order = 0;
16
17my $TESTS = {
18  http_connect => {
19    order => ++$order,
20    test_class => [qw(bug forking)],
21  },
22
23  http_delete => {
24    order => ++$order,
25    test_class => [qw(bug forking)],
26  },
27
28  http_get => {
29    order => ++$order,
30    test_class => [qw(bug forking)],
31  },
32
33  http_head => {
34    order => ++$order,
35    test_class => [qw(bug forking)],
36  },
37
38  http_options => {
39    order => ++$order,
40    test_class => [qw(bug forking)],
41  },
42
43  http_patch => {
44    order => ++$order,
45    test_class => [qw(bug forking)],
46  },
47
48  http_post => {
49    order => ++$order,
50    test_class => [qw(bug forking)],
51  },
52
53  http_put => {
54    order => ++$order,
55    test_class => [qw(bug forking)],
56  },
57
58};
59
60sub new {
61  return shift()->SUPER::new(@_);
62}
63
64sub list_tests {
65  # Check for the required Perl modules:
66  #
67  #  HTTP-Request
68  #  LWP-UserAgent
69
70  my $required = [qw(
71    HTTP::Request
72    LWP::UserAgent
73  )];
74
75  foreach my $req (@$required) {
76    eval "use $req";
77    if ($@) {
78      print STDERR "\nWARNING:\n + Module '$req' not found, skipping all tests\n";
79
80      if ($ENV{TEST_VERBOSE}) {
81        print STDERR "Unable to load $req: $@\n";
82      }
83
84      return qw(testsuite_empty_test);
85    }
86  }
87
88  return testsuite_get_runnable_tests($TESTS);
89}
90
91sub test_http_req {
92  my $self = shift;
93  my $tmpdir = shift;
94  my $req = shift;
95
96  my $config_file = "$tmpdir/http.conf";
97  my $pid_file = File::Spec->rel2abs("$tmpdir/http.pid");
98  my $scoreboard_file = File::Spec->rel2abs("$tmpdir/http.scoreboard");
99
100  my $log_file = test_get_logfile();
101
102  my $auth_user_file = File::Spec->rel2abs("$tmpdir/http.passwd");
103  my $auth_group_file = File::Spec->rel2abs("$tmpdir/http.group");
104
105  my $user = 'proftpd';
106  my $passwd = 'test';
107  my $group = 'ftpd';
108  my $home_dir = File::Spec->rel2abs($tmpdir);
109  my $uid = 500;
110  my $gid = 500;
111
112  # Make sure that, if we're running as root, that the home directory has
113  # permissions/privs set for the account we create
114  if ($< == 0) {
115    unless (chmod(0755, $home_dir)) {
116      die("Can't set perms on $home_dir to 0755: $!");
117    }
118
119    unless (chown($uid, $gid, $home_dir)) {
120      die("Can't set owner of $home_dir to $uid/$gid: $!");
121    }
122  }
123
124  auth_user_write($auth_user_file, $user, $passwd, $uid, $gid, $home_dir,
125    '/bin/bash');
126  auth_group_write($auth_group_file, $group, $gid, $user);
127
128  my $config = {
129    PidFile => $pid_file,
130    ScoreboardFile => $scoreboard_file,
131    SystemLog => $log_file,
132
133    AuthUserFile => $auth_user_file,
134    AuthGroupFile => $auth_group_file,
135
136    IfModules => {
137      'mod_delay.c' => {
138        DelayEngine => 'off',
139      },
140    },
141  };
142
143  my ($port, $config_user, $config_group) = config_write($config_file, $config);
144
145  # Open pipes, for use between the parent and child processes.  Specifically,
146  # the child will indicate when it's done with its test by writing a message
147  # to the parent.
148  my ($rfh, $wfh);
149  unless (pipe($rfh, $wfh)) {
150    die("Can't open pipe: $!");
151  }
152
153  require LWP::UserAgent;
154  require HTTP::Request;
155
156  my $ex;
157
158  # Fork child
159  $self->handle_sigchld();
160  defined(my $pid = fork()) or die("Can't fork: $!");
161  if ($pid) {
162    eval {
163      sleep(1);
164
165      # To reproduce Bug#4143, we only need to connect to the server,
166      # then issue an HTTP request.
167
168      my $client = LWP::UserAgent->new(
169        keep_alive => 1,
170        timeout => 10,
171      );
172      $client->default_header('Host' => "127.0.0.1:$port");
173
174      my $req = HTTP::Request->new($req => "http://127.0.0.1:$port/path/to/some/file");
175      my $resp = $client->request($req);
176
177      if ($ENV{TEST_VERBOSE}) {
178        print STDERR "# response: ", $resp->as_string, "\n";
179      }
180
181      my $conn_count = $client->conn_cache->get_connections();
182
183      $self->assert($conn_count == 0,
184        test_msg("Expected connection cache count 0, got $conn_count"));
185    };
186
187    if ($@) {
188      $ex = $@;
189    }
190
191    $wfh->print("done\n");
192    $wfh->flush();
193
194  } else {
195    eval { server_wait($config_file, $rfh) };
196    if ($@) {
197      warn($@);
198      exit 1;
199    }
200
201    exit 0;
202  }
203
204  # Stop server
205  server_stop($pid_file);
206
207  $self->assert_child_ok($pid);
208
209  if ($ex) {
210    test_append_logfile($log_file, $ex);
211    unlink($log_file);
212
213    die($ex);
214  }
215
216  unlink($log_file);
217}
218
219sub http_connect {
220  my $self = shift;
221  my $tmpdir = $self->{tmpdir};
222  test_http_req($self, $tmpdir, 'CONNECT');
223}
224
225sub http_delete {
226  my $self = shift;
227  my $tmpdir = $self->{tmpdir};
228  test_http_req($self, $tmpdir, 'DELETE');
229}
230
231sub http_get {
232  my $self = shift;
233  my $tmpdir = $self->{tmpdir};
234  test_http_req($self, $tmpdir, 'GET');
235}
236
237sub http_head {
238  my $self = shift;
239  my $tmpdir = $self->{tmpdir};
240  test_http_req($self, $tmpdir, 'HEAD');
241}
242
243sub http_options {
244  my $self = shift;
245  my $tmpdir = $self->{tmpdir};
246  test_http_req($self, $tmpdir, 'OPTIONS');
247}
248
249sub http_patch {
250  my $self = shift;
251  my $tmpdir = $self->{tmpdir};
252  test_http_req($self, $tmpdir, 'PATCH');
253}
254
255sub http_post {
256  my $self = shift;
257  my $tmpdir = $self->{tmpdir};
258  test_http_req($self, $tmpdir, 'POST');
259}
260
261sub http_put {
262  my $self = shift;
263  my $tmpdir = $self->{tmpdir};
264  test_http_req($self, $tmpdir, 'PUT');
265}
266
2671;
268