implement api proxy calls using AnyEvent::HTTP

PVE/REST.pm

@@ -166,108 +166,6 @@ sub prepare_response_data {
     $res->{data} = $new;
 }
 
-sub create_http_request {
-    my ($uri, $method, $params) = @_;
-
-    # NOTE: HTTP::Request::Common::PUT is crap - so we use our own code
-    # borrowed from HTTP::Request::Common::POST
-
-    if  ($method eq 'POST' || $method eq 'PUT') {
-
-	my $req = HTTP::Request->new($method => $uri);
-	$req->header('Content-Type' => 'application/x-www-form-urlencoded'); 
-
-	# We use a temporary URI object to format
-	# the application/x-www-form-urlencoded content.
-	my $url = URI->new('http:');
-	$url->query_form(%$params);
-	my $content = $url->query;
-	if (defined($content)) {
-	    $req->header('Content-Length' => length($content));
-	    $req->content($content);
-	} else {
-	    $req->header('Content-Length' => 0);
-	}
-
-	return $req;
-    }
-
-    die "unknown method '$method'"; 
-}
-
-sub proxy_handler {
-    my($r, $clientip, $host, $method, $abs_uri, $ticket, $token, $params) = @_;
-
-    debug_msg("proxy start $method $host:$abs_uri");
-
-    my $ua = LWP::UserAgent->new(
-	# keep it simple - we are on internal network, and use tickets
-	ssl_opts => { verify_hostname => 0 },
-	# using the pve root CA file would  be another option
-	# ssl_opts => { verify_hostname => 1 , SSL_ca_file => "/etc/pve/pve-root-ca.pem },
-	protocols_allowed => [ 'http', 'https' ],
-	timeout => 30,
-	);
-
-    $ua->default_header('cookie' => "${cookie_name}=$ticket") if $ticket;
-    $ua->default_header('CSRFPreventionToken' => $token) if $token;
-    $ua->default_header('PVEDisableProxy' => 'true');
-    $ua->default_header('PVEClientIP' => $clientip);
-
-    my $uri = URI->new();
-
-    if ($host eq 'localhost') {
-	$uri->scheme('http');
-	$uri->host('localhost');
-	$uri->port(85);
-    } else {
-	$uri->scheme('https');
-	$uri->host($host);
-	$uri->port(8006);
-    }
-
-    $uri->path($abs_uri);
-
-    my $response;
-    if ($method eq 'GET') {
-	$uri->query_form($params);
-	$response = $ua->request(HTTP::Request::Common::GET($uri));		    
-    } elsif ($method eq 'POST' || $method eq 'PUT') {
-	$response = $ua->request(create_http_request($uri, $method, $params));
-    } elsif ($method eq 'DELETE') {
-	$response = $ua->request(HTTP::Request::Common::DELETE($uri));
-    } else {
-	my $code = HTTP_NOT_IMPLEMENTED;
-	$r->status_line("$code proxy method '$method' not implemented");
-	return $code;
-    }
-
-    if (my $cookie = $response->header("Set-Cookie")) {
-	$r->err_headers_out()->add("Set-Cookie" => $cookie);
-    }
-
-    my $ct = $response->header('Content-Type');
-
-    my $code = $response->code;
-    $r->status($code);
-
-    if (my $message = $response->message) {
-	$r->status_line("$code $message");
-    }
-
-    $r->content_type($ct) if $ct;
-    my $raw = $response->decoded_content;
-
-    # note: do not use err_headers_out(), because mod_deflate has a bug,
-    # resulting in dup length (for exampe 'content-length: 89, 75')
-    $r->headers_out()->add('Content-Length' , length($raw));
-    $r->print($raw);
-
-    debug_msg("proxy end $method $host:$abs_uri ($code)");
-
-    return HTTP_OK;
-}
-
 my $exc_to_res = sub {
     my ($err, $status) = @_;
 
@@ -437,92 +335,3 @@ sub split_abs_uri {
 }
 
 1;
-
-__END__
-
-my $known_methods = {
-    GET => 1,
-    POST => 1,
-    PUT => 1,
-    DELETE => 1,
-};
-
-my $request_count = 0;
-
-sub handler {
-     my($r) = @_;
-
-     die "we do not use this any longer";
-
-     debug_msg("perl handler called");
-
-     $request_count++;
-     # we do not use KeepAlive, so this is not necessary
-     # $r->child_terminate() if $request_count >= $MaxRequestsPerChild;
-
-     my $method = $r->method;
-     my $clientip = $r->connection->remote_ip();
-
-     return HTTP_NOT_IMPLEMENTED
-	 if !$known_methods->{$method};
-
-     my $cookie = $r->headers_in->{Cookie};
-     my $token = $r->headers_in->{CSRFPreventionToken};
-
-     my $ticket = extract_auth_cookie($cookie);
-
-     $r->no_cache (1);
-
-     my $abs_uri = $r->uri;
-     my ($rel_uri, $format) = split_abs_uri($abs_uri);
-     return HTTP_NOT_IMPLEMENTED if !$format;
-
-     my $rpcenv;
-     my $res;
-
-     eval { 
-	 $rpcenv = PVE::RPCEnvironment::get();
-	 $rpcenv->init_request(request_rec => $r); 
-     };
-     if (my $err = $@) {
-	 syslog('err', $err);
-	 $res = { status => HTTP_INTERNAL_SERVER_ERROR, message => $err };
-     } else {
-	 $res = rest_handler($rpcenv, $clientip, $method, $abs_uri, $rel_uri, 
-			     $ticket, $token);
-	 $rpcenv->set_user(undef); # clear after request
-     }
-
-     if ($res->{proxy}) {
-	 if (($res->{proxy} ne 'localhost') && $r->headers_in->{'PVEDisableProxy'}) {
-	     my $code = FORBIDDEN;
-	     $r->status($code);
-	     $r->status_line("$code proxy loop detected - aborted ");
-	     return $res->{status};	     
-	 } 
-	 return proxy_handler($r, $clientip, $res->{proxy}, $method, 
-			      $abs_uri, $ticket, $token, $res->{proxy_params});
-     }
-
-     prepare_response_data($format, $res);
-
-     $r->status($res->{status} || HTTP_OK);
- 
-     if ($res->{message}) {
-	 my ($firstline) = $res->{message} =~ m/\A(.*)$/m;
-	 $r->status_line("$res->{status} $firstline");
-     }
-
-     my ($raw, $ct) = format_response_data($format, $res, $abs_uri);
-     $r->content_type ($ct);
-
-     # note: do not use err_headers_out(), because mod_deflate has a bug,
-     # resulting in dup length (for exampe 'content-length: 89, 75')
-     $r->headers_out()->add('Content-Length', length($raw));
-     $r->print($raw);
-    
-     debug_msg("perl handler end $res->{status}");
-
-     return OK;
-}
-

debian/control.in

@@ -3,7 +3,7 @@ Version: @VERSION@-@PACKAGERELEASE@
 Section: admin
 Priority: optional
 Architecture: amd64
-Depends: perl5, libtimedate-perl, libauthen-pam-perl, libintl-perl, rsync, libjson-perl, liblockfile-simple-perl, vncterm, qemu-server (>= 1.1-1), libwww-perl (>= 6.04-1), libnet-http-perl (>= 6.06-1), libhttp-daemon-perl, wget, libnet-dns-perl, vlan, ifenslave-2.6 (>= 1.1.0-10), liblinux-inotify2-perl, debconf (>= 0.5) | debconf-2.0, netcat-traditional, pve-cluster (>= 1.0-29), libpve-common-perl, libpve-storage-perl, libterm-readline-gnu-perl, libpve-access-control, libio-socket-ssl-perl, libfilesys-df-perl, libfile-readbackwards-perl, libfile-sync-perl, redhat-cluster-pve, resource-agents-pve, fence-agents-pve, cstream, postfix | mail-transport-agent, libxml-parser-perl, lzop, dtach, libanyevent-perl, libio-compress-perl, liburi-perl, logrotate
+Depends: perl5, libtimedate-perl, libauthen-pam-perl, libintl-perl, rsync, libjson-perl, liblockfile-simple-perl, vncterm, qemu-server (>= 1.1-1), libwww-perl (>= 6.04-1), libnet-http-perl (>= 6.06-1), libhttp-daemon-perl, wget, libnet-dns-perl, vlan, ifenslave-2.6 (>= 1.1.0-10), liblinux-inotify2-perl, debconf (>= 0.5) | debconf-2.0, netcat-traditional, pve-cluster (>= 1.0-29), libpve-common-perl, libpve-storage-perl, libterm-readline-gnu-perl, libpve-access-control, libio-socket-ssl-perl, libfilesys-df-perl, libfile-readbackwards-perl, libfile-sync-perl, redhat-cluster-pve, resource-agents-pve, fence-agents-pve, cstream, postfix | mail-transport-agent, libxml-parser-perl, lzop, dtach, libanyevent-perl, libio-compress-perl, liburi-perl, logrotate, libanyevent-http-perl
 Conflicts: netcat-openbsd, vzdump
 Replaces: vzdump
 Provides: vzdump