I was previously using reCAPTCHA V1 in conjunction with FormMail.cgi from Matt's Script Archive, with the following Perl function to validate the reCAPTCHA response:
sub check_captcha {
my $ua = LWP::UserAgent->new();
my $result=$ua->post(
'http://www.google.com/recaptcha/api/verify',
{
privatekey => 'MyPrivateKey',
remoteip => $ENV{'REMOTE_ADDR'},
challenge => $Form{'recaptcha_challenge_field'},
response => $Form{'recaptcha_response_field'}
}
);
if ( $result->is_success && $result->content =~ /^true/) {
return;
} else {
&error('captcha_failed');
}
}
reCAPTCHA V1 is shutting down at the end of March 2018 and so I need to move to reCAPTCHA V2, however, I'm having trouble validating the response in the CGI script.
Based on the server side documentation, here is what I've tried so far (without success):
sub check_captcha {
my $ua = LWP::UserAgent->new();
my $result=$ua->post(
'https://www.google.com/recaptcha/api/siteverify',
{
secret => 'MyPrivateKey',
remoteip => $ENV{'REMOTE_ADDR'},
response => $Form{'g-recaptcha-response'}
}
);
if ( $result->is_success && $result->content =~ /"success": true/ ) {
return;
} else {
&error('captcha_failed');
}
}
The above always branches to the 'captcha_failed' error.
Thank you in advance for your time reading my question, I appreciate any assistance the community could offer.
Many thanks!
I can't see any obvious problems with your code. But I wonder why you're implementing this yourself when Google::reCAPTCHA exists.
use Google::reCAPTCHA;
my $c = Google::reCAPTCHA->new( secret => 'MyPrivateKey' );
# Verifying the user's response
my $success = $c->siteverify(
response => $Form{'g-recaptcha-response'},
remoteip => $ENV{'REMOTE_ADDR'},
);
if ( $success ) {
# CAPTCHA was valid
}
And why are you using code from Matt's Script Archive?
Related
I am trying to create a slack application in Perl with mojolicious and I am having the following use case:
Slack sends a request to my API from a slash command and needs a response in a 3 seconds timeframe. However, Slack also gives me the opportunity to send up to 5 more responses in a 30 minute timeframe but still needs an initial response in 3 seconds (it just sends a "late_response_url" in the initial call back so that I could POST something to that url later on). In my case I would like to send an initial response to slack to inform the user that the operation is "running" and after a while send the actual outcome of my slow function to Slack.
Currently, I can do this by spawning a second process using fork() and using one process to respond imidiately as Slack dictates and the second to do the rest of the work and respond later on.
I am trying to do this with Mojolicious' subprocesses to avoid using fork(). However I can't find a way to get this to work....
a sample code of what I am already doing with fork is like this:
sub withpath
{
my $c = shift;
my $user = $c->param('user_name');
my $response_body = {
response_type => "ephemeral",
text => "Running for $user:",
attachments => [
{ text => 'analyze' },
],
};
my $pid = fork();
if($pid != 0){
$c->render( json => $response_body );
}else{
$output = do_time_consuming_things()
$response_body = {
response_type => "in-channel",
text => "Result for $user:",
attachments => [
{ text => $output },
],
};
my $ua = Mojo::UserAgent->new;
my $tx = $ua->post(
$response_url,
{ Accept => '*/*' },
json => $response_body,
);
if( my $res = $tx->success )
{
print "\n success \n";
}
else
{
my $err = $tx->error;
print "$err->{code} response: $err->{message}\n" if $err->{code};
print "Connection error: $err->{message}\n";
}
}
}
So the problem is that no matter how I tried I couldn't replicate the exact same code with Mojolicious' subproccesses. Any ideas?
Thanks in advance!
Actually I just found a solution to my problem!
So here is my solution:
my $c = shift; #receive request
my $user = $c->param('user_name'); #get parameters
my $response_url = $c->param('response_url');
my $text = $c->param('text');
my $response_body = { #create the imidiate response that Slack is waiting for
response_type => "ephemeral",
text => "Running for $user:",
attachments => [
{ text => 'analyze' },
],
};
my $subprocess = Mojo::IOLoop::Subprocess->new; #create the subprocesses
$subprocess->run(
sub {do_time_consuming_things($user,$response_url,$text)}, #this callback is the
#actuall subprocess that will run in background and contains the POST request
#from my "fork" code (with the output) that should send a late response to Slack
sub {# this is a dummy subprocess doing nothing as this is needed by Mojo.
my ($subprocess, $err, #results) = #_;
say $err if $err;
say "\n\nok\n\n";
}
);
#and here is the actual imidiate response outside of the subprocesses in order
#to avoid making the server wait for the subprocess to finish before responding!
$c->render( json => $response_body );
So I actually simply had to put my code of do_time_consuming_things in the first callback (in order for it to run as a subprocess) and use the second callback (that is actually linked to the parent process) as a dummy one and keep my "imidiate" response in the main body of the whole function instead of putting it inside one of the subprocesses. See code comments for more information!
How can you convert from multiple currencies, using the PayPal API (Adaptive Payments) system? The documents only have stuff for Ruby, iOS, PHP, Rails etc... but not Perl!
https://developer.paypal.com/docs/classic/api/adaptive-payments/ConvertCurrency_API_Operation/
This is only meant as a guideline (to run in command line). It will run via the browser, but you need to add in a header (otherwise it'll give a 500 Internal Server Error)
The perl code is as follows:
currency.cgi
#!/usr/bin/perl
use warnings;
use strict;
use HTTP::Request::Common;
use LWP::UserAgent;
my $user = 'your PayPal API username';
my $password = 'your PayPal API password';
my $signature = 'your PayPal API signature';
my $application_id = 'APP-80W284485P519543T'; # this is the sandbox app ID... so you would just change this to your own app-id when going live
my #currencies = qw/GBP EUR CHF USD AUD/; # Enter all the currency codes you want to convert here
my $url = 'https://svcs.sandbox.paypal.com/AdaptivePayments/ConvertCurrency'; # remove the "sandbox." part of this URL, when its ready to go live...
my $ua = LWP::UserAgent->new();
my $headers = HTTP::Headers->new(
'X-PAYPAL-SECURITY-USERID' => $user,
'X-PAYPAL-SECURITY-PASSWORD' => $password,
'X-PAYPAL-SECURITY-SIGNATURE' => $signature,
'X-PAYPAL-APPLICATION-ID' => $application_id,
'X-PAYPAL-DEVICE-IPADDRESS' => $ENV{REMOTE_ADDR},
'X-PAYPAL-REQUEST-DATA-FORMAT' => 'JSON',
'X-PAYPAL-RESPONSE-DATA-FORMAT' => 'JSON'
);
foreach (#currencies) {
print qq|\nGetting exchange rates for $_.... \n|;
my ($status,$vals) = get_converted_amounts($_);
if ($vals->{error}) {
print qq|There was an error: $vals->{error}\n|;
exit;
} else {
print qq|Got conversion rates of:\n|;
foreach (#currencies) {
if ($vals->{$_}) {
print qq|\t$_ => $vals->{$_}\n|;
}
}
}
}
sub get_converted_amounts {
my ($currency_from) = #_;
my #currencies_to_grab;
foreach (#currencies) {
next if $_ eq $currency_from; # We dont wanna bother asking it to convert from this currency, into this currency =)
push #currencies_to_grab, $_;
}
my $json_var = {
requestEnvelope => {
detailLevel => "ReturnAll",
errorLanguage => "en_US",
},
baseAmountList => [{ 'currency' => { 'code' => $currency_from, 'amount' => 1 } }],
convertToCurrencyList => [{ currencyCode => \#currencies_to_grab }]
};
use JSON;
my $new_json = JSON::to_json($json_var);
my $request = HTTP::Request->new( 'POST', $url, $headers, $new_json );
my $response = $ua->request( $request );
my $json_returned = decode_json($response->decoded_content);
if ($json_returned->{error}[0]) {
return (0, { error => "There was an error: $json_returned->{error}[0]->{message} ($json_returned->{error}[0]->{errorId}) " });
}
my $vals;
foreach (#{$json_returned->{estimatedAmountTable}->{currencyConversionList}[0]->{currencyList}->{currency}}) {
$vals->{$_->{code}} = $_->{amount};
}
return (1,$vals);
}
Running it:
You would simply run it via SSH/Telnet, with:
perl /path/to/script/currency.cgi
You can play around with the currency codes (be sure to only use the currencyCode values found here: https://developer.paypal.com/docs/classic/api/adaptive-payments/ConvertCurrency_API_Operation/, as these are the only ones that are supported)
Although this converts from a given currency into the other related currencies (good if you want to run the script every couple of hours, and store the conversion rates) - it wouldn't be hard to tweak it so you can do:
convert(from_currency,to_currency,amount)
Hopefully this will save someone a bit of time (as I spent almost a day trying to get this going)
I am looking for a clean and simple example of how to use the "under" functionality in a "Mojolicious" application. All the examples I find are dealing with "Mojolicious::Lite" (which I don't use).
For example I listened to the screencast here http://mojocasts.com/e3 and I think I understand the concept of the under functionality. But I don't use "Mojolicious::Lite", so it seems that I can't follow the example directly. I keep on failing trying to adopt the Lite-example for non-Lite style. (That's probably also because I'm still kind of new to the framework)
The relevant code looks like this:
# Router
my $r = $self->routes;
# Normal route to controller
$r->get('/') ->to('x#a');
$r->get('/y')->to('y#b');
$r->any('/z')->to('z#c');
So all of this routes need to be protected by user/pass. I tried to do something like this:
$r->under = sub { return 1 if ($auth) };
But this does not compile and I just can't find an example matching this code-style...
Can anybody give me the right hint or link here?
And please forgive me if this is somewhere in the docs... they might be complete, but they lack understandable examples for simple minded guys like me :-P
The analogous code to the Lite-examples looks like this:
# Router
my $r = $self->routes;
# This route is public
$r->any('/login')->to('login#form');
# this sub does the auth-stuff
# you can use stuff like: $self->param('password')
# to check user/pw and return true if fine
my $auth = $r->under( sub { return 1 } );
# This routes are protected
$auth->get ('/') ->to('x#a');
$auth->post('/y')->to('y#b');
$auth->any ('/z')->to('z#c');
Hopes this helps anybody!
(Solution found here: http://mojolicio.us/perldoc/Mojolicious/Routes/Route#under)
I am doing it like this - in a full mojo (not lite) app:
in the startup method
$self->_add_routes_authorization();
# only users of type 'cashier' will have access to routes starting with /cashier
my $cashier_routes = $r->route('/cashier')->over( user_type => 'cashier' );
$cashier_routes->route('/bank')->to('cashier#bank');
# only users of type 'client' will have access to routes starting with /user
my $user_routes = $r->route('/user')->over( user_type => 'client' );
$user_routes->get('/orders')->to('user#orders');
below in the main app file:
sub _add_routes_authorization {
my $self = shift;
$self->routes->add_condition(
user_type => sub {
my ( $r, $c, $captures, $user_type ) = #_;
# Keep the weirdos out!
# $self->user is the current logged in user, as a DBIC instance
return
if ( !defined( $self->user )
|| $self->user->user_type()->type() ne $user_type );
# It's ok, we know him
return 1;
}
);
return;
}
I hope this helps
I use this scenario in my application:
my $guest = $r->under->to( "auth#check_level" );
my $user = $r->under->to( "auth#check_level", { required_level => 100 } );
my $admin = $r->under->to( "auth#check_level", { required_level => 200 } );
$guest->get ( '/login' )->to( 'auth#login' );
$user ->get ( '/users/profile' )->to( 'user#show' );
After this all children routes of $r will go over check_level subroutine:
sub check_level {
my( $self ) = #_;
# GRANT If we do not require any access privilege
my $rl = $self->stash->{ required_level };
return 1 if !$rl;
# GRANT If logged in user has required level OR we raise user level one time
my $sl = $self->session->{ user_level };
my $fl = $self->flash( 'user_level' );
return 1 if $sl >= $rl || $fl && $fl >= $rl;
# RESTRICT
$self->render( 'auth/login', status => 403 );
return 0;
}
Here is my authentication logic:
sub user_logon {
my ($dbh, $cgi, $cache, $logout) = #_;
#use Log::Log4perl qw(:easy);
#Log::Log4perl->easy_init($DEBUG);
my $session = new CGI::Session("driver:MySQL", $cgi, {Handle=>$dbh});
$session->expires("+3h");
my $auth = new CGI::Session::Auth::DBI({
CGI => $cgi,
Session => $session,
IPAuth => 1,
DBHandle => $dbh,
#Log => 1,
});
if($logout) {
$auth->logout();
}
else {
$auth->authenticate();
if($auth->loggedIn) {
my $user = Cherry::Schema::ResultSet::Employee::get_employee($dbh, $cache, { number => $auth->{userid} });
if (!$user->{active}) {
return { error => $user->{name} . ' is not an active employee.' };
}
$user->{cookie} = $auth->sessionCookie();
return $user;
}
elsif($cgi->param('action') eq 'logon') {
if($cgi->param('log_username') && $cgi->param('log_username')) {
return { error => 'Your username and/or password did not match.' };
}
elsif(!$cgi->param('log_username') || !$cgi->param('log_username')) {
return { error => 'Please enter a username and a password.' };
}
}
else {
return { error => 'You are not logged in' };
}
}
}
sub handle_authentication {
my ($dbh, $cache, $config, $params, $cgi) = #_;
if(($cgi->param('auth') || '') eq 'super_user') { # for automation
return;
}
if(($params->{action} || '') eq 'log_off') {
user_logon($dbh, $cgi, $cache, 1); # 1 means log out
login_form($config, 'Successfully logged out', $params->{login_url}, $params->{title});
}
my $user = user_logon($dbh, $cgi, $cache);
if(exists $user->{error}) {
login_form($config, $user->{error}, $params->{login_url}, $params->{title});
}
elsif($user->{number}) {
return $user;
}
}
Then in my code, every time I print a header, it looks something like this:
my $user = Cherry::Authentication::handle_authentication(
$dbh,
$cache,
\%config,
{
action => $FORM{action},
username => $FORM{log_username},
password => $FORM{log_password},
auth => $FORM{auth}
},
$cgi
);
print header(
-type => 'application/json',
-cookie => $user->{cookie}
);
The problem is that this code seems to work very well about 80% of the time. The other 20%, users are getting kicked out (and not after being stale for 3 hours).
Are there any obvious flaws in this code? Have I left any crucial code out?
If you feel is there not enough information here to give a viable solution, do you have any general suggestions on what can be done to troubleshoot these types of issues?
With this particular problem, there was some code in play that I was unaware of.
$cookie = CGI::Cookie->new(
-name => $session->name, # problem line
-value => $session->id, # problem line
-expires => '+1y',
-path => '/',
-secure => 0,
);
my #header = (
-cookie => $cookie,
-type => 'text/html',
-status => $status
);
print $cgi->header( #header );
The lines with the comments #problem line were assigning a new session even when one already existed.
I installed Fiddler HTTP Debugger on the user's computer that seemed to have the issue the most. Then, once the user was unexpectedly logged out, I reviewed the logs. I was able to find a correlation between the user visiting one url, and the unexpected log out on the next request.
I asked this over on Google's support forums for Apps integration, but got zero response. Maybe somebody here can help steer me in the right direction.
I'm trying to integrate a Perl application with Google Apps, and I'm having some trouble with the OpenID authentication. I've been using this PHP tutorial from Google as a kind of reference, since there are no Perl examples I can find.
My initial file, index.cgi (referred by manifest.xml, and the starting point of the OpenID transaction) is as follows:
use Net::OpenID::Consumer;
use CGI;
# ...
my $q = CGI->new();
my $domain = $q->param('domain');
if (!$domain) {
print $q->header(), 'Provide domain please.';
exit 0;
}
# my website
my $root = 'http://www.example.com/';
my $csr = Net::OpenID::Consumer->new(
# The user agent which sends the openid off to the server
ua => LWP::UserAgent->new,
# Who we are
required_root => $root,
# Consumer Key Secret from Google Apps Marketplace
consumer_secret => 'Zzzzzz9zzAAAAA....'
);
my $claimed_id = $csr->claimed_identity(
'https://www.google.com/accounts/o8/site-xrds?hd=' . $domain);
if ($claimed_id) {
my $check_url = $claimed_id->check_url(
# Upon validation, the user will be returned here, and real
# work may begin
return_to => $root . '/return.cgi',
trust_root => $root
);
print $q->redirect($check_url);
}
else {
print $q->header(), "Error";
}
This part seems to be working. That is, I get redirected to return.cgi with a bunch of openid.* parameters. However, at this point I get the following error:
no_identity_server The provided URL doesn't declare its OpenID identity server
I'm using the latest version of the Net::OpenID::Consumer module.
Here are the significant bits of return.cgi:
my $q = CGI->new();
my $csr = Net::OpenID::Consumer->new(
ua => LWP::UserAgent->new,
# The root of our URL
required_root => 'http://www.example.com/',
# Our password.
consumer_secret => 'Zzzzzz9zzAAAAA....',
# Where to get the information from.
args => $q
);
print $q->header();
$csr->handle_server_response(
not_openid => sub {
print "That's not an OpenID message. Did you just type in the URL?";
},
setup_required => sub {
my $setup_url = shift;
print 'You need to do something here.';
},
cancelled => sub {
print 'You cancelled your login.';
},
verified => sub {
my $vident = shift;
my $url = $vident->url;
print "You are verified as '$url'. ** FIN **";
},
error => sub { die "Can't figure it out: ", #_; }
);
As you can imagine, I'm wanting the verified sub to fire, but instead I'm getting an error. Anything obvious I'm missing? Any help would be appreciated.
So the solution, it turns out, is to switch modules. I changed to the skimpily documented Net::Google::FederatedLogin, and things are now working. The code is as follows (substitute example.com below for your actual developer's domain).
In your Google Apps Marketplace vendor profile, add the URL to index.cgi in the Application Manifest:
...
<Url>http://www.example.com/index.cgi?from=google&domain=${DOMAIN_NAME}</Url>
...
Then add the following code to your servers.
index.cgi
use CGI;
use Net::Google::FederatedLogin;
my $q = CGI->new();
my $domain = $q->param('domain');
if (!$domain) {
print $q->header(), 'Provide domain please.';
exit 0;
}
my $fl = Net::Google::FederatedLogin->new(
claimed_id =>
'https://www.google.com/accounts/o8/site-xrds?hd=' . $domain,
return_to =>
'http://www.example.com/return.cgi',
extensions => [
{
ns => 'ax',
uri => 'http://openid.net/srv/ax/1.0',
attributes => {
mode => 'fetch_request',
required => 'email',
type => {
email => 'http://axschema.org/contact/email'
}
}
}
] );
print $q->redirect($fl->get_auth_url());
return.cgi
use CGI;
use Net::Google::FederatedLogin;
my $q = CGI->new();
print $q->header();
my $fl = Net::Google::FederatedLogin->new(
cgi => $q,
return_to =>
'http://www.example.com/return.cgi' );
eval { $fl->verify_auth(); };
if ($#) {
print 'Error: ' . $#;
}
else {
# we've authenticated and gotten attributes --
my $ext = $fl->get_extension('http://openid.net/srv/ax/1.0');
print $ext->get_parameter('value.email');
}
(For a full sample, plus OAuth access to user data, see this post on my blog.)
In some cases, reportedly, this is caused by Perl missing Net::SSL, making it fail on Google's SSL URLs.
The step where it's failing is where it performs discovery on the identifier asserted by Google's server. For some reason discovery on that identifier URL is failing. It would be helpful to know what OpenID identifier the Google server is asserting to try to debug why discovery is not working for it.
I'm not sure what $domain is there, but you may need to escape it:
use URI::Escape 'uri_escape';
....
my $claimed_id = $csr->claimed_identity(
'https://www.google.com/accounts/o8/site-xrds?hd=' . uri_escape($domain) );
Also, the consumer_secret used by Net::OpenID::Consumer has no relationship to any other secret.