I am using LWP to check website accessibility for HTTPS.
But, sometimes there are delays of 3000 ms
sub get_url{
my $url = shift;
my $browser = LWP::UserAgent->new;
$browser->timeout($alltimeout);
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm $alltimeout;
$response = $browser->get($url,
'User-Agent' => 'CHECKER (Win98; U)',
'Accept-Charset' => 'utf-8',
);
alarm 0;
};
if ($#) {print "$#"; return "Timeout $alltimeout - error!"}
if ($response->is_success){$resp[0]=200; return $response->content;}
else {return "ERROR".$response->status_line}
}
i want to check separately: DNS resolving time, ssl connect time, etc for HTTPS.
LWP, and many other modules you'll use, aren't instrumented to produce this sort of tracing, and certainly not in any coherent or consistent fashion. You'd have to delve into the individual modules to provide your own hooks for this.
Do you see the same delays with other browsers, such as curl or wget?
Related
I'm running a little Perl Webservice, based on the example i found on this page : https://www.perlmonks.org/?node_id=1078567 (first example)
However, when a lot of clients are calling it at once, it looks like the requests are suddenly crashing, and there's a lot of TIME_WAIT tcp connections left on the server running the webservice, as if the webservice was not able to handle that many connections at once.
is there a parameter in that module or other that i could use to extend this ?
or a way to put some kind of queue for the incoming requests ?
some parts of my code, to help :
{
package TACWebService;
use HTTP::Server::Simple::CGI;
use base qw(HTTP::Server::Simple::CGI);
use Cwd 'abs_path';
use POSIX;
use DBI;
use warnings;
.........
my %dispatch = (
'/insertunix' => \&resp_insertunix,
'/insertwin' => \&resp_insertwin,
'/getpwdate' => \&resp_getpwdate,
);
# ---------------------------------------------------------------------
# Requests Handling
# ---------------------------------------------------------------------
sub handle_request {
my $self = shift;
my $cgi = shift;
my $path = $cgi->path_info();
my $handler = $dispatch{$path};
if (ref($handler) eq "CODE") {
print "HTTP/1.0 200 OK\r\n";
$handler->($cgi);
} else {
print "HTTP/1.0 404 Not found\r\n";
print $cgi->header,
$cgi->start_html('Not found'),
$cgi->h1('Not found'),
$cgi->end_html;
}
}
sub resp_insertwin {
my $cgi = shift; # CGI.pm object
return if !ref $cgi;
....
} else {
print $cgi->header("text/plain"), "INSERT";
}
.....
# ---------------------------------------------------------------------
# WebService Start in background
# ---------------------------------------------------------------------
my $pid = TACWebService->new($TACWebService::conf{tac_ws_port})->background();
print "Use 'kill $pid' to stop TAC WebService.\n";
the clients themselves are using use LWP::UserAgent like this :
my $ua = LWP::UserAgent->new();
$ua->timeout($timeout);
my $response = $ua->post($TAC_Url,
[
'args' => $here,
]
if (!$response->is_success) {
print "Timeout while connecting to $TAC_Url\n";
} else {
my $content = $response->as_string();
print $content if (grep(/INSERT_/,$content));
}
to describe the exact issue would be complicated. In short : the clients are Unix servers sending their user database (user accounts). and when lots of clients are sending this user db at once, i can see the webservice receiving half of the data, and answering "timeout" after a couple of accounts (probably because it's overloaded in some way)
thanks again
The problem is, that the client waits to long for the server to respond. To solve this you have to start the server multiple times. The easiest Solution to this is to add
sub net_server { 'Net::Server::PreFork' }
to your package TACWebService and the HTTP::Server::Simple::CGI will do the rest of the magick.
Or you can use HTTP::Server::Simple::CGI::PreFork instead. See https://metacpan.org/pod/HTTP::Server::Simple::CGI::PreFork
I'm using Perl to connect to some (very) low-powered hardware devices with TLS. The first handshake can take around 10-15 seconds to complete! Reusing the session (from the same Perl process) is much faster but when the next job comes around to connect to the same device the new process has to establish a new session with the same delay. I'd like to share a session cache between my processes but I'm running into problems (and segfaults!).
I have a test script (connecting to openssl s_server -www) with a IO::Socket::SSL::Session_Cache wrapper that uses Sereal to write the cache object out to disk. Despite finding the existing sessions in the cache, it does not reuse them and sometimes segfaults when trying to add additional entries to the cache.
use 5.20.1; use warnings;
use LWP::UserAgent;
use IO::Socket::SSL;
# $IO::Socket::SSL::DEBUG = 2;
request_with_new_ua();
request_with_new_ua();
request_with_new_ua();
sub request_with_new_ua {
say "make request";
my $ua = LWP::UserAgent->new;
$ua->ssl_opts(
verify_hostname => 0,
SSL_session_cache => Inline::SessionStore->new,
);
process_response($ua->get('https://localhost:4433'));
}
sub process_response {
my $res = shift;
say "> $_" for grep /Session|Master/, split /\n/, $res->as_string;
}
BEGIN {
package Inline::SessionStore;
use 5.20.1; use warnings;
use Moo;
use experimental qw(signatures);
use Sereal::Encoder;
use Sereal::Decoder;
use Try::Tiny;
use Path::Tiny;
has session_cache => ( is => 'rw' );
my $encoder = Sereal::Encoder->new;
my $decoder = Sereal::Decoder->new;
my $file = path('/tmp/ssl-session-cache');
sub get_session ($self, $key) {
say "get session $key";
my $cache;
try {
$cache = $decoder->decode($file->slurp_raw);
say "got cache from file, ".ref $cache;
} catch {
say $_ unless /No such file/;
$cache = IO::Socket::SSL::Session_Cache->new(128);
say "made new cache";
};
$self->session_cache($cache);
my $ret = $cache->get_session($key);
say "found session $ret" if $ret;
return $ret;
}
sub add_session {
my $self = shift;
say"add session " . join ' - ', #_;
my $session = $self->session_cache->add_session(#_);
$file->spew_raw($encoder->encode($self->session_cache));
return $session;
}
sub del_session {
my $self = shift;
say "del session " . join ' - ', #_;
$self->session_cache->del_session(#_);
$file->spew_raw($encoder->encode($self->session_cache));
}
1;
}
And output:
rm -f /tmp/ssl-session-cache && perl wes.swp/workbench.pl
make request
get session localhost:4433
made new cache
add session localhost:4433 - 23864624
> SSL-Session:
> Session-ID:
> Session-ID-ctx: 01000000
> Master-Key: DDF335492BFE2A7BA7674A656E72005865859D89249D597302F338D01C5776E2C94B61E6BCBED6114DFDA5AAEECD22EA
make request
get session localhost:4433
got cache from file, IO::Socket::SSL::Session_Cache
found session 23864624
add session localhost:4433 - 23864624 # trying to re-add the session??
> SSL-Session:
> Session-ID:
> Session-ID-ctx: 01000000
> Master-Key: 4FE17B7FE9B4DE0A711C659FC333F686AD41840740B9D10E67A972D5A27D1720F0470329DA63DE65C1B023A1E2F0CC89
make request
get session localhost:4433
got cache from file, IO::Socket::SSL::Session_Cache
found session 23864624
add session localhost:4433 - 23864624
> SSL-Session:
> Session-ID:
> Session-ID-ctx: 01000000
> Master-Key: C76C52E5ECC13B0BB4FA887B381779B6F686A73DDFBEA06B33336537EC6AE39290370C07505BCD8B552CA874CD6E4089
I feel like I'm close to getting this to work but I'm missing something.
I don't think there is a way to use IO::Socket::SSL/Net::SSLeay or Crypt::SSLeay (which are the newer and older SSL backend for LWP) between processes.
The session cache you are trying to use in your code references SESSION objects which are internal to the OpenSSL library. Serializing the cache at the Perl level will not serialize the parts from inside the OpenSSL library but will just include the pointers to the internal structures. Since these pointers are only valid for the current state of the process, deserializing this again inside a different process or process state will thus result in dangling pointers pointing into nowhere in the best case or to some other data in the worst case and will thus result in segmentation faults or corruption of internal data.
In Net::SSLeay there are i2d_SSL_SESSION and d2i_SSL_SESSION functions which could in theory be used to properly serialize a SESSION object. But I doubt that there are usable in the current implementation.
I'm trying to reuse a previously established websocket connection to avoid the websocket handshake. I found that a custom websocket transaction can be built using build_websocket_tx (more details here), and there's a connection identifier for every websocket connection which can be retrieved using connection subroutine defined in Mojo::Transaction (more details here). Can I somehow combine both of these to re use the connection? Is there another way to do so?
PS: Websocket connections are supposed to be consistent and reusable. But Mojolicoious doesn't provide any such options for websocket connections.
EDIT
Example code without connection re-use.
#!/usr/bin/perl
use strict;
use warnings;
use Mojo::UserAgent;
use JSON qw |encode_json|;
my $ua = Mojo::UserAgent->new;
my $url = "wss://trello.com/1/Session/socket";
$| = 1;
sub _connect {
my $req = {
type => "ping",
reqid=> 0
};
$ua->websocket(
$url => sub {
my ($ua, $tx) = #_;
die "error: ", $tx->res->error->{message}, "\n" if $tx->res->error;
die 'Not a websocket connection' unless $tx->is_websocket;
# Connection established.
$tx->on(
message => sub {
my ($tx, $msg) = #_;
print "$msg\n";
$tx->closed; #Close connection
});
$tx->send(encode_json($req));
});
}
sub reuse_conn {
# Re use connection
}
_connect();
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
Preliminaries: to run a Mojolicious client script with debugging information:
MOJO_EVENTEMITTER_DEBUG=1 MOJO_USERAGENT_DEBUG=1 perl mua.pl
As at version 7.43, Mojo::UserAgent has built-in connection pooling but specifically refuses to use it for WebSockets. This may well be because as you said, WebSockets is stateful, and if the UserAgent blindly reused connections, that could cause chaos. However, if your application knows how to safely reuse them, that is a different matter.
This question came up recently in the IRC channel for Mojolicious, and sri, the author, said:
16:28 sri mohawk: some frameworks like phoenix have their own higher level protocol on top of websockets to multiplex multiple channels https://hexdocs.pm/phoenix/channels.html
16:28 sounds like that's what you want
16:28 mojolicious should have something like that, but doesn't yet
[...]
16:42 sri it's not hard to build on top of mojolicious, but for now you have to do that yourself
16:42 ultimately i'd hope for us to have it in core, without the message bus part
16:43 but channel management and routing
[...]
16:50 jberger mohawk I did write Mojolicious::Plugin::Multiplex which might help
16:51 For an example of a higher level tool
I acknowledge OP said:
The only way I was able to reuse connection was by storing the transaction object and use it in subsequent calls.
However, as the code currently is, it appears this is the only way. This code demonstrates how to make, maintain, and use your own connection pool:
#!/usr/bin/perl
use strict;
use warnings;
use Mojo::UserAgent;
use Time::HiRes qw(time);
$| = 1;
my $REQ = {
type => "ping",
reqid => 0,
};
my $URL = "wss://trello.com/1/Session/socket";
my $SECONDS = 2;
my $POOL_SIZE = 5;
my $ua = Mojo::UserAgent->new;
my #pool;
sub make_conn {
my ($ua, $url, $pool) = #_;
$ua->websocket($URL => sub {
my (undef, $tx) = #_;
die "error: ", $tx->res->error->{message}, "\n" if $tx->res->error;
die 'Not a websocket connection' unless $tx->is_websocket;
push #$pool, $tx;
});
}
# pool gets pushed onto, shifted off, so using recently-used connection
sub send_message {
my ($pool, $request, $start) = #_;
my $tx = shift #$pool;
die "got bad connection" unless $tx; # error checking needs improving
$tx->once(message => sub {
my (undef, $msg) = #_;
print "got back: $msg\n";
print "took: ", time - $start, "\n";
push #$pool, $tx;
});
$tx->send({json => $request});
}
make_conn($ua, $URL, \#pool) for (1..5); # establish pool
# every 2 secs, send a message
my $timer_cb;
$timer_cb = sub {
my $loop = shift;
print "every $SECONDS\n";
send_message(\#pool, $REQ, time);
$loop->timer($SECONDS => $timer_cb);
};
Mojo::IOLoop->timer($SECONDS => $timer_cb);
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
At a high level, it works like this:
make 5 connections in the pool
send_message uses the least-recently-used connection in that pool
send a message every two seconds, registering a one-time "on message" callback to deal with the response
For the sake of simplicity, it does not check connections are still working when it gets them from the pool, and relies on the first two-second delay to initialise all 5 connections.
The use of time calls demonstrates the speed gain from using this pool. Your provided code takes (on my system) around 300ms to start up the connection, then send and receive. Using the pool, it is taking around 120ms.
I'm porting an application from PHP/cURL to Perl and LWP::UserAgent. I need to do a POST request to a web server and provide a client certificate and key file. The PHP code I'm trying to replicate is this:
curl_setopt($ch, CURLOPT_SSL_VERIFYPEER, 0);
curl_setopt($ch, CURLOPT_SSLCERT, "/path/to/certificate.pem");
curl_setopt($ch, CURLOPT_SSLKEY, "/path/to/private.key");
curl_setopt($ch, CURLOPT_SSLKEYPASSWD, "secretpassword");
And here's my Perl code:
my $ua = LWP::UserAgent->new();
$ua->ssl_opts(
SSL_verify_mode => 0,
SSL_cert_file => '/path/to/certificate.pem',
SSL_key_file => "/path/to/private.key",
SSL_passwd_cb => sub { return "secretpassword"; }
);
The PHP code successfully connects to the server but the Perl code fails with:
SSL read error error:14094410:SSL routines:SSL3_READ_BYTES:sslv3 alert handshake failure
I can't figure out what I'm missing.
sub send_command(){
my $command = shift;
my $parser = XML::LibXML->new('1.0','utf-8');
print color ("on_yellow"), "SEND: ", $command, color ("reset"), "\n";
# Create a request
my $req = HTTP::Request->new( GET => $Gateway.$command );
# Pass request to the user agent and get a response back
my $res;
eval {
my $ua;
local $SIG{'__DIE__'};
$ua = LWP::UserAgent->new(); # или
$ua->ssl_opts( #$key => $value
SSL_version => 'SSLv3',
SSL_ca_file => '/ca.pem',
#SSL_passwd_cb => sub { return "xxxxx\n"; },
SSL_cert_file => '/test_test_cert.pem',
SSL_key_file => '/test_privkey_nopassword.pem',
); # ssl_opts => { verify_hostname => 0 }
$ua->agent("xxxxxx xxxx_tester.pl/0.1 ");
$res = $ua->request($req);
};
warn $# if $#;
# Check the outcome of the response
if ( $res->is_success ) {
open xxxLOG, ">> $dir/XXXX_tester.log";
my $without_lf = $res->content;
$without_lf =~ s/(\r|\n)//gm;
print PAYLOG $without_lf,"\n";
close PAYLOG;
}
else {
return $res->status_line;
}
print color ("on_blue"), "RESPONSE: ", color ("reset"), respcode_color($res->content), color ("reset"),"\n\n";
return $res->content;
}
The answer from emazep above solved my problem. I'm using the sample Perl code from UPS to connect to their Rate service via XML. From my tests, this will work any time LWP::UserAgent is being called without arguments that you can control directly, which makes it handy if you're using some other module which makes calls to LWP for you. Just use Net::SSL (in addition to whatever packages have already used LWP) and set a few environment variables:
...
use Net::SSL;
$ENV{HTTPS_VERSION} = 3;
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
my $browser = LWP::UserAgent->new();
...
That's it! You shouldn't even need to specify the path to your server's root certificate with $ENV{PERL_LWP_SSL_CA_FILE}.
Indeed this is a messy bit. Depending on your setup LWP::UserAgent may use one of (at least) two SSL modules to handle the SSL connection.
IO::Socket::SSL
Net::SSL
The first one should be the default for newer versions of LWP::UserAgent. You can test which of these are installed by running the standard command in a terminal for each module:
perl -e 'use <module>;'
IO::socket::SSL requires the SSL configuration with the ssl_opts as in your example.
Net::SSL requires the SSL configuration in environment variables as in goddogsrunnings answer.
Personally I fall in the second category and had good inspiration from the Crypt::SSLeay page. Particularly the section named "CLIENT CERTIFICATE SUPPORT ".
I am trying to implement a request to an unreliable server. The request is a nice to have, but not 100% required for my perl script to successfully complete. The problem is that the server will occasionally deadlock (we're trying to figure out why) and the request will never succeed. Since the server thinks it is live, it keeps the socket connection open thus LWP::UserAgent's timeout value does us no good what-so-ever. What is the best way to enforce an absolute timeout on a request?
FYI, this is not an DNS problem. The deadlock has something to do with a massive number of updates hitting our Postgres database at the same time. For testing purposes, we've essentially put a while(1) {} line in the servers response handler.
Currently, the code looks like so:
my $ua = LWP::UserAgent->new;
ua->timeout(5); $ua->cookie_jar({});
my $req = HTTP::Request->new(POST => "http://$host:$port/auth/login");
$req->content_type('application/x-www-form-urlencoded');
$req->content("login[user]=$username&login[password]=$password");
# This line never returns
$res = $ua->request($req);
I've tried using signals to trigger a timeout, but that does not seem to work.
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm(1);
$res = $ua->request($req);
alarm(0);
};
# This never runs
print "here\n";
The final answer I'm going to use was proposed by someone offline, but I'll mention it here. For some reason, SigAction works while $SIG(ALRM) does not. Still not sure why, but this has been tested to work. Here are two working versions:
# Takes a LWP::UserAgent, and a HTTP::Request, returns a HTTP::Request
sub ua_request_with_timeout {
my $ua = $_[0];
my $req = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)
use Sys::SigAction qw( timeout_call );
our $res = undef;
if( timeout_call( 5, sub {$res = $ua->request($req);}) ) {
return HTTP::Response->new( 408 ); #408 is the HTTP timeout
} else {
return $res;
}
}
sub ua_request_with_timeout2 {
print "ua_request_with_timeout\n";
my $ua = $_[0];
my $req = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)
my $timeout_for_client = $ua->timeout() - 2;
our $socket_has_timedout = 0;
use POSIX;
sigaction SIGALRM, new POSIX::SigAction(
sub {
$socket_has_timedout = 1;
die "alarm timeout";
}
) or die "Error setting SIGALRM handler: $!\n";
my $res = undef;
eval {
alarm ($timeout_for_client);
$res = $ua->request($req);
alarm(0);
};
if ( $socket_has_timedout ) {
return HTTP::Response->new( 408 ); #408 is the HTTP timeout
} else {
return $res;
}
}
You might try LWPx::ParanoidAgent, a subclass of LWP::UserAgent which is more cautious about how it interacts with remote webservers.
Among other things, it allows you to specify a global timeout. It was developed by Brad Fitzpatrick as part of the LiveJournal project.
You can make your own timeout like this:
use LWP::UserAgent;
use IO::Pipe;
my $agent = new LWP::UserAgent;
my $finished = 0;
my $timeout = 5;
$SIG{CHLD} = sub { wait, $finished = 1 };
my $pipe = new IO::Pipe;
my $pid = fork;
if($pid == 0) {
$pipe->writer;
my $response = $agent->get("http://stackoverflow.com/");
$pipe->print($response->content);
exit;
}
$pipe->reader;
sleep($timeout);
if($finished) {
print "Finished!\n";
my $content = join('', $pipe->getlines);
}
else {
kill(9, $pid);
print "Timed out.\n";
}
From what I understand, the timeout property doesn't take into account DNS timeouts. It's possible that you could make a DNS lookup separately, then make the request to the server if that works, with the correct timeout value set for the useragent.
Is this a DNS problem with the server, or something else?
EDIT: It could also be a problem with IO::Socket. Try updating your IO::Socket module, and see if that helps. I'm pretty sure there was a bug in there that was preventing LWP::UserAgent timeouts from working.
Alex
The following generalization of one of the original answers also restores the alarm signal handler to the previous handler and adds a second call to alarm(0) in case the call in the eval clock throws a non alarm exception and we want to cancel the alarm. Further $# inspection and handling can be added:
sub ua_request_with_timeout {
my $ua = $_[0];
my $request = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)`enter code here`
my $timeout_for_client_sec = $ua->timeout();
our $res_has_timedout = 0;
use POSIX ':signal_h';
my $newaction = POSIX::SigAction->new(
sub { $res_has_timedout = 1; die "web request timeout"; },# the handler code ref
POSIX::SigSet->new(SIGALRM),
# not using (perl 5.8.2 and later) 'safe' switch or sa_flags
);
my $oldaction = POSIX::SigAction->new();
if(!sigaction(SIGALRM, $newaction, $oldaction)) {
log('warn',"Error setting SIGALRM handler: $!");
return $ua->request($request);
}
my $response = undef;
eval {
alarm ($timeout_for_client_sec);
$response = $ua->request($request);
alarm(0);
};
alarm(0);# cancel alarm (if eval failed because of non alarm cause)
if(!sigaction(SIGALRM, $oldaction )) {
log('warn', "Error resetting SIGALRM handler: $!");
};
if ( $res_has_timedout ) {
log('warn', "Timeout($timeout_for_client_sec sec) while waiting for a response from cred central");
return HTTP::Response->new(408); #408 is the HTTP timeout
} else {
return $response;
}
}