mod_perl and CGI behavior - perl

This has got to be something silly I'm doing wrong. It's such a newbie type problem.
The original script is something that sits and waits for a 3rd party to connect and POST some xml to it, it takes that xml, does some validation, and stores it in a db. That part is fine. The problem is my response. I'm trying to use the header() function from CGI and it's just not behaving. It comes up blank. Obviously I could just do this manually and just print the header string, but now I'm really curious why this is behaving so strangely.
Here is a stripped down test version of the cgi script:
use strict;
use warnings;
use Data::Dumper::Names;
use CGI qw(:standard);
use Apache2::Connection ();
use Apache2::RequestRec ();
$| = 1;
# Grab the request object provided by mod_perl.
our $request_obj = shift;
our $connection = $request_obj->connection;
our $remote_ip = $connection->client_ip();
my $cgi = CGI->new($request_obj->args());
print STDERR Dumper($cgi);
my $input = $cgi->param('POSTDATA');
print STDERR Dumper($input);
my $cgi_header = $cgi->header();
print STDERR Dumper($cgi_header);
my $cgi_full_header = $cgi->header(-type => 'application/xml');
print STDERR Dumper($cgi_full_header);
my $q = CGI->new({});
print STDERR Dumper($q);
my $q_header = $q->header();
print STDERR Dumper($q_header);
my $q_full_header = $q->header(-type => 'application/xml' );
print STDERR Dumper($q_full_header);
And the output:
$cgi = bless( {
'.r' => bless( do{\(my $o = '94118860562256')}, 'Apache2::RequestRec' ),
'param' => {
'POSTDATA' => [
'test'
],
'XForms:Model' => [
'test'
]
},
'use_tempfile' => 1,
'.fieldnames' => {},
'.charset' => 'ISO-8859-1',
'escape' => 1,
'.parameters' => [
'XForms:Model',
'POSTDATA'
]
}, 'CGI' );
$input = 'test';
$cgi_header = '';
$cgi_full_header = '';
$q = bless( {
'.parameters' => [
'XForms:Model',
'POSTDATA'
],
'escape' => 1,
'.fieldnames' => {},
'.charset' => 'ISO-8859-1',
'use_tempfile' => 1,
'.r' => bless( do{\(my $o = '94118860562256')}, 'Apache2::RequestRec' ),
'param' => {
'POSTDATA' => [
''
],
'XForms:Model' => [
''
]
}
}, 'CGI' );
$q_header = '';
$q_full_header = '';
And here is the simple test script I'm using to send the POST.
#!/perl/bin/perl
use strict;
use warnings;
use DBI;
use URI;
use LWP::UserAgent;
use Data::Dumper::Names;
my $ua = LWP::UserAgent->new;
$ua->max_size( 131072 );
$ua->agent('test_xml_pusher');
$ua->ssl_opts(verify_hostname => 0);
my $url = URI->new;
$url->scheme('https');
$url->host('xxxxxxxxxxxxxxxxxxxxxxxxx');
$url->port(443);
$url->path_segments('test.cgi');
# Yes, I know... it's not valid xml... don't care for the purposes of this test.
#
my $xml = 'test';
my $response = $ua->post( $url, Content => $xml, 'Content-Type' => 'application/xml' );
print Dumper($response);
my $status_line = $response->status_line;
print Dumper($status_line);
my $content = $response->content;
print Dumper($content);
So why is $cgi_header empty? And why does $q end up being a reference to the same thing as $cgi even though I tried initializing it as my $q = CGI->new({});? (I also tried empty quotes instead of empty brackets.)
Any thoughts?
Thanks!
My environment is a centos 7 server running apache httpd 2.4.34 with mod_perl 2.0.11 and perl 5.22.4. (httpd is installed from from SCL, but perl and mod_perl are installed from source.)
--
Andy

Related

Perl script as a router between icecast2 and VLC client

I wrote a Perl script to act as router between an icecast2 server and a VLC client. I start the script via
plackup --listen :8000 testStreamingServer.pl --debug
The problem is, I always get to the print "Starting server\n"; line but neither VLC, Firefox or curl can connect to the audio stream. There is no further info on the server side. No debug message, nothing.
Here is the code:
#!/usr/bin/env perl
use strict;
use warnings;
use Data::Dumper;
use LWP::UserAgent;
use Plack::Runner;
use File::Temp qw(tempfile);
my $source_url = 'http://server1.example.com/stream.mp3';
my $redirect_url = 'http://server2.example.com/stream.mp3';
my $ua = LWP::UserAgent->new();
print "Starting server\n";
my $app = sub {
print "Request received\n";
my $response = $ua->get($source_url);
if ($response->is_success) {
print "Source server is online, stream is playable\n";
my ($fh, $filename) = tempfile();
my $content_response = $ua->get($source_url, ':content_file' => $filename);
my $headers = $content_response->headers();
print Dumper $headers;
my $size = -s $filename;
open(my $file, "<", $filename);
my $file_content = do { local $/; <$file> };
close $file;
return [
200,
[ 'Content-Type' => 'audio/mpeg',
'Content-Length' => $size,
'icy-metaint' => 8192,
'icy-name' => 'My Stream',
'icy-description' => 'My stream description',
'icy-genre' => 'variety',
'icy-pub' => 1,
'icy-br' => 128,
'Connection' => 'close' ],
[ $file_content ],
];
} else {
print "Source server is offline, redirecting to backup stream\n";
return [
302,
[ 'Location' => $redirect_url, 'Connection' => 'close' ],
[],
];
}
};
my $runner = Plack::Runner->new;
$runner->parse_options(qw(--listen :8000 --server HTTP::Server::PSGI));
$runner->run($app);
print "Server started\n";
I tried print debugging, line by line. I am clueless right now.

Perl rest client declaration causes failure of user agent call with custom headers with another end point

I have 2 subroutines called in a single perl program .
First one (get_secrets) I am using the perl REST client directly with custom header and second one (app_restart) I am using LWP user agent and make and HTTP call .
my second subroutine fails when the $client header declaration is available in the first subroutine , as soon as i remove the that subroutine or comment the lines those lines app_restart subroutine works fine .
use REST::Client;
use Data::Dumper;
use JSON; #use strict;
use MIME::Base64 qw( decode_base64 );
use POSIX 'strftime';
use Date::Parse;
use DateTime;
use Date::Calc qw(:all);
use LWP::UserAgent;
#use IO::Socket::SSL 'debug4';
use Data::Dumper qw(Dumper);
use Getopt::Long;
sub toList {
my $data = shift;
my $key = shift;
if ( ref( $data->{$key} ) eq 'ARRAY' ) {
$data->{$key};
}
elsif ( ref( $data->{$key} ) eq 'HASH' ) {
[ $data->{$key} ];
}
else {
[];
}
}
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
$endpoint = $ENV{'ENDPOINT'};
$token = `cat /var/run/secrets/kubernetes.io/serviceaccount/token`;
$namespace = $ENV{'NAMESPACE'};
$apikey = $ENV{'APIKEY'};
$instance = $ENV{'INSTANCE'};
$appid = $ENV{'APPID'};
$storeid = "checker";
sub get_secrets {
my $client = REST::Client->new();
$client->setHost("https://${endpoint}");
#$client->addHeader('Authorization', "Bearer ${token}");
$client->addHeader( 'Accept', "application/json" );
$client->GET("/api/v1/namespaces/${namespace}/secrets?labelSelector=true");
}
get_secrets();
$ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS} = "Net::SSL";
my $ua = LWP::UserAgent->new( 'send_te' => '0' );
$ua->ssl_opts(
SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
SSL_hostname => '',
verify_hostname => 0
);
sub app_restart {
$ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS} = "Net::SSL";
$ua = LWP::UserAgent->new( 'send_te' => '0' );
$ua->ssl_opts(
SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
verify_hostname => 0
print "$instance\n";
print "$apikey\n";
print "$cstoreid\n";
print "$appid\n";
my $r = HTTP::Request->new(
'PUT' =>
"https://api.service.intranet.com/rest/application/$appid/instance/$instance/action?action=restart&config=$storeid&deploy=0",
[
'Accept' => '*/*',
'Authorization' => "Realm $apikey",
'Host' => 'api.service.intranet.com:443',
'User-Agent' => 'curl/7.55.1',
],
);
my $res = $ua->request( $r, );
#$response = $res->decoded_content;
$json = JSON->new->allow_nonref;
$response_decoded = $json->decode( $res->decoded_content );
$actionID = $response_decoded->{'action_id'};
print "$actionID\n";
}
app_restart();

How can I send an incorrect Content-Length header for an HTTP request using Perl?

I'm trying to debug a weird warning that is showing up in server logs when a Plack::Request is being parsed. In some cases, a broken UserAgent will send a Content-Length header that looks something like "6375, 6375", which is obviously wrong.
To fix this properly, I need to be able to reproduce the warning. I'd like to include this in a unit test so that I can ensure there are no regressions after the warning is silenced. However, I'm having trouble doing this with Perl. I know this can be done using netcat and socat, but I don't want the unit test to have to rely on other binaries to be installed.
Here is what I've tried:
#!/usr/bin/env perl
use strict;
use warnings;
use JSON::XS qw( encode_json );
use WWW::Mechanize;
my $mech = WWW::Mechanize->new;
$mech->add_handler(
request_prepare => sub {
my ( $req, $ua, $h ) = #_;
$req->headers->header( 'Content-Length' => 9999 );
return;
}
);
my $json = encode_json( { foo => 'bar' } );
$mech->post(
'http://example.com'/url,
'Content-Length' => 999,
Content => $json
);
Output is:
Content-Length header value was wrong, fixed at /opt/perl5.16.3/lib/site_perl/5.16.3/LWP/Protocol/http.pm line 260.
200
That's entirely too helpful for me. :)
If I use HTTP::Request and LWP::UserAgent, it's the same end result.
So, I tried HTTP::Tiny.
#!/usr/bin/env perl
use strict;
use warnings;
use DDP;
use HTTP::Tiny;
use JSON::XS qw( encode_json );
my $http = HTTP::Tiny->new;
my $json = encode_json( { foo => 'bar' } );
my $response = $http->request(
'POST',
'http://example.com'/url',
{ headers => { 'Content-Length' => 999, },
content => $json,
}
);
p $response;
The output is:
{ content => "Content-Length missmatch (got: 13 expected: 999)
",
headers => {
content
-length => 49,
content-type => "text/plain",
},
reason => "Internal Exception",
status => 599,
success => "",
url => "http://example.com'/url",
}
Again, too helpful. At this point, I could use a few suggestions.
Seems like the higher level API's are fixing your error; Here's an example using raw sockets that overcomes this;
#!/usr/bin/env perl
use strict 'vars';
use warnings;
use Socket;
# initialize host and port
my $host = 'www.example.com';
my $port = 80;
# contact the server
open_tcp(F, $host, $port)
or die 'Could not connect to server';
# Send request data
while ( my $request = <DATA> ) {
print F $request;
}
# Get Response
while ( my $response = <F> ) {
print "Response:> $response";
}
close(F);
# TCP Helper
sub open_tcp
{
# get parameters
my ($FS, $dest, $port) = #_;
my $proto = getprotobyname('tcp');
socket($FS, PF_INET, SOCK_STREAM, $proto);
my $sin = sockaddr_in($port,inet_aton($dest));
connect($FS,$sin);
my $old_fh = select($FS);
$| = 1; # don't buffer output
select($old_fh);
}
__DATA__
GET / HTTP/1.1
Host: example.com
Content-Length: 999
-END-

How to use output from WWW::Mechanize?

I would like to loop through all links on a web page, so I have tried
#!/usr/bin/perl
use WWW::Mechanize;
my $url = "http://www.google.com";
my $m = WWW::Mechanize->new();
$m->get($url);
my #links = $m->find_all_links(url_regex => qr/google/);
foreach my $link (#links){
print Dumper $m->get($link->url_abs);
}
which gives me e.g.
$VAR11 = bless( [
'http://www.google.com/ncr',
'Google.com in English',
undef,
'a',
$VAR1->[4],
{
'href' => 'http://www.google.com/ncr',
'class' => 'gl nobr'
}
], 'WWW::Mechanize::Link' );
Question
How do I output just the links?
The documentation points out that the links are returned as WWW::Mechanize::Link objects. Therefore:
my #links = $m->find_all_links(url_regex => qr/google/);
print $_->url, "\n" for #links;

How can I access Closure JavaScript minifier using Perl's LWP::UserAgent?

I'm trying to get Code Closure to work, but unfortunately, there's always an error thrown.
Here's the code:
use LWP::UserAgent;
use HTTP::Request::Common;
use HTTP::Response;
my $name = 'test.js';
my $agent = new LWP::UserAgent();
$agent->agent("curl/7.21.0 (x86_64-pc-linux-gnu) libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18");
$res = $agent->request(POST 'http://closure-compiler.appspot.com/compile',
content_type => 'multipart/form-data',
content => [
output_info => 'compiled_code',
compilation_level => 'SIMPLE_OPTIMIZATIONS',
output_format => 'text',
js_code => [File::Spec->rel2abs($name)]
]);
if ($res->is_success) {
$minified = $res->decoded_content;
print $minified;die;
}
I get the following error:
Error(13): No output information to produce, yet compilation was requested.
Here's the api reference I used:
http://code.google.com/intl/de-DE/closure/compiler/docs/api-ref.html
Hope anyone knows what's going wrong here. Thanks.
#!/usr/bin/perl
use strict; use warnings;
use File::Slurp;
use LWP::UserAgent;
my $agent = LWP::UserAgent->new;
my $script = 'test.js';
my $response = $agent->post(
'http://closure-compiler.appspot.com/compile',
content_type => 'application/x-www-form-urlencoded',
content => [
compilation_level => 'SIMPLE_OPTIMIZATIONS',
output_info => 'compiled_code',
output_format => 'text',
js_code => scalar read_file($script),
],
);
if ($response->is_success) {
my $minified = $response->decoded_content;
print $minified;
}
Output:
C:\Temp> cat test.js
// ADD YOUR CODE HERE
function hello(name) {
alert('Hello, ' + name);
}
hello('New user');
C:\Temp> t
function hello(a){alert("Hello, "+a)}hello("New user");
Pass as js_code the actual code to compile. Try (removing the form-data content_type header):
use File::Slurp "read_file";
...
js_code => scalar( read_file($name) ),
I see you are trying to use POST's file upload feature; what in the API documentation do you see that makes you think that would work? If there is something there, I don't see it.