Skip Menu |
 
rt.cpan.org will be shut down on March 1st, 2021.

This queue is for tickets about the Net-DBus CPAN distribution.

Report information
The Basics
Id: 45034
Status: resolved
Priority: 0/
Queue: Net-DBus

People
Owner: Nobody in particular
Requestors: dreamind [...] dreamind.de
Cc:
AdminCc:

Bug Information
Severity: Wishlist
Broken in: (no value)
Fixed in: (no value)



Subject: Net::DBus dbus_strict_exports [patch]
Download (untitled) / with headers
text/plain 291b
Hi Daniel, Net::DBus doesn't support to only allow access to exported methods via dbus_method. The attached patch introduces a new method dbus_strict_exports() which will force Net::DBus to only allow a client to access methods which were exported through dbus_method. Thanks. Greetings.
Subject: dbus_strict_exports.patch
diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Binding/Introspector.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Binding/Introspector.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Binding/Introspector.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Binding/Introspector.pm 2009-04-14 19:42:02.112396715 +0200 @@ -209,14 +209,20 @@ my $self = shift; my $name = shift; - my @interfaces; - foreach my $interface (keys %{$self->{interfaces}}) { - if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) { - push @interfaces, $interface; + if (@_) { + my $interface = shift; + return () unless exists $self->{interfaces}->{$interface}; + return () unless exists $self->{interfaces}->{$interface}->{methods}->{$name}; + return ($interface); + } else { + my @interfaces; + foreach my $interface (keys %{$self->{interfaces}}) { + if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) { + push @interfaces, $interface; + } } + return @interfaces; } - - return @interfaces; } =item my @interfaces = $ins->has_signal($name) diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Exporter.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Exporter.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Exporter.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Exporter.pm 2009-04-14 19:41:18.452156966 +0200 @@ -240,7 +240,7 @@ package Net::DBus::Exporter; -use vars qw(@ISA @EXPORT %dbus_exports %dbus_introspectors); +use vars qw(@ISA @EXPORT %dbus_exports %dbus_introspectors $dbus_strict_exports); use Net::DBus::Binding::Introspector; @@ -250,7 +250,7 @@ use Exporter; @ISA = qw(Exporter); -@EXPORT = qw(dbus_method dbus_signal dbus_property); +@EXPORT = qw(dbus_method dbus_signal dbus_property dbus_strict_exports); sub import { @@ -400,6 +400,22 @@ $dbus_exports{$caller}->{methods}->{$name} = [$params, $returns, $interface, \%attributes, $param_names, $return_names]; } +=item dbus_strict_exports(); + +Restricts calls to only methods already exported through C<dbus_method>. +When not using this method, by default any method call will be allowed. + +Method calls will be also restricted according to the used interface. + +=cut + +sub dbus_strict_exports { + $dbus_strict_exports = 1; +} + +sub _has_dbus_strict_exports { + return $dbus_strict_exports; +} =item dbus_property($name, $type, $access, [\%attributes]); diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Object.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Object.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Object.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Object.pm 2009-04-14 19:42:37.060397087 +0200 @@ -488,7 +488,7 @@ } elsif ($method_name eq "Set") { $reply = $self->_dispatch_prop_write($connection, $message); } - } elsif ($self->can($method_name)) { + } elsif (Net::DBus::Exporter::_has_dbus_strict_exports() ? $self->_introspector->has_method($method_name, $interface) : $self->can($method_name)) { my $ins = $self->_introspector; my @ret = eval { my @args;
Hi Daniel, here is the newer patch according to your suggestions. Thanks. Greetings.
diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Binding/Introspector.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Binding/Introspector.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Binding/Introspector.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Binding/Introspector.pm 2009-04-15 14:05:49.732160398 +0200 @@ -149,6 +149,8 @@ $self->{children} = exists $params{children} ? $params{children} : []; } + $self->{strict} = defined $params{strict}; + # Some versions of dbus failed to include signals in introspection data # so this code adds them, letting us keep compatability with old versions if (defined $self->{object_path} && @@ -209,14 +211,42 @@ my $self = shift; my $name = shift; - my @interfaces; - foreach my $interface (keys %{$self->{interfaces}}) { - if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) { - push @interfaces, $interface; + if (@_) { + my $interface = shift; + return () unless exists $self->{interfaces}->{$interface}; + return () unless exists $self->{interfaces}->{$interface}->{methods}->{$name}; + return ($interface); + } else { + my @interfaces; + foreach my $interface (keys %{$self->{interfaces}}) { + if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) { + push @interfaces, $interface; + } } + return @interfaces; } +} - return @interfaces; +=item my @interfaces = $ins->can_do_method($object, $name) + +Checks according to C<dbus_strict_exports()> wether the C<$object> +supports the method or not. If you used C<dbus_strict_exports()>, then +only methods which were exported earlier through C<dbus_method()> will +be allowed. Otherwise simply C<$object> will be checked with can(). + +=cut + +sub can_do_method { + my $self = shift; + # for some reason using caller() didn't work, so in this way. + my $caller = shift; + my $method_name = shift; + + if ($self->{strict}) { + return $self->has_method($method_name, @_); + } else { + return $caller->can($method_name); + } } =item my @interfaces = $ins->has_signal($name) diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Exporter.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Exporter.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Exporter.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Exporter.pm 2009-04-15 14:05:41.336206453 +0200 @@ -250,7 +250,7 @@ use Exporter; @ISA = qw(Exporter); -@EXPORT = qw(dbus_method dbus_signal dbus_property); +@EXPORT = qw(dbus_method dbus_signal dbus_property dbus_strict_exports); sub import { @@ -305,7 +305,7 @@ } unless (exists $dbus_introspectors{$class}) { - my $is = Net::DBus::Binding::Introspector->new(); + my $is = Net::DBus::Binding::Introspector->new(strict=>$dbus_exports{$class}->{strict}); &_dbus_introspector_add($class, $is); $dbus_introspectors{$class} = $is; } @@ -400,6 +400,19 @@ $dbus_exports{$caller}->{methods}->{$name} = [$params, $returns, $interface, \%attributes, $param_names, $return_names]; } +=item dbus_strict_exports(); + +Restricts calls to only methods already exported through C<dbus_method>. +When not using this method, by default any method call will be allowed. + +Method calls will be also restricted according to the used interface. + +=cut + +sub dbus_strict_exports { + my $caller = caller; + $dbus_exports{$caller}->{strict} = 1; +} =item dbus_property($name, $type, $access, [\%attributes]); diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Object.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Object.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Object.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Object.pm 2009-04-15 14:05:31.884227634 +0200 @@ -488,7 +488,7 @@ } elsif ($method_name eq "Set") { $reply = $self->_dispatch_prop_write($connection, $message); } - } elsif ($self->can($method_name)) { + } elsif ($self->_introspector->can_do_method($self, $method_name, $interface)) { my $ins = $self->_introspector; my @ret = eval { my @args;
Download (untitled) / with headers
text/plain 123b
Patch looks good and will be included in next release. I probably also need to add a similar check on valid property names.
Download (untitled) / with headers
text/plain 348b
A derived version of your patch is included upstream http://hg.berrange.com/libraries/net-dbus--devel?cs=be26112c5fdd I decided to be stricter by default, even when 'dbus_strict_exports' isn't set - explicitly reject any attempt to invoke internal implementation methods on Net::DBus::Object itself, only allowing methods provided in sub-classes.
Download (untitled) / with headers
text/plain 237b
The 1.0.0 release includes a slight variation on this. The exporter is actually strict by default, and requires a 'dbus_no_strict_exports' call to allow access of non-exported methods. This should ensure good security in the common case.


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.