[libnet-dbus-perl] 279/335: Be stricter about allowing remote invocation of methods (derived from patch by Stefan Pfetzing)
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:08:10 UTC 2015
This is an automated email from the git hooks/post-receive script.
intrigeri pushed a commit to branch experimental
in repository libnet-dbus-perl.
commit fc4fc3dd78d8a0c2c52e18a6b66d46627bb5ee8a
Author: Daniel P. Berrange <berrange at redhat.com>
Date: Mon May 4 19:44:56 2009 +0100
Be stricter about allowing remote invocation of methods (derived from patch by Stefan Pfetzing)
---
AUTHORS | 1 +
examples/strict-exports.pl | 75 ++++++++++++++++++++++++++++++++++++
lib/Net/DBus/Binding/Introspector.pm | 46 +++++++++++++++++++---
lib/Net/DBus/Exporter.pm | 21 +++++++++-
lib/Net/DBus/Object.pm | 24 +++++++++++-
5 files changed, 158 insertions(+), 9 deletions(-)
diff --git a/AUTHORS b/AUTHORS
index 58542b4..0ad65e6 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -13,6 +13,7 @@ from
Olivier Blin <oblin-at-mandriva-dot-com>
Jack <ms419-at-freezone-dot-co-dot-uk>
Dave Belser <dbelser-at-aerosat-dot-com>
+ Stefan Pfetzing <dreamind at dreamind.de>
[...send patches to get your name here!]
diff --git a/examples/strict-exports.pl b/examples/strict-exports.pl
new file mode 100644
index 0000000..25417d4
--- /dev/null
+++ b/examples/strict-exports.pl
@@ -0,0 +1,75 @@
+#!/usr/bin/perl
+# -*- perl -*-
+
+use strict;
+use warnings;
+
+package MyStrictObject;
+
+use base qw(Net::DBus::Object);
+use Net::DBus::Exporter "org.example.MyObject";
+
+dbus_strict_exports;
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+
+ $self->{name} = "Joe";
+ $self->{salary} = 100000;
+
+ bless $self, $class;
+
+ return $self;
+}
+
+dbus_method("name", [], ["string"]);
+sub name {
+ my $self = shift;
+ return $self->{name};
+}
+
+sub salary {
+ my $self = shift;
+ return $self->{salary};
+}
+
+package MyFlexibleObject;
+
+use base qw(Net::DBus::Object);
+use Net::DBus::Exporter qw(org.example.MyObject);
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+
+ $self->{name} = "Joe";
+ $self->{salary} = 100000;
+
+ bless $self, $class;
+
+ return $self;
+}
+
+dbus_method("name", [], ["string"]);
+sub name {
+ my $self = shift;
+ return $self->{name};
+}
+
+sub salary {
+ my $self = shift;
+ return $self->{salary};
+}
+
+package main;
+
+use Net::DBus;
+use Net::DBus::Reactor;
+
+my $bus = Net::DBus->session;
+my $service = $bus->export_service("org.cpan.Net.Bus.test");
+my $object1 = MyStrictObject->new($service, "/org/example/MyStrictObject");
+my $object2 = MyFlexibleObject->new($service, "/org/example/MyFlexibleObject");
+
+Net::DBus::Reactor->main->run();
diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index 0a64d58..e007c2b 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -149,6 +149,8 @@ sub new {
$self->{children} = exists $params{children} ? $params{children} : [];
}
+ $self->{strict} = exists $params{strict} ? $params{strict} : 0;
+
# 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} &&
@@ -198,10 +200,12 @@ sub has_interface {
return exists $self->{interfaces}->{$name} ? 1 : 0;
}
-=item my @interfaces = $ins->has_method($name)
+=item my @interfaces = $ins->has_method($name, [$interface])
Return a list of all interfaces provided by the object, which
contain a method called C<$name>. This may be an empty list.
+The optional C<$interface> parameter can restrict the check to
+just that one interface.
=cut
@@ -209,14 +213,42 @@ sub has_method {
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 $boolean = $ins->is_method_allowed($name[, $interface])
+
+Checks according to whether the remote caller is allowed to invoke
+the method C<$name> on the object associated with this introspector.
+If this object has 'strict exports' enabled, then only explicitly
+exported methods will be allowed. The optional C<$interface> parameter
+can restrict the check to just that one interface. Returns a non-zero
+value if the method should be allowed.
+
+=cut
+
+sub is_method_allowed {
+ my $self = shift;
+ my $name = shift;
+
+ if ($self->{strict}) {
+ return $self->has_method($name, @_) ? 1 : 0;
+ } else {
+ return 1;
+ }
}
=item my @interfaces = $ins->has_signal($name)
@@ -243,6 +275,8 @@ sub has_signal {
Return a list of all interfaces provided by the object, which
contain a property called C<$name>. This may be an empty list.
+The optional C<$interface> parameter can restrict the check to
+just that one interface.
=cut
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index c046046..5c06587 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -34,6 +34,9 @@ Net::DBus::Exporter - Export object methods and signals to the bus
# We're going to be a DBus object
use base qw(Net::DBus::Object);
+ # Ensure only explicitly exported methods can be invoked
+ dbus_strict_exports;
+
# Export a 'Greeting' signal taking a stringl string parameter
dbus_signal("Greeting", ["string"]);
@@ -250,7 +253,7 @@ use strict;
use Exporter;
@ISA = qw(Exporter);
- at EXPORT = qw(dbus_method dbus_signal dbus_property);
+ at EXPORT = qw(dbus_method dbus_signal dbus_property dbus_strict_exports);
sub import {
@@ -263,6 +266,7 @@ sub import {
}
$dbus_exports{$caller} = {
+ strict => 0,
methods => {},
signals => {},
props => {},
@@ -302,7 +306,7 @@ sub _dbus_introspector {
}
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;
}
@@ -398,6 +402,19 @@ sub dbus_method {
$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.
+It is strongly recommended that this method be used.
+
+=cut
+
+sub dbus_strict_exports {
+ my $caller = caller;
+ $dbus_exports{$caller}->{strict} = 1;
+}
=item dbus_property($name, $type, $access, [\%attributes]);
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index b60372a..64345c1 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -488,7 +488,7 @@ sub _dispatch {
} elsif ($method_name eq "Set") {
$reply = $self->_dispatch_prop_write($connection, $message);
}
- } elsif ($self->can($method_name)) {
+ } elsif ($self->_is_method_allowed($method_name)) {
my $ins = $self->_introspector;
my @ret = eval {
my @args;
@@ -634,6 +634,28 @@ sub _introspector {
return $self->{introspector};
}
+sub _is_method_allowed {
+ my $self = shift;
+ my $method = shift;
+
+ # Disallow any method defined in this specific package, since these
+ # are all server-side helpers / internal methods
+ return 0 if __PACKAGE__->can($method);
+
+ # If this object instance doesn't have it defined, trivially can't
+ # allow it
+ return 0 unless $self->can($method);
+
+ my $ins = $self->_introspector;
+ if (defined $ins) {
+ # Finally do check against introspection data
+ return $ins->is_method_allowed($method);
+ }
+
+ # No introspector, so have to assume its allowed
+ return 1;
+}
+
1;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git
More information about the Pkg-perl-cvs-commits
mailing list