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 <berra...@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 <dream...@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);
 
-@EXPORT = qw(dbus_method dbus_signal dbus_property);
+@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

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits

Reply via email to