[pve-devel] r4966 - pve-common/trunk

[svn-commits at proxmox.com]

Author: dietmar
Date: 2010-08-11 09:46:09 +0000 (Wed, 11 Aug 2010)
New Revision: 4966

Added:
   pve-common/trunk/RESTHandler.pm
Modified:
   pve-common/trunk/Makefile
Log:
moved RESTHandler from pve-manager


Modified: pve-common/trunk/Makefile
===================================================================
--- pve-common/trunk/Makefile	2010-08-10 13:00:32 UTC (rev 4965)
+++ pve-common/trunk/Makefile	2010-08-11 09:46:09 UTC (rev 4966)
@@ -18,6 +18,7 @@
 DEB=${PACKAGE}_${VERSION}-${PKGREL}_${ARCH}.deb
 
 LIB_SOURCES=			\
+	RESTHandler.pm		\
 	JSONSchema.pm		\
 	SafeSyslog.pm		\
 	AtomicFile.pm		\

Added: pve-common/trunk/RESTHandler.pm
===================================================================
--- pve-common/trunk/RESTHandler.pm	                        (rev 0)
+++ pve-common/trunk/RESTHandler.pm	2010-08-11 09:46:09 UTC (rev 4966)
@@ -0,0 +1,243 @@
+package PVE::RESTHandler;
+
+use strict;
+use warnings;
+use PVE::SafeSyslog;
+use PVE::JSONSchema;
+use HTTP::Status qw(:constants :is status_message);
+
+use Data::Dumper; # fixme: remove
+
+my $method_registry = {};
+my $method_by_name = {};
+
+our $AUTOLOAD;  # it's a package global
+
+sub register_method {
+    my ($self, $info) = @_;
+
+    PVE::JSONSchema::validate_method_info($info);
+
+    my $match_re = [];
+    my $match_name = [];
+
+    foreach my $comp (split(/\/+/, $info->{path})) {
+	die "path compoment has zero length" if $comp eq '';
+	if ($comp =~ m/^\{(\w+)\}$/) {
+	    my $name = $1;
+	    push @$match_re, '\S+';
+	    push @$match_name,  $1;
+	} else {
+	    push @$match_re, $comp;
+	    push @$match_name,  undef;
+	}
+    }
+
+    $info->{match_re} = $match_re;
+    $info->{match_name} = $match_name;
+
+    $method_by_name->{$self} = {} if !defined($method_by_name->{$self});
+
+    if ($info->{name}) {
+	die "method '${self}::$info->{name}' already defined\n"
+	    if defined($method_by_name->{$self}->{$info->{name}});
+
+	$method_by_name->{$self}->{$info->{name}} = $info;
+    }
+
+    push @{$method_registry->{$self}}, $info;
+}
+
+sub AUTOLOAD {
+    my $self = shift;
+
+    my $method = $AUTOLOAD;
+
+    $method =~ s/.*:://;
+   
+    my $info = $method_by_name->{$self}->{$method};
+    
+    die "no such method '${self}::$method'\n" if !$info;
+
+    # fixme: how do we handle this here?
+    # fixme: language ?
+    my $conn = {
+#	abs_uri => $abs_uri,
+#	rel_uri => $rel_uri,
+#	user => $username,
+	params => shift || {},
+    };
+
+    my $res = {};
+    $res->{status} = $self->handle($info, $conn, $res);
+ 
+    my $status = $res->{status};
+    if (!is_success($status)) {
+	my $msg = $res->{message} || status_message($status);
+	chomp $msg;
+	$msg .= "\n";
+	if ($res->{errors}) {
+	    foreach my $e (keys %{$res->{errors}}) {
+		$msg .= "$e: $res->{errors}->{$e}\n";
+	    }
+	}
+	die $msg;
+    }
+
+    return $res->{data};
+}
+
+sub method_attributes {
+    my ($self) = @_;
+
+    return $method_registry->{$self};
+}
+
+sub map_method {
+    my ($self, $stack, $method, $uri_param) = @_;
+
+    my $ma = $method_registry->{$self};
+
+    my $stacklen = scalar(@$stack);
+
+    #syslog ('info', "MAPTEST:$method:$self: " . join ('/', @$stack));
+
+    foreach my $info (@$ma) {
+	#syslog ('info', "TEST0 " . Dumper($info));
+	next if !($info->{subclass} || ($info->{method} eq $method));
+	my $regexlen = scalar(@{$info->{match_re}});
+	if ($info->{subclass}) {
+	    next if $stacklen < $regexlen;
+	} else {
+	    next if $stacklen != $regexlen;
+	}
+
+	#syslog ('info', "TEST1 " . Dumper($info));
+
+	my $param = {};
+	my $i = 0;
+	for (; $i < $regexlen; $i++) {
+	    my $comp = $stack->[$i];
+	    my $re = $info->{match_re}->[$i];
+	    #print "COMPARE $comp $info->{match_re}->[$i]\n";
+	    my ($match) = $stack->[$i] =~ m/^($re)$/;
+	    last if !defined($match);
+	    if (my $name = $info->{match_name}->[$i]) {
+		$param->{$name} = $match; 
+	    }
+	}
+
+	next if $i != $regexlen;
+
+	#print "MATCH $info->{name}\n";
+	
+	foreach my $p (keys %$param) {
+	    $uri_param->{$p} = $param->{$p};
+	}
+
+	return $info;
+    }
+}
+
+sub find_handler {
+    my ($class, $method, $stack, $uri_param) = @_;
+
+    my $info;
+    eval {
+	$info = $class->map_method($stack, $method, $uri_param);
+    };
+    syslog('err', $@) if $@;
+
+    return undef if !$info;
+
+    if (my $subh = $info->{subclass}) {
+	eval "require $subh;";
+
+	if ($@) {
+	    syslog ('err', "missing subclass '$subh': $@");
+	    return undef;
+	}
+
+	my $matchlen = scalar(@{$info->{match_re}});
+
+	for (my $i = 0; $i < $matchlen; $i++) {
+	    my $fragment = shift @$stack;
+	    # fixme: store $fragments somewhere ?
+	}
+
+	return $subh->find_handler($method, $stack, $uri_param);
+    }
+
+    return ($class, $info);
+}
+
+sub handle {
+    my ($self, $info, $conn, $resp) = @_;
+
+    my $func = $info->{code};
+
+    if (!($info->{name} && $func)) {
+	$resp->{message} = "Method lookup failed ('$info->{name}')";
+	$resp->{status} = HTTP_INTERNAL_SERVER_ERROR;
+	return $resp->{status};
+    }
+
+    if (my $schema = $info->{parameters}) {
+	# warn "validate ". Dumper($conn->{params}) . "\n" . Dumper($schema);
+	my $res = PVE::JSONSchema::validate($conn->{params}, $schema);
+	if (!$res->{valid}) {
+	    $resp->{status} = HTTP_BAD_REQUEST;
+	    $resp->{message} = "Parameter verification failed";
+	    $resp->{errors} = $res->{errors},
+	    return $resp->{status};
+	}
+    }
+
+    eval{
+	my $result = &$func($conn, $resp, $conn->{params});
+	$resp->{status} = HTTP_OK if !$resp->{status};
+	$resp->{data} = $result;
+    };
+    my $err = $@;
+
+    if ($err) {
+	$resp->{message} = $err;
+
+	$resp->{status} = HTTP_BAD_REQUEST
+	    if !($resp->{status} && is_error($resp->{status}));
+    }
+
+    # fixme: this is only to be safe
+    if (!$err && (my $schema = $info->{returns})) {
+
+	my $res = PVE::JSONSchema::validate($resp->{data}, $schema);
+	if (!$res->{valid}) {
+
+	    $resp->{message} = "Result verification vailed";
+	    $resp->{status} = HTTP_INTERNAL_SERVER_ERROR;
+	    $resp->{errors} = $res->{errors};
+
+	    return $resp->{status};
+	} 
+    }
+
+    return $resp->{status};
+}
+
+# utility methods
+# note: this modifies the original hash by adding the id property
+sub hash_to_array {
+    my ($hash, $idprop) = @_;
+
+    my $res = [];
+    return $res if !$hash;
+
+    foreach my $k (keys %$hash) {
+	$hash->{$k}->{$idprop} = $k;
+	push @$res, $hash->{$k};
+    }
+
+    return $res;
+}
+
+1;