1use strict;
2use warnings;
3
4use Bio::Das::Lite;
5use Test::More;
6use English qw(-no_match_vars);
7
8BEGIN {
9  eval {
10    require POE;
11    require WWW::Curl::Simple;
12    POE->import(qw(Component::Server::TCP Filter::HTTPD));
13    require HTTP::Response;
14  };
15
16  if ($EVAL_ERROR) {
17    plan skip_all => 'Proxy testing requires POE and WWW::Curl::Simple';
18  } else {
19    plan tests => 11;
20  }
21}
22
23# We will only communicate with the local host on the loopback interface, we don't want interference from a proxy!
24delete $ENV{http_proxy};
25
26my ($child_pid, $port) = &setup_server;
27if ($child_pid && $port) {
28  pass("run test proxy server");
29
30  my $dsn = 'http://www.ensembl.org/das/Homo_sapiens.GRCh37.reference';
31
32  $ENV{http_proxy} = undef if $ENV{http_proxy};
33
34  my $dl = Bio::Das::Lite->new($dsn);
35  $dl->features('1:1,2');
36  my $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
37  unlike($status, qr/PROXY/smx, 'direct connection');
38
39  SKIP: {
40
41    if (! defined $Bio::Das::Lite::{CURLOPT_NOPROXY} ) {
42      skip 'proxy support DISABLED as unsupported by your version of libcurl', 9;
43    }
44
45    $dl = Bio::Das::Lite->new({dsn => $dsn, http_proxy => "http://127.0.0.1:$port"});
46    $dl->features('1:1,2');
47    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
48    is($status, '200 (OK) PROXY', 'basic proxy (constructor)');
49
50    $dl = Bio::Das::Lite->new($dsn);
51    $dl->http_proxy("http://127.0.0.1:$port");
52    $dl->features('1:1,2');
53    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
54    is($status, '200 (OK) PROXY', 'basic proxy (method)');
55
56    if (! defined $Bio::Das::Lite::{CURLOPT_PROXYUSERNAME} || !defined $Bio::Das::Lite::{CURLOPT_PROXYPASSWORD} ) {
57      skip 'authenticating proxy support DISABLED as unsupported by your version of libcurl', 1;
58    }
59
60    $dl = Bio::Das::Lite->new($dsn);
61    $dl->http_proxy("http://user:pass\@127.0.0.1:$port");
62    $dl->features('1:1,2');
63    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
64    is($status, '200 (OK) PROXY user:pass', 'authenticated proxy (method)');
65
66    $ENV{http_proxy} = "http://127.0.0.1:$port";
67    $dl = Bio::Das::Lite->new($dsn);
68    $dl->features('1:1,2');
69    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
70    is($status, '200 (OK) PROXY', 'basic proxy (environment)');
71
72    if (! defined $Bio::Das::Lite::{CURLOPT_NOPROXY} ) {
73      skip 'no_proxy support DISABLED as unsupported by your version of libcurl', 5;
74    }
75
76    $dl = Bio::Das::Lite->new({dsn=>$dsn,no_proxy=>'ensembl.org'});
77    $dl->features('1:1,2');
78    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
79    unlike($status, qr/PROXY/smx, 'no-proxy (constructor) positive match');
80
81    $dl = Bio::Das::Lite->new($dsn);
82    $dl->no_proxy('ensembl.org', 'another.com');
83    $dl->features('1:1,2');
84    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
85    unlike($status, qr/PROXY/smx, 'no-proxy (method list) positive match');
86
87    $dl = Bio::Das::Lite->new($dsn);
88    $dl->no_proxy('wibble.com', 'another.com');
89    $dl->features('1:1,2');
90    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
91    is($status, '200 (OK) PROXY', 'no-proxy (method list) negative match');
92
93    $dl = Bio::Das::Lite->new($dsn);
94    $dl->no_proxy(['ensembl.org', 'another.com']);
95    $dl->features('1:1,2');
96    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
97    unlike($status, qr/PROXY/smx, 'no-proxy (method listref) positive match');
98
99    $ENV{no_proxy} = 'ensembl.org, another.com';
100    $dl = Bio::Das::Lite->new($dsn);
101    $dl->features('1:1,2');
102    $status = $dl->statuscodes("$dsn/features?segment=1:1,2");
103    unlike($status, qr/PROXY/smx, 'no-proxy (environment) positive match');
104  };
105
106} else {
107  fail("run test proxy server");
108}
109
110kill_child();
111
112sub kill_child {
113  $child_pid && kill 9, $child_pid;
114}
115
116$SIG{INT} = \&kill_child;
117
118sub setup_server {
119  # Set up a server and check it is listening.
120  my $port;
121  my $child_pid;
122  my $agent = WWW::Curl::Simple->new(timeout=>1);
123
124  for my $test_port (10000 .. 10010) {
125    $child_pid = fork_server($test_port);
126    my $resp;
127    eval {
128      $resp = $agent->get("http://127.0.0.1:$test_port");
129    };
130
131    if ($@) {
132      warn "Error from test server on port $test_port - ".$@;
133    } elsif (!$resp) {
134      warn "No response from test server on port $test_port";
135    } elsif ($resp->status_line() =~ m/^200 \(OK\) PROXY/) {
136      $port = $test_port;
137      last;
138    } else {
139      warn "Unexpected status from test server on port $test_port - ".$resp->status_line;
140    }
141    kill 9, $child_pid; wait;
142    undef $child_pid;
143  }
144
145  return ($child_pid, $port);
146}
147
148sub fork_server {
149
150  if (my $child_pid = fork) {
151    return $child_pid;
152  }
153
154  my $listen_port = shift;
155
156  eval {
157    # Child process runs a server
158    # (similar to http://poe.perl.org/?POE_Cookbook/Web_Server)
159    POE::Component::Server::TCP->new(
160      Port         => $listen_port,
161      ClientFilter => 'POE::Filter::HTTPD',
162      ClientInput  => sub {
163        my ($kernel, $heap, $req_or_resp) = @_[KERNEL, HEAP, ARG0];
164        # Errors appear as HTTP::Response objects (via filter)
165        if ($req_or_resp->isa(q[HTTP::Request])) {
166          my $auth = $req_or_resp->proxy_authorization_basic;
167          $req_or_resp = HTTP::Response->new(200, $auth ? 'PROXY ' . $auth : 'PROXY'); # OK
168          $req_or_resp->content('FAKE CONTENT');
169        }
170        $heap->{client}->put($req_or_resp);
171        $kernel->yield(q[shutdown]);
172      }
173    );
174
175    $poe_kernel->run();
176  };
177}
178