Extract REMOTE_ADDR using mod_perl - perl

Please help how to extract REMOTE_ADDR value using mod_perl.
I have following perl script:
use Apache2::RequestUtil;
use Apache2::RequestRec;
$| = 1;
print "Content-type: text/plain\n\n";
my $r = Apache2::RequestUtil->request;
print $r->as_string();
the result of script:
GET /tmp/recheaders.pl HTTP/1.0
X-Scheme: http
REMOTE_ADDR: 81.204.25.44
Host: dom.net
X-Real-IP: 81.204.25.44
X-Forwarded-for: 81.204.25.44
Connection: close
User-Agent: Opera/9.80 (X11; Linux x86_64) Presto/2.12.388 Version/12.16
Accept: text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/webp, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1
Accept-Language: en-US,en;q=0.9
Accept-Encoding: gzip, deflate
Cookie: SESSION_ID=963bd96302cd70047c9f017640c7cbb8;
Cache-Control: no-cache
HTTP/1.0 (null)
How can I extract only REMOTE_ADDR: 81.204.25.44 ? What API method and how should I use?
SOLUTION
I found more elegant solution, to fetch just REMOTE_ADDR using headers_in:
use Apache2::Request;
my $r = shift;
my $req = Apache2::Request->new($r);
my $remip = $req->headers_in->{REMOTE_ADDR};
print $remip;

Just use %ENV
print $ENV{REMOTE_ADDR};
Alternatively there is Apache2::Connection->remote_addr()
use Apache2::Connection ();
use Apache2::RequestRec ();
my $c = $r->connection;
# this connection's local and remote socket addresses
my $local_sa = $c->local_addr();
my $remote_sa = $c->remote_addr();

Related

Perl LWP Post form-data with my boundary

I want to post data with content type multipart/form-data:
use strict;
use warnings;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
$ua->post (
'http://127.0.0.1:12555',
'Content-Type' => 'form-data',
Content => {
'data1' => rand,
'data2' => rand,
}
);
And i tested the submitted data:
use strict;
use warnings;
use IO::Socket::INET;
use Socket qw ( inet_aton );
my $sock_listen = new IO::Socket::INET (
LocalHost => '127.0.0.1',
LocalPort => '12555',
Proto => 'tcp',
Listen => 3,
Reuse => 1,
);
$sock_listen->autoflush ();
my $sock;
while ( $sock = $sock_listen->accept ( ) )
{
my $data = '';
$sock->recv ( $data, 4096 );
print $data . "\n";
}
Test #1 result:
POST / HTTP/1.1
TE: deflate,gzip;q=0.3
Connection: TE, close
Host: 127.0.0.1:12555
User-Agent: libwww-perl/6.05
Content-Length: 162
Content-Type: multipart/form-data; boundary=xYzZY
--xYzZY
Content-Disposition: form-data; name="data2"
0.876556396484375
--xYzZY
Content-Disposition: form-data; name="data1"
0.62921142578125
--xYzZY--
Test #2 result:
POST / HTTP/1.1
TE: deflate,gzip;q=0.3
Connection: TE, close
Host: 127.0.0.1:12555
User-Agent: libwww-perl/6.05
Content-Length: 163
Content-Type: multipart/form-data; boundary=xYzZY
--xYzZY
Content-Disposition: form-data; name="data2"
0.896942138671875
--xYzZY
Content-Disposition: form-data; name="data1"
0.041656494140625
--xYzZY--
I added a data:
'data3' => '--xYzZY'
and got:
POST / HTTP/1.1
TE: deflate,gzip;q=0.3
Connection: TE, close
Host: 127.0.0.1:12555
User-Agent: libwww-perl/6.05
Content-Length: 221
Content-Type: multipart/form-data; boundary=Tegj
--Tegj
Content-Disposition: form-data; name="data2"
0.34613037109375
--Tegj
Content-Disposition: form-data; name="data3"
--xYzZY
--Tegj
Content-Disposition: form-data; name="data1"
0.678955078125
--Tegj--
The question is how i can set the boundary manually to 32 chars string like browser's ----WebKitFormBoundary[...] using LWP?
Or can just use IO::Socket?
LWP allows you set the boundary manually when you do multipart/form-data requests. This feature is unfortunately not documented at all.
However, you have to do multipart explicitly. You can set your own boundary by appending the boundary as an additional field of the Content-Type. It will be converted to a header appropriately by HTTP::Request::Common.
my $ua = LWP::UserAgent->new;
$ua->post(
'http://127.0.0.1:12555',
'Content-Type' =>
'multipart/form-data;boundary=Nobody-has-the-intention-to-erect-a-wall',
# ^^^^^^^ ^^^^^^^^
Content => {
data1 => rand,
data2 => rand,
},
);
With your listener, this result in the following output.
POST / HTTP/1.1
TE: deflate,gzip;q=0.3
Connection: TE, close
Host: 127.0.0.1:12555
User-Agent: libwww-perl/6.15
Content-Length: 269
Content-Type: multipart/form-data; boundary=Nobody-has-the-intention-to-erect-a-wall
--Nobody-has-the-intention-to-erect-a-wall
Content-Disposition: form-data; name="data2"
0.0575856828104122
--Nobody-has-the-intention-to-erect-a-wall
Content-Disposition: form-data; name="data1"
0.677908250902878
--Nobody-has-the-intention-to-erect-a-wall--
Note that HTTP::Request::Common will replace your boundary with a random string if it finds the boundary string in the body of any of the parts. It will not just add a number to your boundary.
The sole purpose of the boundary is to separate the message parts and the only requirement on it is that it doesn't appear anywhere in the message. I don't see a good reason to attempt to set it to be "the same" as anything else. Besides, no tool guarantees that it will always use the same one.
More importantly, setting it to a fixed string (without regard for the message) is dangerous: how does anyone know that such a string may not be in a message?
Finally, I don't think it is possible to do so, precisely because the boundary must be checked to ensure that it indeed isn't in the message; so no tool should provide a way to set it to a predefined string.
Have a look at HTTP::Request::Common's source. See how the sub boundary() badly mangles the string to return, and how much work goes into the boundary elsewhere. Then CHECK_BOUNDARY: block changes it further if it isn't good enough. This is clearly not meant to be set outside.
The post method of LWP::UserAgent exists as a shortcut for this module's one.
Note that simbabque found a way to set the boundary, which then also undergoes the checks.

Snooping on http headers between different plack middlewares

If I understand right, the PSGI application works as next:
got the request from a browser
the request is "bubbles" thru some middlewares in the order as them is defined in the builder
the request comes to my app
my app produces some respond
this respond again bubbles thru some middlewares
finally the respon is send to the browser
I can easily debug-print all headers (e.g. cookies) when the request landed in my $app.
The question is:
How to debug-print the actual state of headers while the request coming thru many middlewares to my app and while the respond is going-out again thru middlewares.
So, Having an (simplyfied) app.psgi, like the next:
use strict;
use warnings;
use Plack::Builder;
my $app = sub { ... };
builder {
# <- debug-print the first request headers
# and the last respond headers here
enable "Debug";
# <- debug-print the actual state of request/respond headers here
enable "mid2";
# <- and here
enable "mid3";
# <- and here
$app; # <- and finally here - this is of course EASY
}
It is probably not as easy as something like,
print STDERR Dumper $dont_know_what->request->headers(); #HTTP::Headers ???
print STDERR Dumper $dont_know_what->respond->headers();
so adding a bounty :) ;)
One basic approach is to create a middleware that dumps the headers before executing the wrapped application and then right afterward. Then you enable this middleware at each point where you want to see the headers as you have pointed out in your pseudocode.
The following code does this by building an in-line middleware each time you enable it.
use Plack::Builder;
use Plack::Request;
use Plack::Response;
sub headers_around {
my $position = shift;
# build and return the headers_around middleware as a closure
return sub {
my $app = shift;
# gets called each request
return sub {
my $env = shift;
my $req = Plack::Request->new($env);
# display headers before next middleware
print STDERR "req headers before $position:\n" . $req->headers->as_string . "\n=====\n";
# execute the next app on the stack
my $res = $app->($env);
my $response = Plack::Response->new(#$res);
# display headers after previous middleware
print STDERR "res headers after $position:\n" . $response->headers->as_string . "\n=====\n";
return $res;
};
};
};
builder {
enable headers_around('Debug');
enable 'Debug';
enable headers_around('Lint');
enable 'Lint';
enable headers_around('StackTrace');
enable 'StackTrace', force => 1;
enable headers_around('App');
mount '/' => builder { sub {
return [ 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello World' ] ];
}}
};
# now build the application enabling regular middleware with our inline middleware
builder {
enable headers_around('Debug');
enable 'Debug';
enable headers_around('Lint');
enable 'Lint';
enable headers_around('StackTrace');
enable 'StackTrace', force => 1;
enable headers_around('App');
mount '/' => builder { sub {
return [ 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello World' ] ];
}}
};
When I run it with plackup I get the following output:
$ plackup --app between_middleware.psgi
HTTP::Server::PSGI: Accepting connections at http://0:5000/
req headers before Debug:
Connection: Keep-Alive
Accept: */*
Host: 0:5000
User-Agent: Wget/1.12 (linux-gnu)
=====
req headers before Lint:
Connection: Keep-Alive
Accept: */*
Host: 0:5000
User-Agent: Wget/1.12 (linux-gnu)
=====
req headers before StackTrace:
Connection: Keep-Alive
Accept: */*
Host: 0:5000
User-Agent: Wget/1.12 (linux-gnu)
=====
req headers before App:
Connection: Keep-Alive
Accept: */*
Host: 0:5000
User-Agent: Wget/1.12 (linux-gnu)
=====
res headers after App:
Content-Type: text/plain
=====
res headers after StackTrace:
Content-Type: text/plain
=====
res headers after Lint:
Content-Type: text/plain
=====
res headers after Debug:
Content-Type: text/plain
=====
127.0.0.1 - - [02/Apr/2014:19:37:30 -0700] "GET / HTTP/1.0" 200 11 "-" "Wget/1.12 (linux-gnu)"
Obviously you could turn this into an actual middleware like Ashley's and you may have to tweak it to send log messages using whatever facility you have in place.
Middleware
package ShowMeTheHeaders;
use parent "Plack::Middleware";
use Plack::Request;
use Plack::Response
require Text::Wrap;
my $_call_back = sub {
my $response = Plack::Response->new(#{+shift});
print "* Response Headers:\n",
Text::Wrap::wrap("\t", "\t", $response->headers->as_string);
return; # Explicit return suggested by docs.
};
sub call {
my $self = shift;
my $request = Plack::Request->new(shift);
print "* Request Headers:\n",
Text::Wrap::wrap("\t", "\t", $request->headers->as_string);
my $response = $self->app->($request);
Plack::Util::response_cb($response, $_call_back);
}
1;
You can do this without the objectification (Plack::Request and Plack::Response) but then you have to deal with raw attributes and keys for the header fields instead of the entirely more pleasant ->as_string. See also the “response callback” section of Plack::Middleware.
demo psgi
use warnings;
use strict;
use Plack::Builder;
my $app = sub {
[ 200,
[ "Content-Type" => "text/plain" ],
[ "O HAI, PLAK!" ]
];
};
builder {
enable "+ShowMeTheHeaders";
mount "/" => $app;
};

Origin not allowed by Access-Control-Allow-Origin Perl

I am making a request to remote perl server. but got the problem as
XMLHttpRequest cannot load http://otherdomain.com/getPub.pl?content=hello. Origin http://localhost is not allowed by Access-Control-Allow-Origin.
I already enable access_control_allow_origin to be "*" in perl script, codes as following:
#!/usr/bin/perl
use strict;
use CGI qw(:standard);
use warnings;
my $cgi = new CGI;
print $cgi -> header(
-type => 'text/plain',
-access_control_allow_origin => '*',
);
my $content = $cgi -> param('content');
open(CON,">content.txt") || die "can't open $!";
print CON $content;
close(CON);
and the js request as followings:
function sendData(){
var url = "http://otherdomain.com/getPub.pl?content=hello";
var xhr = createCORSRequest("GET", url);
if(!xhr){
throw new Error ('CORS not supported');
}
xhr.send();
}
function createCORSRequest(method, url){
var xhr = new XMLHttpRequest();
if("withCredentials" in xhr){
xhr.open(method,url,true);
}else if(typeof XDomainRequest != "undefined"){
xhr = new XDomainRequest();
xhr.open(method, url);
}else{
xhr = null;
}
return xhr;
}
the response header as:
Allow:GET,HEAD,POST,OPTIONS,TRACE
Connection:Keep-Alive
Content-Length:0
Content-Type:text/plain; charset=UTF-8
Date:Mon, 07 Jan 2013 16:55:44 GMT
Keep-Alive:timeout=15, max=99
Server:Apache/2.2.3 (CentOS)
What is the matter?
It finally works in PHP, although I still didn't see the difference.
Summary as :
1.
When using perl as:
my $cgi = new CGI;
print $cgi -> header(
-type => 'text/plain',
-access_control_allow_origin => '*',
-access_control_allow_headers => 'content-type,X-Requested-With',
-access_control_allow_methods => 'GET,POST,OPTIONS',
-access_control_allow_credentials => 'true',
);
The HTTP headers as:
Request header:
Request Method:OPTIONS
Status Code:200 OK
Request Headersview source
Accept:*/*
Accept-Charset:ISO-8859-1,utf-8;q=0.7,*;q=0.3
Accept-Encoding:gzip,deflate,sdch
Accept-Language:en-US,en;q=0.8
Access-Control-Request-Headers:origin, x-requested-with, content-type
Access-Control-Request-Method:POST
Connection:keep-alive
Host:example.org
Origin:http://localhost
Referer:http://localhost/testCORS.html
User-Agent:Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.11 (KHTML, like Gecko) Chrome/23.0.1271.97 Safari/537.11
Response header:
Allow:GET,HEAD,POST,OPTIONS,TRACE
Connection:Keep-Alive
Content-Length:0
Content-Type:text/plain; charset=UTF-8
Date:Tue, 08 Jan 2013 05:52:26 GMT
Keep-Alive:timeout=15, max=100
Server:Apache/2.2.3 (CentOS)
2.
BUT in PHP, it works!!!: I didn't see the differences!
code as:
<?php
header("Access-Control-Allow-Origin: *");
header("Access-Control-Allow-Methods: GET,POST,OPTIONS");
header("Access-Control-Allow-Headers: X-Requested-With,");
#header("Access-Control-Allow-Credentials: true");
?>
Response header :
Access-Control-Allow-Headers:X-Requested-With
Access-Control-Allow-Methods:GET,POST,OPTIONS
Access-Control-Allow-Origin:*
Connection:Keep-Alive
Content-Length:0
Content-Type:text/html; charset=UTF-8
Date:Tue, 08 Jan 2013 05:52:10 GMT
Keep-Alive:timeout=15, max=100
Server:Apache/2.2.3 (CentOS)
X-Powered-By:PHP/5.3.3
You need to make sure that your server is responding to an OPTIONS request to that URL with the proper Access-Control-Allow-Origin header. The browser will "preflight" your request by first making an OPTIONS request. If that fails, it will not try your request at all.

How do I change the order of HTTP request headers sent by Perl's LWP?

For a test i need to do a get requets to a website - unfortunatly when using perl lwp the "connection" appears in the header b4 the host. As a result the request gets filtered by the web application firewall. All i need is to remove or move down the connection line in the header. When i do the requets with my script:
use warnings;
use IO::Socket;
use LWP::UserAgent;
use LWP::Protocol::http;
use HTTP::Request;
my $ua = LWP::UserAgent->new();
push(#LWP::Protocol::http::EXTRA_SOCK_OPTS, SendTE => 0, PeerHTTPVersion => "1.1");
$ua->default_header(Cookie => 'XXX', User-Agent => 'whateva');
my $request = $ua->get('https://www.test.com/test.html?...');
....
The header looks like this:
GET /test.html?... HTTP/1.1
Connection: close
Host: www.test.com
User-Agent: whateva
Cookie: XXXX
BUT it should look like this to work (conenction comes after host):
GET /test.html?... HTTP/1.1
Host: www.test.com
Connection: close
User-Agent: whateva
Cookie: XXXX
How do i get rid of that connection line in LWP? I just need to re-oder it....Its not that it needs to be completly removed; I am happy to add it later in there again as
# $userAgent->default_header ("Connection" => "keep-alive");..
Thx a lot in advance!
To work around the bug in your firewall*, change
return _bytes(join($CRLF, "$method $uri HTTP/$ver", #h2, #h, "", $content));
in Net/HTTP.pm to
my #h3 = ( #h2, #h );
if (my ($idx) = grep /^Host:/, 0..$#h3) {
unshift(#h3, splice(#h3, $idx, 1));
}
return _bytes(join($CRLF, "$method $uri HTTP/$ver", #h3, "", $content));
* — According to the HTTP/1.1 spec, RFC 2616, "The order in which header fields with differing field names are received is not significant."

Send a plain string request with LWP

To get a response from a certain website, I have to give one exact request string, HTTP/1.1. I tried that one with telnet, it gives me the response I want (a redirect, but I need it).
But when I try to give the same request string to HTTP::Request->parse(), I merely get the message 400 URL must be absolute.
I am not sure if it's the website or LWP giving me that, because as I said, the response worked with telnet.
This is the code:
my $req = "GET / HTTP/1.1\n".
"Host: www.example-site.de\n".
"User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:2.0.1) Gecko/20100101 Firefox/4.0.1\n".
"Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\n".
"Accept-Language: en-us,en;q=0.5\n".
"Accept-Encoding: gzip, deflate\n".
"Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\n".
"Keep-Alive: 115\n".
"Connection: keep-alive\n";
# Gives correct request string
print HTTP::Request->parse($req)->as_string;
my $ua = LWP::UserAgent->new( cookie_jar => {}, agent => '' );
my $response = $ua->request(HTTP::Request->parse($req));
# 400 error
print $response->as_string,"\n";
Anyone can help me here?
LWP::UserAgent dies with the error you are getting if there is no schema specified in request. It probably need it to properly work with it.
So, to make it work, you need to specify full url for your request:
my $req_str = "GET http://www.example.de/\n".
"User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:2.0.1) Gecko/20100101 Firefox/4.0.1\n".
"Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\n".
"Accept-Language: en-us,en;q=0.5\n".
"Accept-Encoding: gzip, deflate\n".
"Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\n".
"Keep-Alive: 115\n".
"Connection: keep-alive\n";
Ok, I did it using Sockets. After all, I had the HTTP request and wanted the plain response. Here the code for people who are interested:
use IO::Sockets;
my $sock = IO::Socket::INET->new(
PeerAddr => 'www.example-site.de',
PeerPort => 80,
Proto => 'Tcp',
);
die "Could not create socket: $!\n" unless $sock;
print $sock, $req;
while(<$sock>) {
# Look for stuff I need
}
close $sock;
It's just important to remember to leave the while, as the HTTP response won't end with an EOF.
It looks to me like parsing the request isn't 100 % round-trip-safe, meaning you cannot feed the response back into a request.
Looks like a bug at first sight, but the module's been out for such a long time… On the other hand, I didn't even know you could use this module to parse a request, so maybe it's not so well tested.
The following test case should point you to the problem, which is that the URL isn't properly assembled for being fed to the $req->request method.
use strict;
use warnings;
use LWP::UserAgent;
use HTTP::Request;
use Test::More;
my $host = 'www.example.com';
my $url = '/bla.html';
my $req = <<"EOS";
GET $url HTTP/1.1
Host: $host
EOS
# (1) parse the request
my $reqo = HTTP::Request->parse($req);
isa_ok $reqo, 'HTTP::Request';
diag explain $reqo;
diag $reqo->as_string;
# (2) construct the request
my $reqo2 = HTTP::Request->new( GET => "http://$host$url" );
isa_ok $reqo2, 'HTTP::Request';
diag explain $reqo2;
diag $reqo2->as_string;
is $reqo->uri, $reqo2->uri, 'both URLs are identical';
my $ua = LWP::UserAgent->new( cookie_jar => {}, agent => '' );
for ( $reqo, $reqo2 ) {
my $response = $ua->request( $_ );
diag $response->as_string,"\n";
}
done_testing;