Dump WWW::Curl::Easy request - perl

I use package WWW::Curl::Easy for API calls, and this is my example code:
use WWW::Curl::Easy;
my $curl = WWW::Curl::Easy->new();
$curl->setopt(CURLOPT_POST, 1);
$curl->setopt(CURLOPT_HEADER, 1);
$curl->setopt(CURLOPT_HTTPHEADER, ['Accept: text/xml; charset=utf-8', 'Content-Type:text/xml; charset=utf-8', 'SOAPAction: "importSheet"']);
$curl->setopt(CURLOPT_POSTFIELDS, $requestMessage);
$curl->setopt(CURLOPT_URL, $tom::{'setup'}{'api'}{'carrier'}{'url'});
my $response;
$curl->setopt(CURLOPT_WRITEDATA, \$response);
main::_log(Dumper(\$curl));
my $ret = $curl->perform();
Can I somehow dump whole request from $curl?
I tried main::_log(Dumper(\$curl)); but it didn't give me anything useful.
I would like to see whole request like real headers, method, body of request, post data etc. I know that I can see these information in code because I set it for example in CURLOPT_HTTPHEADER but I would like to dump "real" request (from curl) which is going to be send.

The easiest way is to turn CURLOPT_VERBOSE on in your program.
use WWW::Curl::Easy;
my $curl = WWW::Curl::Easy->new;
$curl->setopt(CURLOPT_HEADER,1);
$curl->setopt(CURLOPT_URL, 'http://example.com');
$curl->setopt(CURLOPT_WRITEDATA,\my $response_body);
# this turns on debugging a la `curl -v http://example.com`
$curl->setopt(CURLOPT_VERBOSE, 1);
my $retcode = $curl->perform;
print("Transfer went ok\n") unless $retcode;
Output:
* Trying 93.184.216.34:80...
* TCP_NODELAY set
* Connected to example.com (93.184.216.34) port 80 (#0)
> GET / HTTP/1.1
Host: example.com
Accept: */*
* Mark bundle as not supporting multiuse
< HTTP/1.1 200 OK
< Accept-Ranges: bytes
< Age: 543595
< Cache-Control: max-age=604800
< Content-Type: text/html; charset=UTF-8
< Date: Thu, 25 Nov 2021 14:20:18 GMT
< Etag: "3147526947+gzip"
< Expires: Thu, 02 Dec 2021 14:20:18 GMT
< Last-Modified: Thu, 17 Oct 2019 07:18:26 GMT
< Server: ECS (nyb/1D0F)
< Vary: Accept-Encoding
< X-Cache: HIT
< Content-Length: 1256
<
* Connection #0 to host example.com left intact
Transfer went ok
If you want something more fancy, you would have to roll your own. You can overwrite what CURLOPT_VERBOSE does by setting CURLOPT_DEBUGFUNCTION to a Perl code reference. That gets called for every line of debug output.
The signature seems to be different from what's in the documentation for libcurl, but it's possible to deduct what's going on.
$curl->setopt(CURLOPT_VERBOSE, 1);
$curl->setopt(CURLOPT_DEBUGFUNCTION, sub {
use Data::Dumper;
print Dumper \#_;
});
The first few lines of output with this set look as follows.
[
[0] " Trying 93.184.216.34:80...
",
[1] undef,
[2] 0
]
[
[0] "TCP_NODELAY set
",
[1] undef,
[2] 0
]
[
[0] "Connected to example.com (93.184.216.34) port 80 (#0)
",
[1] undef,
[2] 0
]
[
[0] "GET / HTTP/1.1
Host: example.com
Accept: */*
",
[1] undef,
[2] 2
]
The first argument seems to be the text.
According to the docs, there are a few types of debug data.
typedef enum {
CURLINFO_TEXT = 0,
CURLINFO_HEADER_IN, /* 1 */
CURLINFO_HEADER_OUT, /* 2 */
CURLINFO_DATA_IN, /* 3 */
CURLINFO_DATA_OUT, /* 4 */
CURLINFO_SSL_DATA_IN, /* 5 */
CURLINFO_SSL_DATA_OUT, /* 6 */
CURLINFO_END
} curl_infotype;
Given that the last of my examples has a 2 and all the others have a 0 as their third argument, we can assume that this must be the type.
I have not figured out what the second argument is.
This leaves us with:
$curl->setopt(CURLOPT_DEBUGFUNCTION, sub {
my ($text, undef, $type) = #_;
# ...
});
As it happens, these types have been imported as constants by WWW::Curl::Easy. So we can do something like this to only get the outgoing header.
$curl->setopt(CURLOPT_DEBUGFUNCTION, sub {
my ($text, undef, $type) = #_;
print $text if $type == CURLINFO_HEADER_OUT;
});
This'll output:
$ /usr/bin/perl foo.pl
GET / HTTP/1.1
Host: example.com
Accept: */*
Transfer went ok
The incoming headers seem to be one at a time, so you could filter.
$curl->setopt(CURLOPT_DEBUGFUNCTION, sub {
my ($text, undef, $type) = #_;
if ($type == CURLINFO_HEADER_IN && $text =~ m/Etag: "(.+)"/) {
print "Etag is $1\n";
}
});
A more involved example would be to take the entire debug output and convert it to HTTP::Request and HTTP::Response objects.
$curl->setopt(CURLOPT_WRITEDATA,\$response_body);
$curl->setopt(CURLOPT_VERBOSE, 1);
my ($req, $res);
$curl->setopt(CURLOPT_DEBUGFUNCTION, sub {
my ($text, undef, $type) = #_;
require HTTP::Request;
require HTTP::Response;
if ($type == CURLINFO_HEADER_OUT) {
$req = HTTP::Request->parse($text);
} elsif ($type == CURLINFO_DATA_OUT) {
$req->content($text);
} elsif ($type == CURLINFO_HEADER_IN) {
unless ($res) {
$res = HTTP::Response->parse($text);
$res->request($req);
return 0; # this is retcode
}
# this is from HTTP::Message
# (https://metacpan.org/dist/HTTP-Message/source/lib/HTTP/Message.pm#L60)
my #hdr;
while (1) {
if ($text =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
push(#hdr, $1, $2);
$hdr[-1] =~ s/\r\z//;
}
elsif (#hdr && $text =~ s/^([ \t].*)\n?//) {
$hdr[-1] .= "\n$1";
$hdr[-1] =~ s/\r\z//;
}
else {
$text =~ s/^\r?\n//;
last;
}
}
$res->header(#hdr) if #hdr;
} elsif ($type == CURLINFO_DATA_IN) {
$res->content($text);
}
return 0; # this is retcode
});
This will give you an HTTP::Request and an HTTP::Response object each containing all headers and content. Not sure if that's useful, but it's a good demo of what is possible with this function.
Disclaimer: I am a maintainer of libwww-perl.

Related

Unable to post messages using Mailbox API and Mojo::UserAgent

According to the API docs (https://documentation.mailgun.com/api-sending.html) all the relevant parameters are supplied, but it gives me
400 response: BAD REQUEST
Here's my piece of code:
#!/usr/bin/perl
use Mojo::UserAgent;
use MIME::Base64;
use JSON qw(to_json);
use strict;
use warnings;
use v5.10;
my $ua = Mojo::UserAgent->new;
my $endpoint = 'https://api.mailgun.net/v3/sandbox2ad5b70fd744416ea7ff3d5422YYYYYY.mailgun.org/messages';
my $key = 'key-d3d8d350d4ef9c92349df62208XXXXXX';
my $headers = { 'Authorization' => 'Basic ' . encode_base64('api:' . $key) };
my $params = {
'to' => 'abc#domain.ru',
'subject' => 'testing',
'text' => 'some text',
'from' => 'postmaster#sandbox2ad5b70fd744416ea7ff3d5422YYYYYY.mailgun.org'
};
my $tx = $ua->post($endpoint, $headers, json => $params);
my $res = $tx->success;
if ($res) {
say $res->body;
} else {
my $err = $tx->error;
die "$err->{code} response: $err->{message}" if $err->{code};
die "Connection error: $err->{message}";
}
I have Mojo version as follows:
CORE
Perl (v5.22.1, linux)
Mojolicious (7.26, Doughnut)
OPTIONAL
EV 4.0+ (4.22)
IO::Socket::Socks 0.64+ (0.67)
IO::Socket::SSL 1.94+ (2.024)
Net::DNS::Native 0.15+ (n/a)
I wrote another version of this script using LWP::UserAgent and it works fine.
Are there some Mojo::UserAgent experts who might have an idea of what is wrong with the script?
UPDATED
Here's my LWP::UserAgent version which works without problems:
my ($key, $domain, $from, $from_name, $to, $subject, $comments) = #_;
my $url = 'https://api.mailgun.net/v3';
$url = $url . '/' . $domain . '/messages';
my $ua = LWP::UserAgent->new;
$ua->default_header('Authorization' => 'Basic ' . encode_base64('api:' . $key));
my $data = {
to => $to,
subject => $subject,
text => $comments,
from => $from_name . '<' . $from . '>'
};
my $r = $ua->post($url, Content => $data);
my $rc = $r->code;
if ($rc == 200) {
my $hash = from_json($r->decoded_content);
say $hash->{id};
say $hash->{message};
} else {
return { error => $rc };
}
UPDATED ON 25.02.2017
I used fake requests to my localhost:9000. Here's what I've traced using nc -l 9000:
POST / HTTP/1.1
TE: deflate,gzip;q=0.3
Connection: TE, close
Authorization: Basic YXBpOmtleS1kM2Q4ZDM1MGQ0ZWY5YzkyMzQ5ZGY2MjIwOGRXXXXXX==
Host: localhost:9000
User-Agent: libwww-perl/6.15
Content-Length: 144
Content-Type: application/x-www-form-urlencoded
text=%3Chtml%3E%3Cbody%3E%3Cp%3Etest%3C%2Fp%3E%3C%2Fbody%3E%3C%2Fhtml%3E&from=John%3Clala%40ya.ru%3E&to=zozoba29a%40yandex.ru&subject=My+Subject
And:
POST / HTTP/1.1
Host: localhost:9000
Accept-Encoding: gzip
Content-Type: application/x-www-form-urlencoded
Authorization: Basic YXBpOmtleS1kM2Q4ZDM1MGQ0ZWY5YzkyMzQ5ZGY2MjIwOGRjXXXXXX==
Content-Length: 144
User-Agent: Mojolicious (Perl)
from=John%3Clala%40ya.ru%3E&subject=My+Subject&text=%3Chtml%3E%3Cbody%3E%3Cp%3Etest%3C%2Fp%3E%3C%2Fbody%3E%3C%2Fhtml%3E&to=zozoba29a%40yandex.ru

Mailchimp v3.0 API, using Perl Curl

I'm trying to find a way to do a Curl request to MailChimps new API v3.0, that will subscribe a user to a given list. Here is what I have thus far:
use warnings;
use WWW::Curl::Easy;
use JSON;
my $apikey = 'xxxx';
my $listid = 'xxxx';
my $email = 'andy#test.co.uk';
my $endpoint = "https://us6.api.mailchimp.com/3.0/lists";
my $json = JSON::encode_json([
'email_address' => $email,
'status' => 'pending',
'merge_fields' => [
'FNAME' => "andy",
'LNAME' => "newby"
]
]);
my $curl = WWW::Curl::Easy->new;
my $url = "$endpoint/$listid/members/" . Digest::MD5::md5(lc($email));
$curl->setopt(CURLOPT_HEADER,1);
$curl->setopt(CURLOPT_URL, $endpoint);
$curl->setopt(CURLOPT_USERPWD, 'user:' . $apikey);
$curl->setopt(CURLOPT_HTTPHEADER, ['Content-Type: application/json']);
$curl->setopt(CURLOPT_TIMEOUT, 10);
$curl->setopt(CURLOPT_CUSTOMREQUEST, 'PUT');
$curl->setopt(CURLOPT_SSL_VERIFYPEER, 0);
$curl->setopt(CURLOPT_POSTFIELDS, $json);
my $response_body;
$curl->setopt(CURLOPT_WRITEDATA,\$response_body);
# Starts the actual request
my $retcode = $curl->perform;
# Looking at the results...
if ($retcode == 0) {
print("Transfer went ok\n");
my $response_code = $curl->getinfo(CURLINFO_HTTP_CODE);
print "Received response: $response_body\n";
} else {
# Error code, type of error, error message
print "An error happened: $retcode ".$curl->strerror($retcode)." ".$curl->errbuf."\n";
}
The documentation is pretty scarce, due to it being a new API. Has anyone had any success with the MailChimp v3 API, for subscribing someone in Perl? (I'm also open to suggestions for command line curl requests... but everything I tried with regards to that, failed with "internal server errors" coming back from MailChimp, which wasn't very helpful)
UPDATE: As suggested below, I enabled verbose, and it now spits out:
Hostname was NOT found in DNS cache
Trying 184.86.100.251...
Connected to us6.api.mailchimp.com (184.86.100.251) port 443 (#0)
successfully set certificate verify locations:
CAfile: none CApath: /etc/ssl/certs
SSL connection using TLSv1.2 / ECDHE-RSA-AES128-GCM-SHA256
Server certificate:
subject: C=US; ST=GA; L=Atlanta; O=ROCKET SCIENCE GROUP; OU=Rocket Science Group; CN=*.api.mailchimp.com
start date: 2015-09-22 14:39:14 GMT
expire date: 2016-09-22 14:39:13 GMT
subjectAltName: us6.api.mailchimp.com matched
issuer: C=NL; L=Amsterdam; O=Verizon Enterprise Solutions; OU=Cybertrust; CN=Verizon Akamai SureServer CA G14-SHA2
SSL certificate verify ok.
Server auth using Basic with user 'user'
PUT /3.0/lists HTTP/1.1 Authorization: Basic xxxx Host: us6.api.mailchimp.com Accept: / Content-Type: application/json
Content-Length: 108
upload completely sent off: 108 out of 108 bytes < HTTP/1.1 405 Method Not Allowed
Server nginx is not blacklisted < Server: nginx < Content-Type: application/problem+json; charset=utf-8 < Content-Length: 253 <
X-Request-Id: 5f6ab08f-69e7-4c9b-b22a-91714331d5b7 < Link:
https://us6.api.mailchimp.com/schema/3.0/ProblemDetailDocument.json;
rel="describedBy" < Allow: GET, POST < Date: Tue, 13 Oct 2015 11:24:32
GMT < Connection: close < Set-Cookie: _AVESTA_ENVIRONMENT=prod; path=/
<
Closing connection 0 Transfer went ok Received response: HTTP/1.1 405 Method Not Allowed Server: nginx Content-Type:
application/problem+json; charset=utf-8 Content-Length: 253
X-Request-Id: 5f6ab08f-69e7-4c9b-b22a-91714331d5b7 Link:
https://us6.api.mailchimp.com/schema/3.0/ProblemDetailDocument.json;
rel="describedBy" Allow: GET, POST Date: Tue, 13 Oct 2015 11:24:32 GMT
Connection: close Set-Cookie: _AVESTA_ENVIRONMENT=prod; path=/
{"type":"http://kb.mailchimp.com/api/error-docs/405-method-not-allowed","title":"Method
Not Allowed","status":405,"detail":"The requested method and resource
are not compatible. See the Allow header for this resource's available
methods.","instance":""}
I'm not really sure what to make of that though :/
Working code: Thanks to TooMuchPete, I managed to get it going. For anyone who may come across this while trying to use the MailChimp API (3.0) in Perl, below is a working sample (you just need to replace the values of the email, name, api key, and list id);
use WWW::Curl::Easy;
use JSON;
use Digest::MD5;
my $apikey = 'xxxx-us6';
my $listid = 'xxxx';
my $email = 'andy#testr.co.uk';
my $endpoint = "https://us6.api.mailchimp.com/3.0/lists";
my $json = JSON::encode_json({
'email_address' => $email,
'status' => 'pending',
'merge_fields' => {
'FNAME' => "andy",
'LNAME' => "newby"
}
});
my $curl = WWW::Curl::Easy->new;
my $url = "$endpoint/$listid/members/" . Digest::MD5::md5(lc($email));
$curl->setopt(CURLOPT_HEADER,1);
$curl->setopt(CURLOPT_URL, $url);
$curl->setopt(CURLOPT_VERBOSE, 1);
$curl->setopt(CURLOPT_USERPWD, 'user:' . $apikey);
$curl->setopt(CURLOPT_HTTPHEADER, ['Content-Type: application/json']);
$curl->setopt(CURLOPT_TIMEOUT, 10);
$curl->setopt(CURLOPT_CUSTOMREQUEST, 'PUT');
$curl->setopt(CURLOPT_SSL_VERIFYPEER, 0);
$curl->setopt(CURLOPT_POSTFIELDS, $json);
# A filehandle, reference to a scalar or reference to a typeglob can be used here.
my $response_body;
$curl->setopt(CURLOPT_WRITEDATA,\$response_body);
# Starts the actual request
my $retcode = $curl->perform;
# Looking at the results...
if ($retcode == 0) {
print("Transfer went ok\n");
my $response_code = $curl->getinfo(CURLINFO_HTTP_CODE);
# judge result and next action based on $response_code
print "Received response: $response_body\n";
} else {
# Error code, type of error, error message
print "An error happened: $retcode ".$curl->strerror($retcode)." ".$curl->errbuf."\n";
}
I hope this saves someone the grief I had :)
You're attempting to connect to $endpoint instead of $url.
my $url = "$endpoint/$listid/members/" . Digest::MD5::md5(lc($email));
$curl->setopt(CURLOPT_HEADER,1);
$curl->setopt(CURLOPT_URL, $endpoint);
should be:
my $url = "$endpoint/$listid/members/" . Digest::MD5::md5(lc($email));
$curl->setopt(CURLOPT_HEADER,1);
$curl->setopt(CURLOPT_URL, $url);
I received an illegal characters response from MailChimp using the code above until I switched to the md5_base64() call.

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;
};

Form a CURL request to PayMill in Perl

I'm out of my depth with curl.
I want to integrate PayMill into my site (which is written in Perl).
There isn't a Perl lib for Paymill yet, so I need to connect to them via curl.
I have completed the front end JS Paymill integration, and received a payment token from PayMill.
I now need to pass the token received from Paymill to my backend and use curl to ask PayMill to complete the transaction and charge the user.
At this point I'm stuck.
To make a transaction, the PayMill documentation says that I must do the following:
curl https://api.paymill.de/v2/transactions \
-u b94a7550bd908877cbae5d3cf0dc4b74: \
-d "amount=4200" \
-d "currency=EUR" \
-d "token=098f6bcd4621d373cade4e832627b4f6" \
-d "description=Test Transaction"
I believe -u is the Paymill secret key to authenticate my request although the documentation is not clear here.
I've had a look at WWW::Curl::Easy, Net:Curl::Easy and LWP::Curl, however nothing in the documentation for those methods makes it obvious to me how to form the query above.
I've tried (without really believing it would work), simply encoding a string in perl as described above;
my $request = '-u ' . $private_key . " ";
foreach my $key (keys %$params_in) {
$request .= '-d "' . lc($key) .'='.$params_in->{$key} . ' ';
}
And then passing $request to my attempt at curl as follows;
my $curl = WWW::Curl::Easy->new;
$curl->setopt(WWW::Curl::Easy::CURLOPT_HEADER(), 1);
$curl->setopt(WWW::Curl::Easy::CURLOPT_URL(), $paymill_server);
$curl->setopt(WWW::Curl::Easy::CURLOPT_POST(), 1);
$curl->setopt(WWW::Curl::Easy::CURLOPT_POSTFIELDS(), $request);
my $response;
$curl->setopt(WWW::Curl::Easy::CURLOPT_WRITEDATA(), \$response);
my $retcode = $curl->perform;
however that fails with an Access Denied error, which I assume is because Paymill is not finding my key because I'm messing up the Curl (assuming -u is supposed to be the secret_key).
I feel I'm missing something obvious here.
Could someone point me in the right direction re how to do this?
Thanks
UPDATE
Excellent answers, thanks everyone for your help, it's working now. I went with Matthias's solution in the end and the final complete solution for making a transaction looked as follows;
use LWP::UserAgent;
use MIME::Base64;
use JSON::XS;
my $ua = LWP::UserAgent->new;
$ua->default_header(Authorization => "Basic " . encode_base64(private_key));
my $response = $ua->post(https://api.paymill.de:443/v2/transactions , $params );
if ( $response->is_success ) {
my $obj = eval { decode_json $response->content } || {};
etc
}
Like other answers propose the best way would be using LWP::UserAgent for doing the requests.
Edit: Since PAYMILL is sending challenge responses since a while now I updated the code.
Since Paymill doesn't comply with RFC 2616, Section 14.47 (the API isn't sending a challenge response) LWP::UserAgent and similar are failing in sending a second request with the credentials. The solution is to "force" LWP::UserAgent to send the credentials with the first request by adding them as header:
use LWP::UserAgent;
use MIME::Base64;
my $ua = LWP::UserAgent->new;
# Use the following line no longer:
# $ua->default_header(Authorization => "Basic " . encode_base64("your PRIVATE key"))
$ua->credentials('api.paymill.de:443', '', 'YOUR PRIVATE KEY');
# Dumping only
use Data::Dumper;
print Dumper($ua->get("https://api.paymill.de:443/v2/clients"));
Disclosure: I work at Paymill.
I don't know if the authentication part with the user/password and your token is correct as I don't know what the 'Realm' is supposed to be. Still, have a go with LWP. It's not that I don't like Curl, I just don't know it, but I do know LWP.
use strict; use warnings;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
$ua->credentials(
'api.paymill.de:80',
'Realm?',
'b94a7550bd908877cbae5d3cf0dc4b74'
);
my $response = $ua->post(
' https://api.paymill.de/v2/transactions',
{
amount => "4200",
currency => "EUR",
token => "098f6bcd4621d373cade4e832627b4f6",
description => "Test Transaction",
}
);
if ( $response->is_success ) {
print $response->decoded_content; # or whatever
} else {
die $response->status_line;
}
Edit: I read a little in the Paymill documentation. It says:
Authentication
Example
% curl https://api.paymill.de/v2/clients \
-u e73fa5e7b87620585b5ea5d73c4d23bb:
To authenticate at the Paymill API, you need the private key of your
test or live account. You have to use http basic access
authentification. Your key has to be set as the username. A password
isn’t required and you don’t have to insert one. But if you want, feel
free to insert an arbitrary string.
Note
Please keep your private keys secure and don’t pass them to anybody. These private keys have extreme secure information for
handling the transactions of your shop.
All your requests must be made via https. Requests which will be made in another way will fail. This is for security reasons of the
submitted data.
There is also a link to http://en.wikipedia.org/wiki/HTTP_Secure, which clears up the -u part pretty much I believe.
You can use LWP::Protocol::Net::Curl to integrate LWP and libcurl organically. Check this:
#!/usr/bin/env perl
use common::sense;
use Data::Printer;
use JSON::XS;
use LWP::Protocol::Net::Curl verbose => 1;
use LWP::UserAgent;
# create user agent
my $ua = LWP::UserAgent->new;
# POST request
my $res = $ua->post(
'https://b94a7550bd908877cbae5d3cf0dc4b74:#api.paymill.de/v2/transactions',
'Accept-Encoding' => 'gzip',
Content => {
amount => 4200,
currency => 'EUR',
token => '098f6bcd4621d373cade4e832627b4f6',
description => 'Test Transaction',
},
);
# parse received data
my $obj = eval { decode_json $res->content } // {};
# output
p $obj;
The output:
* About to connect() to api.paymill.de port 443 (#0)
* Trying 62.138.241.3...
* Connected to api.paymill.de (62.138.241.3) port 443 (#0)
* Connected to api.paymill.de (62.138.241.3) port 443 (#0)
* successfully set certificate verify locations:
* CAfile: /etc/ssl/certs/ca-certificates.crt
CApath: none
* SSL connection using RC4-SHA
* Server certificate:
* subject: OU=Domain Control Validated; OU=PositiveSSL Wildcard; CN=*.paymill.de
* start date: 2012-07
* expire date: 2013-10
* subjectAltName: api.paymill.de matched
* issuer: C=GB; S
* SSL certificate verify ok.
* Server auth using Basic with user 'b94a7550bd908877cbae5d3cf0dc4b74'
> POST /v2/transactions HTTP/1.1
Authorization: Basic Yjk0YTc1NTBiZDkwODg3N2NiYWU1ZDNjZjBkYzRiNzQ6
User-Agent: libwww-perl/6.04 libcurl/7.28.0 OpenSSL/1.0.0e zlib/1.2.3.4 libidn/1.22 libssh2/1.2.8
Host: api.paymill.de
Accept: */*
Accept-Encoding: gzip
Content-Length: 92
Content-Type: application/x-www-form-urlencoded
* upload completely sent off: 92 out of 92 bytes
< HTTP/1.1 200 OK
< Server: nginx
< Date: Wed, 09 Jan 2013 17:22:54 GMT
< Content-Type: application/json
< Transfer-Encoding: chunked
< Connection: close
< Set-Cookie: PHPSESSID=rmdo5a8c6u107gma28lotmmn24; path=/
< Expires: Thu, 19 Nov 1981 08:52:00 GMT
< Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0
< Pragma: no-cache
< X-Server: hrtt-frn5-de13
<
* Closing connection #0
Printing in line 28 of paymill.pl:
\ {
data {
amount 4200,
client {
created_at 1357752174,
description undef,
email undef,
id "client_85cb0bfc837f31c81015",
payment [],
subscription undef,
updated_at 1357752174
},
created_at 1357752174,
currency "EUR",
description "Test Transaction",
id "tran_c672daa0538e2a04e919",
livemode false,
origin_amount 4200,
payment {
card_holder undef,
card_type "visa",
client "client_85cb0bfc837f31c81015",
country undef,
created_at 1357752174,
expire_month 12,
expire_year 2014,
id "pay_2732689f44928301c769",
last4 1111,
type "creditcard",
updated_at 1357752174
},
preauthorization undef,
refunds undef,
status "closed",
updated_at 1357752174
},
mode "test"
}

How to post non-latin1 data to non-UTF8 site using perl?

I want to post russian text on a CP1251 site using LWP::UserAgent and get following results:
# $text="Русский текст"; obtained from command line
FIELD_NAME => $text # result: Г?в г'В?г'В?г'В?г?вєг?вёг?в? Г'В'Г?вчг?вєг'В?г'В'
$text=Encode::decode_utf8($text);
FIELD_NAME => $text # result: Р с?с?с?рєрёр? С'Рчрєс?с'
FIELD_NAME => Encode::encode("cp1251", $text) # result: Г?гіг+г+гЄгёгЏ ГІгҐгЄг+гІ
FIELD_NAME => URI::Escape::uri_escape_utf8($text) # result: D0%a0%d1%83%d1%81%d1%81%d0%ba%d0%b8%d0%b9%20%d1%82%d0%b5%d0%ba%d1%81%d1%82
How can I do this? Content-Type must be x-www-form-urlencoded. You can find similar form here, but there you can just escape any non-latin character using &#...; form, trying to escape it in FIELD_NAME results in 10561091108910891 10901077108210891 (every &, # and ; stripped out of the string) or 1056;усский текст (punctuation characters at the beginning of the string are stripped out) depending on what the FIELD_NAME actually is.
UPDATE: Anybody knows how to convert the following code so that it will use LWP::UserAgent::post function?
my $url=shift;
my $fields=shift;
my $request=HTTP::Request->new(POST => absURL($url));
$request->content_type('application/x-www-form-urlencoded');
$request->content_encoding("UTF-8");
$ua->prepare_request($request);
my $content="";
for my $k (keys %$fields) {
$content.="&" if($content ne "");
my $c=$fields->{$k};
eval {$c=Encode::decode_utf8($c)};
$c=Encode::encode("cp1251", $c, Encode::FB_HTMLCREF);
$content.="$k=".URI::Escape::uri_escape($c);
}
$request->content($content);
my $response=$ua->simple_request($request);
This code actually solves the problem, but I do not want to add the third request wrapper function (alongside with get and post).
One way around it appears to be (far from the best, I think) to use recode system command if you have it avialable. From http://const.deribin.com/files/SignChanger.pl.txt
my $boardEncoding="cp1251"; # encoding used by the board
$vals{'Post'} = `fortune $forunePath | recode utf8..$boardEncoding`;
$res = $ua->post($formURL,\%vals);
Another approach seems to be in http://mail2lj.nichego.net/lj.txt
my $formdata = $1 ;
my $hr = ljcomment_string2form($formdata) ;
my $req = new HTTP::Request('POST' => $ljcomment_action)
or die "new HTTP::Request(): $!\n" ;
$hr->{usertype} = 'user' ;
$hr->{encoding} = $mh->mime_attr('content-type.charset') ||
"cp1251" ;
$hr->{subject} = decode_mimewords($mh->get('Subject'));
$hr->{body} = $me->bodyhandle->as_string() ;
$req->content_type('application/x-www-form-urlencoded');
$req->content(href2string($hr)) ;
my $ljres = submit_request($req, "comment") ;
if ($ljres->{'success'} eq "OK") {
print STDERR "journal updated successfully\n" ;
} else {
print STDERR "error updating journal: $ljres->{errmsg}\n" ;
send_bounce($ljres->{errmsg}, $me, $mh->mime_attr("content-type.charset")) ;
}
Use WWW::Mechanize, it takes care of encoding (both character encoding and form encoding) automatically and does the right thing if a form element's accept-charset attribute is set appropriately. If it's missing, the form defaults to UTF-8 and thus needs correction. You seem to be in this situation. By the way, your example site's encoding is KOI8-R, not Windows-1251. Working example:
use utf8;
use WWW::Mechanize qw();
my $message = 'Русский текст';
my $mech = WWW::Mechanize->new(
cookie_jar => {},
agent => 'Mozilla/5.0 (X11; U; Linux x86_64; en-US) AppleWebKit/533.9 SUSE/6.0.401.0-2.1 (KHTML, like Gecko)',
);
$mech->get('http://zhurnal.lib.ru/cgi-bin/comment?COMMENT=/z/zyx/index_4-1');
$mech->current_form->accept_charset(scalar $mech->response->content_type_charset);
$mech->submit_form(with_fields => { TEXT => $message });
HTTP dump (essential parts only):
POST /cgi-bin/comment HTTP/1.1
Content-Length: 115
Content-Type: application/x-www-form-urlencoded
FILE=%2Fz%2Fzyx%2Findex_4-1&MSGID=&OPERATION=store_new&NAME=&EMAIL=&URL=&TEXT=%F2%D5%D3%D3%CB%C9%CA+%D4%C5%CB%D3%D
These functions solve the issue (first for posting application/x-www-form-urlencoded data and second for multipart/form-data):
#{{{2 postue
sub postue($$;$) {
my $url=shift;
my $fields=shift;
my $referer=shift;
if(defined $referer and $referer eq "" and defined $fields->{"DIR"}) {
$referer=absURL($url."?DIR=".$fields->{"DIR"}); }
else {
$referer=absURL($referer); }
my $request=HTTP::Request->new(POST => absURL($url));
$request->content_type('application/x-www-form-urlencoded');
$request->content_encoding("UTF-8");
$ua->prepare_request($request);
my $content="";
for my $k (keys %$fields) {
$content.="&" if($content ne "");
my $c=$fields->{$k};
if(not ref $c) {
$c=Encode::decode_utf8($c) unless Encode::is_utf8($c);
$c=Encode::encode("cp1251", $c, Encode::FB_HTMLCREF);
$c=URI::Escape::uri_escape($c);
}
elsif(ref $c eq "URI::URL") {
$c=$c->canonical();
$c=URI::Escape::uri_escape($c);
}
$content.="$k=$c";
}
$request->content($content);
$request->referer($referer) if(defined $referer);
my $i=0;
print STDERR "Doing POST request to url $url".
(($::o_verbose>2)?(" with fields:\n".
::YAML::dump($fields)):("\n"))
if($::o_verbose>1);
REQUEST:
my $response=$ua->simple_request($request);
$i++;
my $code=$response->code;
if($i<=$o_maxtries and 500<=$code and $code<600) {
print STDERR "Failed to request $url with code $code... retrying\n"
if($::o_verbose>2);
sleep $o_retryafter;
goto REQUEST;
}
return $response;
}
#{{{2 postfd
sub postfd($$;$) {
my $url=absURL(shift);
my $content=shift;
my $referer=shift;
$referer=absURL($referer) if(defined $referer);
my $i=0;
print STDERR "Doing POST request (form-data) to url $url".
(($::o_verbose>2)?(" with fields:\n".
::YAML::dump($content)):("\n"))
if($::o_verbose>1);
my $newcontent=[];
while(my ($f, $c)=splice #$content, 0, 2) {
if(not ref $c) {
$c=Encode::decode_utf8($c) unless Encode::is_utf8($c);
$c=Encode::encode("cp1251", $c, Encode::FB_HTMLCREF);
}
push #$newcontent, $f, $c;
}
POST:
my $response=$ua->post($url, $newcontent,
Content_type => "form-data",
((defined $referer)?(referer => $referer):()));
$i++;
my $code=$response->code;
if($i<=$o_maxtries and 500<=$code and $code<600) {
print STDERR "Failed to download $url with code $code... retrying\n"
if($::o_verbose>2);
sleep $o_retryafter;
goto POST;
}
return $response;
}