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