From a95074fd43ac8e617e146c94c943681f2eeee42b Mon Sep 17 00:00:00 2001 From: zapad Date: Wed, 18 Sep 2019 08:49:03 +0300 Subject: [PATCH 1/2] Fix for servers which use Digest-MD5 for SASL auth, like jabber.ru. --- lib/Net/XMPP/Connection.pm | 4 ++-- lib/Net/XMPP/XML/Stream.pm | 47 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 2 deletions(-) create mode 100644 lib/Net/XMPP/XML/Stream.pm diff --git a/lib/Net/XMPP/Connection.pm b/lib/Net/XMPP/Connection.pm index 47a685b..bd492de 100644 --- a/lib/Net/XMPP/Connection.pm +++ b/lib/Net/XMPP/Connection.pm @@ -58,7 +58,7 @@ use Carp; use Scalar::Util qw(weaken); -use XML::Stream; +use Net::XMPP::XML::Stream; use Net::XMPP::Debug; use Net::XMPP::Protocol; @@ -110,7 +110,7 @@ sub init $self->{DISCONNECTED} = 0; $self->{STREAM} = - XML::Stream->new(style => "node", + Net::XMPP::XML::Stream->new(style => "node", debugfh => $self->{DEBUG}->GetHandle(), #debugfh => weaken $self->{DEBUG}->GetHandle(), debuglevel => $self->{DEBUG}->GetLevel(), diff --git a/lib/Net/XMPP/XML/Stream.pm b/lib/Net/XMPP/XML/Stream.pm new file mode 100644 index 0000000..714a782 --- /dev/null +++ b/lib/Net/XMPP/XML/Stream.pm @@ -0,0 +1,47 @@ +package Net::XMPP::XML::Stream; +use XML::Stream; +use base qw(XML::Stream); + +# This file is added on 2019.09.18 only to make Net::XMPP work with +# servers supporting SASL Auth via Digest-md5 method. If the original +# XML::Stream will remove force setting callback for "authname" field, +# you can switch back to it. To do it remove this file and fix +# Connection.pm to use XML::Stream instead of Net::XMPP::XML::Stream. + +sub SASLClient +{ + my $self = shift; + my $sid = shift; + my $username = shift; + my $password = shift; + + my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl"); + + return unless defined($mechanisms); + + # Here we assume that if 'to' is available, then a domain is being + # specified that does not match the hostname of the jabber server + # and that we should use that to form the bare JID for SASL auth. + my $domain .= $self->{SIDS}->{$sid}->{to} + ? $self->{SIDS}->{$sid}->{to} + : $self->{SIDS}->{$sid}->{hostname}; + + my $authname = $username . '@' . $domain; + + my $sasl = Authen::SASL->new(mechanism=>join(" ",@{$mechanisms}), + callback=>{ + user => $username, + pass => $password + } + ); + + $self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new('xmpp', $domain); + $self->{SIDS}->{$sid}->{sasl}->{username} = $username; + $self->{SIDS}->{$sid}->{sasl}->{password} = $password; + $self->{SIDS}->{$sid}->{sasl}->{authed} = 0; + $self->{SIDS}->{$sid}->{sasl}->{done} = 0; + + $self->SASLAuth($sid); +} + +1; From 6ca2f0d0fd29b7341afaf1e122559df3e3a839a4 Mon Sep 17 00:00:00 2001 From: zapad Date: Wed, 18 Sep 2019 20:35:09 +0300 Subject: [PATCH 2/2] Implemented choosing of SASL auth mechanisms. --- examples/client.pl | 16 +++++++-- lib/Net/XMPP/Protocol.pm | 4 ++- lib/Net/XMPP/XML/Stream.pm | 68 +++++++++++++++++++++++++++++++------- 3 files changed, 72 insertions(+), 16 deletions(-) diff --git a/examples/client.pl b/examples/client.pl index 787b2cc..ba3ea59 100644 --- a/examples/client.pl +++ b/examples/client.pl @@ -36,9 +36,19 @@ exit(0); } -my @result = $Connection->AuthSend(username=>$username, - password=>$password, - resource=>$resource); +my @result = $Connection->AuthSend( + username=>$username, + password=>$password, + resource=>$resource, + # can be omitted in most cases. See Net::XMPP::XML::Stream for details. + sasl_opts => { + 'sasl_mechanisms' => [ + 'ANONYMOUS', 'CRAM-MD5', 'DIGEST-MD5', 'EXTERNAL', 'GSSAPI', + 'LOGIN', 'PLAIN' + ], + 'use_authzid' => 0 + } +); if ($result[0] ne "ok") { diff --git a/lib/Net/XMPP/Protocol.pm b/lib/Net/XMPP/Protocol.pm index 28ebd16..d68b5fc 100644 --- a/lib/Net/XMPP/Protocol.pm +++ b/lib/Net/XMPP/Protocol.pm @@ -2253,7 +2253,9 @@ sub AuthSASL my $status = $self->{STREAM}->SASLClient($sid, $args{username}, - $args{password} + $args{password}, + $args{resource}, + $args{sasl_mechanisms} ); $args{timeout} = "120" unless exists($args{timeout}); diff --git a/lib/Net/XMPP/XML/Stream.pm b/lib/Net/XMPP/XML/Stream.pm index 714a782..e5a28db 100644 --- a/lib/Net/XMPP/XML/Stream.pm +++ b/lib/Net/XMPP/XML/Stream.pm @@ -2,11 +2,28 @@ package Net::XMPP::XML::Stream; use XML::Stream; use base qw(XML::Stream); -# This file is added on 2019.09.18 only to make Net::XMPP work with -# servers supporting SASL Auth via Digest-md5 method. If the original -# XML::Stream will remove force setting callback for "authname" field, -# you can switch back to it. To do it remove this file and fix -# Connection.pm to use XML::Stream instead of Net::XMPP::XML::Stream. +=pod + +=head2 SASLClient + +This is a helper function to perform all of the required steps for doing SASL with the server. + +Parameters: + +sid - session id, required +username - username, without domain, required +password - raw password, required +resource - jabber resource, optional +sasl_opts - optional hashref with specific auth opts for SASL + +The structure of sasl_opts is: +{ + allowed_mechanisms => arrayref, with allowed auth methods, for example ['PLAIN', 'CRAM-MD5'] + use_authzid => 0|1, to set if field authzid will be sent during auth, some servers handle this incorrectly +} + +=cut + sub SASLClient { @@ -14,10 +31,31 @@ sub SASLClient my $sid = shift; my $username = shift; my $password = shift; + my $resource = shift(@_) || time; + my $sasl_opts = shift(@_) || {}; + + if (!defined($sasl_opts->{allowed_mechanisms})) { + $sasl_opts->{allowed_mechanisms} = [ + 'ANONYMOUS', 'CRAM-MD5', 'DIGEST-MD5', 'EXTERNAL', 'GSSAPI', + 'LOGIN', 'PLAIN', + ]; + }; + + if (!defined($sasl_opts->{use_authzid})) { + $sasl_opts->{'use_authzid'} = 0; + } + + # check which mechanisms among available we can use + my %am = (); + foreach (@{$sasl_opts->{allowed_mechanisms}}) { $am{$_} = 1; } - my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl"); + my $available_mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl"); + my $mechanisms = []; - return unless defined($mechanisms); + foreach (@$available_mechanisms) { push(@$mechanisms, $_) if $am{$_}; } + + # no avaialable mechanisms - no auth + return unless (scalar(@$mechanisms)); # Here we assume that if 'to' is available, then a domain is being # specified that does not match the hostname of the jabber server @@ -26,13 +64,19 @@ sub SASLClient ? $self->{SIDS}->{$sid}->{to} : $self->{SIDS}->{$sid}->{hostname}; - my $authname = $username . '@' . $domain; + my $authname = $username . '@' . $domain . '/' . $resource; + + my $callbacks = { + user => $username, + pass => $password + }; + + if ($sasl_opts->{'use_authzid'}) { + $callbacks->{'authname'} = $authname; + } my $sasl = Authen::SASL->new(mechanism=>join(" ",@{$mechanisms}), - callback=>{ - user => $username, - pass => $password - } + callback=> $callbacks ); $self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new('xmpp', $domain);