| Subject: | [patch] Add support for handling of arbitrary perl objects, logging to syslog and client IP filtering for Frontier::* |
This patches for Clients.pm and RPC.pm as the rewrite of Daemon.pm add
some new features, but should be 100% compatible to older versions.
The new Frontier::* stuff is able to push any arbitrary perl object over
the wire by using Data::Serializer to put it into an ASCII stream and
including this in the XML data.
The new Frontier::Daemon has the ability to filter client connections
based on a list of given IPs which are able to make connections to the
server.
The daemon is also able to log requests including query path and method
(if desired) to syslog.
I would like this changes to be included in the Frontier distribution as
I think they are interesting for others, too.
Ciao
Max
| Subject: | Client.pm.handle_perl_objects.patch |
diff --git a/Client.pm b/Client.pm
index 800acab..9ee5755 100644
--- a/Client.pm
+++ b/Client.pm
@@ -1,8 +1,12 @@
#
# Copyright (C) 1998 Ken MacLeod
+# Copyright (C) 2007-2008 Maximilian Wilhelm <max@rfc2324.org>
+#
# Frontier::Client is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
+# Handling of arbitrary perl objects added by Maximilian Wilhelm.
+#
# $Id: Client.pm,v 1.8 2001/10/03 01:30:54 kmacleod Exp $
#
@@ -47,6 +51,10 @@ sub new {
push @options, 'use_objects' => $self->{'use_objects'};
}
+ if (defined $self->{'handle_perl_objects'} && $self->{'handle_perl_objects'}) {
+ push @options, 'handle_perl_objects' => $self->{'handle_perl_objects'};
+ }
+
$self->{'enc'} = Frontier::RPC2->new(@options);
return $self;
| Subject: | Daemon.pm |
#!/usr/bin/perl -WT
#
# Frontier::Daemon (next generation)
#
# Frontier::Daemon is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# Copyright (C) 1998 Ken MacLeod
# Copyright (C) 2007-2008 Maximilian Wilhelm <max@rfc2324.org>
#
# This is an extended version of the Frontier::Daemon HTTP XML-RPC server.
#
# This version of Frontier::Daemon basicly does the same as the normal
# Frontier::Daemon but allows specifying a reference to a list of IPs
# allowed to open connections to this server and can log request to syslog.
#
# It is also possible to push arbitrary perl objects over the wire.
#
# All this stuff was added by Maximilian Wilhelm.
#
package Frontier::Daemon;
use strict;
use Carp;
use HTTP::Daemon;
use HTTP::Status;
use HTTP::Headers;
use Frontier::RPC2;
#
# Little bit of magic to simplify debugging
sub _options(@) {
my %ret = @_;
if ($ret{debug}) {
foreach my $opt (keys %ret) {
print STDERR __PACKAGE__ . "->_options: $opt => $ret{$opt}\n";
}
}
return \%ret;
}
sub log_msg ($) {
my $self = shift;
my $msg = shift;
return if (ref ($self) ne __PACKAGE__);
return if (! $self->{syslog}->{active});
syslog ($self->{syslog}->{log_level}, $self->{syslog}->{prefix} . $msg);
}
#
# Create new Fronter HTTP RPC server
sub new { # new (methods => \%, allowed_clients => \@, <HTTP::Daemon opts>) : \__PACKAGE__
my $self = shift;
my $class = ref ($self) || $self;
#
# Get and check arguments
#
my $args = &_options (@_);
my $syslog = $args->{syslog} || {};
if (defined $syslog) {
if (ref ($syslog) ne 'HASH') {
$syslog = {};
}
# Only load syslog module when needed. (compatibility)
use Sys::Syslog qw(:standard :macros);;
# Default values if not there.
$syslog->{name} = 'Frontier::Daemon' if (! defined $syslog->{name});
$syslog->{prefix} = "XML-RPC HTTP server: " if (! defined $syslog->{prefix});
$syslog->{facility} = "daemon" if (! defined $syslog->{facility});
$syslog->{log_level} = "info" if (! defined $syslog->{log_level});
openlog ($syslog->{name}, "ndelay,pid", $syslog->{facility});
$syslog->{active} = 1;
END { closelog(); }
}
# Reference to methods hash
my $methods = $args->{methods};
if (! defined $methods || ref ($methods) ne 'HASH') {
confess __PACKAGE__ . "::new(): Missing or invalid 'methods' argument\n";
}
# Check for list of allowed clients
my $allowed_clients = $args->{allowed_clients};
if (defined $allowed_clients) {
if (ref ($allowed_clients) ne 'ARRAY') {
confess __PACKAGE__ . "::new(): Invalid 'allowed_clients' argument, must be list_ref\n";
}
use Net::CIDR;
}
#
# Prepare stuff
#
# Fire up XML-RPC decoder
my $rpc2_use_objects = $args->{use_objects} || undef;
my $rpc2_handle_perl_objects = $args->{handle_perl_objects} || undef;
my $decoder = Frontier::RPC2->new (use_objects => $rpc2_use_objects,
handle_perl_objects => $rpc2_handle_perl_objects);
if (! $decoder) {
confess __PACKAGE__ . "::new(): Failed to fire up XML-RPC decoder\n";
}
# Prepare HTTP response
my $http_header = HTTP::Headers->new ('Content-Type' => 'text/xml');
my $http_response = HTTP::Response->new (200, "", $http_header);
if (! $http_header || ! $http_response) {
confess __PACKAGE__ . "::new(): Failed to prepare HTTP stuff\n";
}
my $http_daemon = HTTP::Daemon->new (%{$args});
if (! $http_daemon) {
confess __PACKAGE__ . "::new(): Failed to start up HTTP daemon\n";
}
#
# Create instance object
my $obj = bless {
methods => $methods,
allowed_clients => $allowed_clients,
decoder => $decoder,
http_header => $http_header,
http_response => $http_response,
http_daemon => $http_daemon,
syslog => $syslog,
}, $class;
$obj->log_msg ("started.");
if ($args->{no_autolisten}) {
return $obj;
} else {
$obj->listen ();
}
}
#
# Start listeing for HTTP requests
sub listen() { # listen() :
my $self = shift;
if (ref ($self) ne __PACKAGE__) {
confess __PACKAGE__ . "::listen() has to be called on instanciated object.\n";
}
while (my $conn = $self->{http_daemon}->accept ()) {
my $request = $conn->get_request ();
my $is_allowed = 1;
if ($request) {
my ($peer_port, $peer) = sockaddr_in ($conn->peername ());
my $peer_ip = inet_ntoa ($peer);
# Check if client is allowed to talk to us if we were asked for it
if (defined $self->{allowed_clients} && ! Net::CIDR::cidrlookup ($peer_ip, @{$self->{allowed_clients}})) {
$is_allowed = 0;
}
# Get request method and path for logging
my $method = $request->method ();
my $path = $request->url()->path ();
if ($is_allowed) {
if (defined $self->{syslog}->{log_request_path}) {
$self->log_msg ("Accepted request from $peer_ip for $path ($method)\n");
} else {
$self->log_msg ("Accepted request from $peer_ip\n");
}
# Check for valid request
if ($method eq 'POST' && $path eq '/RPC2') {
# Fill response
$self->{http_response}->content ($self->{decoder}->serve ($request->content (), $self->{methods}));
# Send answer
$conn->send_response ($self->{http_response});
# Invalid request
} else {
$conn->send_error (RC_BAD_REQUEST);
}
# Client IP not listed in allowed_client list
} else {
if (defined $self->{syslog}->{log_request_path}) {
$self->log_msg ("Denied request from $peer_ip for $path ($method)\n");
} else {
$self->log_msg ("Denied request from $peer_ip\n");
}
$conn->send_error (RC_FORBIDDEN, "You are not welcome from $peer_ip\n");
}
}
$conn->close ();
# close connection
$conn = undef;
}
}
1;
=head1 NAME
Frontier::Daemon - receive Frontier XML RPC requests
=head1 SYNOPSIS
use Frontier::Daemon;
Frontier::Daemon->new(methods => {
'rpcName' => \&sub_name,
...
# Optional things
'allowed_clients' => [' 127.0.0.1', '192.168.23.42' ],
'handle_perl_objects' => 1,
'syslog' => {
name => "Frontier::Daemon",
prefix => "[RPC]",
facility => "daemon",
log_level => "info",
log_request_path => 1,
},
});
my $daemon = Frontier::Daemon->new (methods => { ... },
no_autolisten => 1,
...
};
$daemon->listen ();
=head1 DESCRIPTION
I<Frontier::Daemon> is an HTTP/1.1 server that listens on a socket for
incoming requests containing Frontier XML RPC2 method calls.
I<Frontier::Daemon> is a subclass of I<HTTP::Daemon>, which is a
subclass of I<IO::Socket::INET>.
I<Frontier::Daemon> takes a `C<methods>' parameter, a hash that maps
an incoming RPC method name to reference to a subroutine.
I<Frontier::Daemon> takes a `C<use_objects>' parameter that if set to
a non-zero value will convert incoming E<lt>intE<gt>, E<lt>i4E<gt>,
E<lt>floatE<gt>, and E<lt>stringE<gt> values to objects instead of
scalars. See int(), float(), and string() in Frontier::RPC2 for more
details.
I<Frontier::Daemon> takes an `C<allowed_clients>' parameter that if set
to a list reference containing IP addresses will make I<Frontier::Daemon>
to allow only request from client with a listed address.
I<Frontier::Daemon> takes a `C<handle_perl_objects>' parameter that if set
will be pushed to I<Frontier::RPC2> to allow pushing arbitrary perl objects
over the wire.
I<Frontier::Daemon> takes a `C<syslog>' paramter that if set to a non-zero value or
hash reference contains extra options enables syslog logging support for I<Frontier::Daemon>.
The syslog options - and therefore hash keywords are: name, facility, log_level,
prefix and log_request_path. The options name, facility and log_level are obvious
syslog options, prefix may contain a string which will be prepended to any log entry
written by I<Frontier::Daemon> and log_request_path set to a non-zero value enables
logging of the request path.
I<Frontier::Daemon> takes a `C<no_autolisten>' parameter for being able to just
create a new instance, which does not start listning imediatly.
This option was added for compatibility.
=head1 SEE ALSO
perl(1), HTTP::Daemon(3), IO::Socket::INET(3), Frontier::RPC2(3), Sys::Syslog(3)
<http://www.scripting.com/frontier5/xml/code/rpc.html>
=head1 AUTHOR
Ken MacLeod <ken@bitsko.slc.ut.us>
Arbitrary perl object handling and client ip flitering added by Maximilian Wilhelm <max@rfc2324.org>
=cut
1;
| Subject: | RPC2.pm.handle_perl_objects.patch |
diff --git a/RPC2.pm b/RPC2.pm
index a42ec4d..fdf3257 100644
--- a/RPC2.pm
+++ b/RPC2.pm
@@ -1,8 +1,11 @@
#
# Copyright (C) 1998, 1999 Ken MacLeod
+# Copyright (C) 2007-2008 Maximilian Wilhelm <max@rfc2324.org>
# Frontier::RPC is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
+# Handling of arbitrary perl objects added by Maximilian Wilhelm.
+#
# $Id: RPC2.pm,v 1.18 2002/08/02 18:35:21 ivan420 Exp $
#
@@ -45,6 +48,16 @@ sub new {
$self->{'encoding_'} = "";
}
+ #
+ # This version of Frontier::RPC2 can push arbitrary perl objects across the wire...
+ #
+ # If you set 'handle_perl_objects' are parameter this feature is actived.
+ if ($self->{handle_perl_objects}) {
+ use Data::Serializer;
+ $self->{serializer} = Data::Serializer->new();
+ $scalars{'perl_object'} = 1;
+ }
+
return $self;
}
@@ -183,7 +196,16 @@ sub _item {
push @text, $self->_hash($item);
} elsif ($ref =~ /=ARRAY\(/) {
push @text, $self->_array($item);
- } else {
+ }
+
+ # If handle_perl_objects parameter was set, encode every object of any class in XML
+ elsif ($self->{handle_perl_objects} &&
+ $item =~ /=HASH\(/ &&
+ $ref =~ /[[:alnum:]]+/) {
+ push @text, "<value><perl_object>", $self->{serializer}->serialize ($item), "</perl_object></value>\n";
+ }
+
+ else {
die "can't convert \`$item' to XML\n";
}
@@ -439,6 +461,13 @@ sub end {
$value = Frontier::RPC2::String->new($value);
}
}
+
+ # Deserialize arbitrary perl objects.
+ elsif ($tag eq 'perl_object') {
+ my $ser = Data::Serializer->new ();
+ $value = $ser->deserialize ($value);
+ }
+
$expat->{'rpc_value'} = $value;
} elsif ($state eq 'member_name') {
$expat->{'rpc_member_name'}[-1] = $expat->{'rpc_text'};