+include /usr/share/dpkg/default.mk
+
PACKAGE=libpve-apiclient-perl
-PKGVER=$(shell dpkg-parsechangelog -Sversion | cut -d- -f1)
-PKGREL=$(shell dpkg-parsechangelog -Sversion | cut -d- -f2)
-BUILDSRC := $(PACKAGE)-$(PKGVER)
-DEB=${PACKAGE}_${PKGVER}-${PKGREL}_all.deb
-DSC=${PACKAGE}_${PKGVER}-${PKGREL}.dsc
+BUILDSRC := $(PACKAGE)-$(DEB_VERSION)
+DEB=$(PACKAGE)_$(DEB_VERSION)_all.deb
+DSC=$(PACKAGE)_$(DEB_VERSION).dsc
DESTDIR=
-
-PERL5DIR=${DESTDIR}/usr/share/perl5
-DOCDIR=${DESTDIR}/usr/share/doc/${PACKAGE}
-
-PVE_COMMON_FILES= \
- Exception.pm
+PERL5DIR=$(DESTDIR)/usr/share/perl5
+DOCDIR=$(DESTDIR)/usr/share/doc/$(PACKAGE)
GITVERSION:=$(shell git rev-parse HEAD)
-all: ${DEB}
+all: $(DEB)
-.PHONY: $(BUILDSRC)
$(BUILDSRC):
- rm -rf $(BUILDSRC)
- rsync -a debian $(BUILDSRC)
- make DESTDIR=./$(BUILDSRC) install
- echo "git clone git://git.proxmox.com/git/pve-apiclient.git\\ngit checkout ${GITVERSION}" > $(BUILDSRC)/debian/SOURCE
+ rm -rf $@ $@.tmp
+ cp -a src $@.tmp
+ cp -a debian $@.tmp/
+ echo "git clone git://git.proxmox.com/git/pve-apiclient.git\\ngit checkout $(GITVERSION)" >$@.tmp/debian/SOURCE
+ mv $@.tmp $@
.PHONY: deb
-deb ${DEB}: $(BUILDSRC)
- cd $(BUILDSRC); dpkg-buildpackage -rfakeroot -b -us -uc
- lintian ${DEB}
+deb $(DEB): $(BUILDSRC)
+ cd $(BUILDSRC); dpkg-buildpackage -b -us -uc
+ lintian $(DEB)
.PHONY: dsc
-dsc: $(BUILDSRC)
- cd $(BUILDSRC); dpkg-buildpackage -S -us -uc -d -nc
- lintian ${DSC}
-
-install:
- install -D -m 0644 PVE/APIClient/LWP.pm ${PERL5DIR}/PVE/APIClient/LWP.pm
- install -m 0644 PVE/APIClient/Exception.pm ${PERL5DIR}/PVE/APIClient/Exception.pm
- install -d -m 755 ${DOCDIR}/examples
- install -m 0755 examples/example1.pl ${DOCDIR}/examples
- install -m 0755 examples/example2.pl ${DOCDIR}/examples
- install -m 0755 examples/perftest1.pl ${DOCDIR}/examples
-
-update-pve-common:
- for i in ${PVE_COMMON_FILES}; do cp ../pve-common/src/PVE/$$i PVE/APIClient/; done
- for i in ${PVE_COMMON_FILES}; do sed -i 's/PVE::/PVE::APIClient::/g' PVE/APIClient/$$i; done
+dsc: $(DSC)
+$(DSC): $(BUILDSRC)
+ cd $(BUILDSRC); dpkg-buildpackage -S -us -uc -d
+ lintian $(DSC)
+
+sbuild: $(DSC)
+ sbuild $(DSC)
.PHONY: upload
-upload: ${DEB}
- tar cf - ${DEB} | ssh -X repoman@repo.proxmox.com upload --product pmg,pve --dist stretch
+upload: UPLOAD_DIST ?= $(DEB_DISTRIBUTION)
+upload: $(DEB)
+ tar cf - $(DEB) | ssh -X repoman@repo.proxmox.com upload --product pmg,pve --dist $(UPLOAD_DIST)
distclean: clean
-
clean:
- rm -rf ./$(BUILDSRC) *.deb *.changes *.buildinfo *.dsc *.tar.gz
- find . -name '*~' -exec rm {} ';'
+ rm -rf $(PACKAGE)-[0-9]*/ *.deb *.changes *.buildinfo *.build *.dsc *.tar.*
.PHONY: dinstall
-dinstall: ${DEB}
- dpkg -i ${DEB}
+dinstall: $(DEB)
+ dpkg -i $(DEB)
+++ /dev/null
-package PVE::APIClient::Exception;
-
-# a way to add more information to exceptions (see man perlfunc (die))
-# use PVE::APIClient::Exception qw(raise);
-# raise ("my error message", code => 400, errors => { param1 => "err1", ...} );
-
-use strict;
-use warnings;
-use vars qw(@ISA @EXPORT_OK);
-require Exporter;
-use Storable qw(dclone);
-use HTTP::Status qw(:constants);
-
-@ISA = qw(Exporter);
-
-use overload '""' => sub {local $@; shift->stringify};
-use overload 'cmp' => sub {
- my ($a, $b) = @_;
- local $@;
- return "$a" cmp "$b"; # compare as string
-};
-
-@EXPORT_OK = qw(raise raise_param_exc raise_perm_exc);
-
-sub new {
- my ($class, $msg, %param) = @_;
-
- $class = ref($class) || $class;
-
- my $self = {
- msg => $msg,
- };
-
- foreach my $p (keys %param) {
- next if defined($self->{$p});
- my $v = $param{$p};
- $self->{$p} = ref($v) ? dclone($v) : $v;
- }
-
- return bless $self;
-}
-
-sub raise {
-
- my $exc = PVE::APIClient::Exception->new(@_);
-
- my ($pkg, $filename, $line) = caller;
-
- $exc->{filename} = $filename;
- $exc->{line} = $line;
-
- die $exc;
-}
-
-sub raise_perm_exc {
- my ($what) = @_;
-
- my $param = { code => HTTP_FORBIDDEN };
-
- my $msg = "Permission check failed";
-
- $msg .= " ($what)" if $what;
-
- my $exc = PVE::APIClient::Exception->new("$msg\n", %$param);
-
- my ($pkg, $filename, $line) = caller;
-
- $exc->{filename} = $filename;
- $exc->{line} = $line;
-
- die $exc;
-}
-
-sub is_param_exc {
- my ($self) = @_;
-
- return $self->{code} && $self->{code} eq HTTP_BAD_REQUEST;
-}
-
-sub raise_param_exc {
- my ($errors, $usage) = @_;
-
- my $param = {
- code => HTTP_BAD_REQUEST,
- errors => $errors,
- };
-
- $param->{usage} = $usage if $usage;
-
- my $exc = PVE::APIClient::Exception->new("Parameter verification failed.\n", %$param);
-
- my ($pkg, $filename, $line) = caller;
-
- $exc->{filename} = $filename;
- $exc->{line} = $line;
-
- die $exc;
-}
-
-sub stringify {
- my $self = shift;
-
- my $msg = $self->{code} ? "$self->{code} $self->{msg}" : $self->{msg};
-
- if ($msg !~ m/\n$/) {
-
- if ($self->{filename} && $self->{line}) {
- $msg .= " at $self->{filename} line $self->{line}";
- }
-
- $msg .= "\n";
- }
-
- if ($self->{errors}) {
- foreach my $e (keys %{$self->{errors}}) {
- $msg .= "$e: $self->{errors}->{$e}\n";
- }
- }
-
- if ($self->{propagate}) {
- foreach my $pi (@{$self->{propagate}}) {
- $msg .= "\t...propagated at $pi->[0] line $pi->[1]\n";
- }
- }
-
- if ($self->{usage}) {
- $msg .= $self->{usage};
- $msg .= "\n" if $msg !~ m/\n$/;
- }
-
- return $msg;
-}
-
-sub PROPAGATE {
- my ($self, $file, $line) = @_;
-
- push @{$self->{propagate}}, [$file, $line];
-
- return $self;
-}
-
-1;
+++ /dev/null
-package PVE::APIClient::LWP;
-
-use strict;
-use warnings;
-use URI;
-use IO::Socket::SSL; # important for SSL_verify_callback
-use LWP::UserAgent;
-use URI::Escape;
-use Net::SSLeay;
-use JSON;
-use Data::Dumper; # fixme: remove
-use HTTP::Request::Common;
-use Carp;
-use PVE::APIClient::Exception qw(raise);
-
-my $extract_data = sub {
- my ($res) = @_;
-
- croak "undefined result" if !defined($res);
- croak "undefined result data" if !exists($res->{data});
-
- return $res->{data};
-};
-
-sub get_raw {
- my ($self, $path, $param) = @_;
-
- return $self->call('GET', $path, $param);
-}
-
-sub get {
- my ($self, $path, $param) = @_;
-
- return $extract_data->($self->call('GET', $path, $param));
-}
-
-sub post_raw {
- my ($self, $path, $param) = @_;
-
- return $self->call('POST', $path, $param);
-}
-
-sub post {
- my ($self, $path, $param) = @_;
-
- return $extract_data->($self->call('POST', $path, $param));
-}
-
-sub put_raw {
- my ($self, $path, $param) = @_;
-
- return $self->call('PUT', $path, $param);
-}
-
-sub put {
- my ($self, $path, $param) = @_;
-
- return $extract_data->($self->call('PUT', $path, $param));
-}
-
-sub delete_raw {
- my ($self, $path, $param) = @_;
-
- return $self->call('DELETE', $path, $param);
-}
-
-sub delete {
- my ($self, $path, $param) = @_;
-
- return $extract_data->($self->call('DELETE', $path, $param));
-}
-
-sub update_csrftoken {
- my ($self, $csrftoken) = @_;
-
- $self->{csrftoken} = $csrftoken;
-
- my $agent = $self->{useragent};
-
- $agent->default_header('CSRFPreventionToken', $self->{csrftoken});
-}
-
-sub update_ticket {
- my ($self, $ticket) = @_;
-
- my $agent = $self->{useragent};
-
- $self->{ticket} = $ticket;
-
- my $encticket = uri_escape($ticket);
- my $cookie = "$self->{cookie_name}=$encticket; path=/; secure;";
- $agent->default_header('Cookie', $cookie);
-}
-
-sub login {
- my ($self) = @_;
-
- my $uri = URI->new();
- $uri->scheme($self->{protocol});
- $uri->host($self->{host});
- $uri->port($self->{port});
- $uri->path('/api2/json/access/ticket');
-
- my $ua = $self->{useragent};
-
- delete $self->{last_unknown_fingerprint};
-
- my $exec_login = sub {
- return $ua->post($uri, {
- username => $self->{username} || 'unknown',
- password => $self->{password} || ''});
- };
-
- my $response = $exec_login->();
-
- if (!$response->is_success) {
- if (my $fp = delete($self->{last_unknown_fingerprint})) {
- if ($self->manual_verify_fingerprint($fp)) {
- $response = $exec_login->(); # try again
- }
- }
- }
-
- if (!$response->is_success) {
- raise($response->status_line ."\n", code => $response->code)
- }
-
- my $res = from_json($response->decoded_content, {utf8 => 1, allow_nonref => 1});
-
- my $data = $extract_data->($res);
-
- $self->update_ticket($data->{ticket});
- $self->update_csrftoken($data->{CSRFPreventionToken});
-
- return $data;
-}
-
-sub manual_verify_fingerprint {
- my ($self, $fingerprint) = @_;
-
- if (!$self->{manual_verification}) {
- raise("fingerprint '$fingerprint' not verified, abort!\n");
- }
-
- print "The authenticity of host '$self->{host}' can't be established.\n" .
- "X509 SHA256 key fingerprint is $fingerprint.\n" .
- "Are you sure you want to continue connecting (yes/no)? ";
-
- my $answer = <STDIN>;
-
- my $valid = ($answer =~ m/^\s*yes\s*$/i) ? 1 : 0;
-
- $self->{cached_fingerprints}->{$fingerprint} = $valid;
-
- raise("Fingerprint not verified, abort!\n") if !$valid;
-
- if (my $cb = $self->{register_fingerprint_cb}) {
- $cb->($fingerprint) if $valid;
- }
-
- return $valid;
-}
-
-sub call {
- my ($self, $method, $path, $param) = @_;
-
- delete $self->{last_unknown_fingerprint};
-
- my $ticket = $self->{ticket};
-
- my $ua = $self->{useragent};
-
- # fixme: check ticket lifetime?
-
- if (!$ticket && $self->{username} && $self->{password}) {
- $self->login();
- }
-
- my $uri = URI->new();
- $uri->scheme($self->{protocol});
- $uri->host($self->{host});
- $uri->port($self->{port});
-
- $path =~ s!^/+!!;
-
- if ($path !~ m!^api2/!) {
- $uri->path("api2/json/$path");
- } else {
- $uri->path($path);
- }
-
- #print "CALL $method : " . $uri->as_string() . "\n";
-
- my $exec_method = sub {
-
- my $response;
- if ($method eq 'GET') {
- $uri->query_form($param);
- $response = $ua->request(HTTP::Request::Common::GET($uri));
- } elsif ($method eq 'POST') {
- $response = $ua->request(HTTP::Request::Common::POST($uri, Content => $param));
- } elsif ($method eq 'PUT') {
- # We use another temporary URI object to format
- # the application/x-www-form-urlencoded content.
-
- my $tmpurl = URI->new('http:');
- $tmpurl->query_form(%$param);
- my $content = $tmpurl->query;
-
- $response = $ua->request(HTTP::Request::Common::PUT($uri, 'Content-Type' => 'application/x-www-form-urlencoded', Content => $content));
-
- } elsif ($method eq 'DELETE') {
- $response = $ua->request(HTTP::Request::Common::DELETE($uri));
- } else {
- raise("method $method not implemented\n");
- }
- return $response;
- };
-
- my $response = $exec_method->();
-
- if (my $fp = delete($self->{last_unknown_fingerprint})) {
- if ($self->manual_verify_fingerprint($fp)) {
- $response = $exec_method->(); # try again
- }
- }
-
- #print "RESP: " . Dumper($response) . "\n";
-
- my $ct = $response->header('Content-Type') || '';
-
- if ($response->is_success) {
-
- raise("got unexpected content type", code => $response->code)
- if $ct !~ m|application/json|;
-
- return from_json($response->decoded_content, {utf8 => 1, allow_nonref => 1});
-
- } else {
-
- my $msg = $response->message;
- my $errors = eval {
- return if $ct !~ m|application/json|;
- my $res = from_json($response->decoded_content, {utf8 => 1, allow_nonref => 1});
- return $res->{errors};
- };
-
- raise("$msg\n", code => $response->code, errors => $errors);
- }
-}
-
-my $verify_cert_callback = sub {
- my ($self, $cert) = @_;
-
- # check server certificate against cache of pinned FPs
- # get fingerprint of server certificate
- my $fp = Net::SSLeay::X509_get_fingerprint($cert, 'sha256');
- return 0 if !defined($fp) || $fp eq ''; # error
-
- my $valid = $self->{cached_fingerprints}->{$fp};
- return $valid if defined($valid); # return cached result
-
- if (my $cb = $self->{verify_fingerprint_cb}) {
- $valid = $cb->($cert);
- $self->{cached_fingerprints}->{$fp} = $valid;
- return $valid;
- }
-
- $self->{last_unknown_fingerprint} = $fp;
-
- return 0;
-};
-
-sub new {
- my ($class, %param) = @_;
-
- my $ssl_default_opts = { verify_hostname => 0 };
- my $ssl_opts = $param{ssl_opts} || $ssl_default_opts;
-
- my $self = {
- username => $param{username},
- password => $param{password},
- host => $param{host} || 'localhost',
- port => $param{port},
- protocol => $param{protocol},
- cookie_name => $param{cookie_name} // 'PVEAuthCookie',
- manual_verification => $param{manual_verification},
- cached_fingerprints => $param{cached_fingerprints} || {},
- verify_fingerprint_cb => $param{verify_fingerprint_cb},
- register_fingerprint_cb => $param{register_fingerprint_cb},
- ssl_opts => $ssl_opts,
- timeout => $param{timeout} || 60,
- };
- bless $self;
-
- if (!$ssl_opts->{SSL_verify_callback}) {
- $ssl_opts->{'SSL_verify_mode'} = SSL_VERIFY_PEER;
- $ssl_opts->{'SSL_verify_callback'} = sub {
- my (undef, undef, undef, undef, $cert, $depth) = @_;
-
- # we don't care about intermediate or root certificates
- return 1 if $depth != 0;
-
- return $verify_cert_callback->($self, $cert);
- }
- }
-
- if (!$self->{port}) {
- $self->{port} = $self->{host} eq 'localhost' ? 85 : 8006;
- }
- if (!$self->{protocol}) {
- $self->{protocol} = $self->{host} eq 'localhost' ? 'http' : 'https';
- }
-
- $self->{useragent} = LWP::UserAgent->new(
- protocols_allowed => [ 'http', 'https'],
- ssl_opts => $ssl_opts,
- timeout => $self->{timeout},
- keep_alive => $param{keep_alive} // 50,
- );
-
- $self->{useragent}->default_header('Accept-Encoding' => 'gzip'); # allow gzip
-
- $self->update_ticket($param{ticket}) if $param{ticket};
- $self->update_csrftoken($param{csrftoken}) if $param{csrftoken};
-
-
- return $self;
-}
-
-1;
+libpve-apiclient-perl (3.3.2) bookworm; urgency=medium
+
+ * fix validation of self-signed cert chains
+
+ -- Proxmox Support Team <support@proxmox.com> Tue, 26 Mar 2024 09:35:54 +0100
+
+libpve-apiclient-perl (3.3.1) bookworm; urgency=medium
+
+ * lwp: set SameSite attr of auth cookie to 'strict'
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 09 Jun 2023 07:54:37 +0200
+
+libpve-apiclient-perl (3.3.0) bookworm; urgency=medium
+
+ * re-build for Debian 12 Bookworm based releases
+
+ * switch over to native versioning
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 19 May 2023 16:07:13 +0200
+
+libpve-apiclient-perl (3.2-1) bullseye; urgency=medium
+
+ * bump version for Debian 11 Bullseye based releases
+
+ -- Proxmox Support Team <support@proxmox.com> Mon, 28 Jun 2021 16:45:24 +0200
+
+libpve-apiclient-perl (3.1-3) pve pmg; urgency=medium
+
+ * improve protocol selection heuristic when using 'localhost'
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 04 Dec 2020 12:25:41 +0100
+
+libpve-apiclient-perl (3.1-2) pve pmg; urgency=medium
+
+ * client exception: try to avoid HTTP code duplication in error string
+
+ * certificate verification: trust openssl result if the hostname is getting
+ verified
+
+ * default to verifying hostname with the certificate one if no fingerprint is
+ passed
+
+ -- Proxmox Support Team <support@proxmox.com> Thu, 03 Dec 2020 16:09:02 +0100
+
+libpve-apiclient-perl (3.1-1) pve pmg; urgency=medium
+
+ * rework sharing data with the openssl certificate verify callback to avoid
+ creating a refcount cycle, slowly using up all memory
+
+ -- Proxmox Support Team <support@proxmox.com> Mon, 30 Nov 2020 15:30:20 +0100
+
+libpve-apiclient-perl (3.0-3) pve pmg; urgency=medium
+
+ * implement API token support and add a example
+
+ * fix #2227: enable totp codes to be passed in cli
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 07 Feb 2020 07:53:51 +0100
+
+libpve-apiclient-perl (3.0-2) pve pmg; urgency=medium
+
+ * check if API user has TFA setup and abort with better error message in that
+ case
+
+ -- Proxmox Support Team <support@proxmox.com> Thu, 11 Jul 2019 19:28:56 +0200
+
libpve-apiclient-perl (3.0-1) pve pmg; urgency=medium
* bump version for Debian buster
Section: perl
Priority: optional
Maintainer: Proxmox Support Team <support@proxmox.com>
-Build-Depends: debhelper (>= 9),
- perl (>= 5.10.0-19),
-Standards-Version: 4.3.0
-Homepage: http://www.proxmox.com
+Build-Depends: debhelper-compat (= 13),
+ perl,
+Standards-Version: 4.5.1
+Homepage: https://www.proxmox.com
Package: libpve-apiclient-perl
Architecture: all
+++ /dev/null
-/usr/share/perl5
-/usr/share/doc/libpve-apiclient-perl
\ No newline at end of file
+++ /dev/null
-#!/usr/bin/perl
-
-# NOTE: you need to run this on a PVE host, or modify the source to
-# provide username/password/hostname from somewhere else.
-
-use strict;
-use warnings;
-
-use PVE::APIClient::LWP;
-
-use PVE::AccessControl;
-use PVE::INotify;
-use JSON;
-
-# normally you use username/password,
-# but we can simply create a ticket and CRSF token if we are root
-# running on a pve host
-
-my $hostname = PVE::INotify::read_file("hostname");
-
-my $ticket = PVE::AccessControl::assemble_ticket('root@pam');
-my $csrftoken = PVE::AccessControl::assemble_csrf_prevention_token('root@pam');
-
-my $conn = PVE::APIClient::LWP->new(
- #username => 'root@pam',
- #password => 'yourpassword',
- ticket => $ticket,
- csrftoken => $csrftoken,
- host => $hostname,
- # allow manual fingerprint verification
- manual_verification => 1,
- );
-
-my $res = $conn->get("/", {});
-
-print to_json($res, { pretty => 1, canonical => 1});
+++ /dev/null
-#!/usr/bin/perl
-
-# NOTE: you need to run this on a PVE host, or modify the source to
-# provide username/password/hostname from somewhere else.
-
-use strict;
-use warnings;
-
-use PVE::APIClient::LWP;
-
-use PVE::AccessControl;
-use PVE::INotify;
-use JSON;
-
-# normally you use username/password,
-# but we can simply create a ticket and CRSF token if we are root
-# running on a pve host
-
-my $hostname = PVE::INotify::read_file("hostname");
-
-my $ticket = PVE::AccessControl::assemble_ticket('root@pam');
-my $csrftoken = PVE::AccessControl::assemble_csrf_prevention_token('root@pam');
-
-sub get_local_cert_fingerprint {
- my ($node) = @_;
-
- my $cert_path = "/etc/pve/nodes/$node/pve-ssl.pem";
- my $custom_cert_path = "/etc/pve/nodes/$node/pveproxy-ssl.pem";
-
- $cert_path = $custom_cert_path if -f $custom_cert_path;
-
- my $bio = Net::SSLeay::BIO_new_file($cert_path, 'r');
- my $cert = Net::SSLeay::PEM_read_bio_X509($bio);
- Net::SSLeay::BIO_free($bio);
-
- my $fp = Net::SSLeay::X509_get_fingerprint($cert, 'sha256');
- die "got empty fingerprint" if !defined($fp) || ($fp eq '');
-
- return $fp;
-}
-
-my $local_fingerprint = get_local_cert_fingerprint($hostname);
-
-my $conn = PVE::APIClient::LWP->new(
- #username => 'root@pam',
- #password => 'yourpassword',
- ticket => $ticket,
- csrftoken => $csrftoken,
- host => $hostname,
- # add local hosts cert fingerprint
- cached_fingerprints => {
- $local_fingerprint => 1,
- });
-
-my $res = $conn->get("api2/json/access/domains", {});
-print to_json($res, { pretty => 1, canonical => 1});
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-# NOTE: you need to run this on a PVE host, or modify the source to
-# provide username/password/hostname from somewhere else.
-
-use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
-
-use PVE::APIClient::LWP;
-use PVE::AccessControl;
-use PVE::INotify;
-use JSON;
-
-# normally you use username/password,
-# but we can simply create a ticket and CRSF token if we are root
-# running on a pve host
-
-my $hostname = PVE::INotify::read_file("hostname");
-my $ticket = PVE::AccessControl::assemble_ticket('root@pam');
-my $csrftoken = PVE::AccessControl::assemble_csrf_prevention_token('root@pam');
-
-my $wcount = 10;
-my $qcount = 100;
-
-sub get_local_cert_fingerprint { my ($node) = @_; my $cert_path =
- "/etc/pve/nodes/$node/pve-ssl.pem"; my $custom_cert_path =
- "/etc/pve/nodes/$node/pveproxy-ssl.pem";
-
- $cert_path = $custom_cert_path if -f $custom_cert_path;
-
- my $bio = Net::SSLeay::BIO_new_file($cert_path, 'r'); my $cert =
- Net::SSLeay::PEM_read_bio_X509($bio); Net::SSLeay::BIO_free($bio);
-
- my $fp = Net::SSLeay::X509_get_fingerprint($cert, 'sha256'); die
- "got empty fingerprint" if !defined($fp) || ($fp eq '');
-
- return $fp; }
-
-my $local_fingerprint = get_local_cert_fingerprint($hostname);
-
-sub test_rpc {
- my ($host) = @_;
-
- my $conn = PVE::APIClient::LWP->new(
- #username => 'root@pam',
- #password => 'yourpassword',
- ticket => $ticket,
- csrftoken => $csrftoken,
- host => $host,
- # add local hosts cert fingerprint
- cached_fingerprints => {
- $local_fingerprint => 1,
- });
-
- for (my $i = 0; $i < $qcount; $i++) {
- eval {
- my $res = $conn->get("/", {});
- };
- if (my $err = $@) {
- print "ERROR: $err\n";
- last;
- }
- }
-}
-
-sub run_tests {
- my ($host) = @_;
-
- my $workers;
-
- my $starttime = [gettimeofday];
-
- for (my $i = 0; $i < $wcount; $i++) {
- if (my $pid = fork ()) {
- $workers->{$pid} = 1;
- } else {
- test_rpc($host);
- exit (0);
- }
- }
-
- # wait for children
- 1 while (wait > 0);
-
- my $elapsed = int(tv_interval ($starttime) * 1000);
-
- my $tpq = $elapsed / ($wcount*$qcount);
-
- print "$host: $tpq ms per query\n";
-}
-
-run_tests("localhost"); # test 'pvedaemon'
-
-run_tests($hostname); # test 'pveproxy'
--- /dev/null
+PACKAGE ?= libpve-apiclient-perl
+
+DESTDIR=
+PERL5DIR=$(DESTDIR)/usr/share/perl5
+DOCDIR=$(DESTDIR)/usr/share/doc/$(PACKAGE)
+
+all:
+
+install: PVE/APIClient/Exception.pm PVE/APIClient/LWP.pm examples/*.pl
+ install -D -m 0644 PVE/APIClient/LWP.pm $(PERL5DIR)/PVE/APIClient/LWP.pm
+ install -m 0644 PVE/APIClient/Exception.pm $(PERL5DIR)/PVE/APIClient/Exception.pm
+ install -d -m 755 $(DOCDIR)/examples
+ install -m 0755 examples/example1.pl $(DOCDIR)/examples
+ install -m 0755 examples/example2.pl $(DOCDIR)/examples
+ install -m 0755 examples/perftest1.pl $(DOCDIR)/examples
+
+clean:
--- /dev/null
+package PVE::APIClient::Exception;
+
+# NOTE: derived from pve-common's PVE::Execption by copying and then:
+# sed -i 's/PVE::/PVE::APIClient::/g' Exception.pm
+
+# a way to add more information to exceptions (see man perlfunc (die))
+# use PVE::APIClient::Exception qw(raise);
+# raise ("my error message", code => 400, errors => { param1 => "err1", ...} );
+
+use strict;
+use warnings;
+use vars qw(@ISA @EXPORT_OK);
+require Exporter;
+use Storable qw(dclone);
+use HTTP::Status qw(:constants);
+
+@ISA = qw(Exporter);
+
+use overload '""' => sub {local $@; shift->stringify};
+use overload 'cmp' => sub {
+ my ($a, $b) = @_;
+ local $@;
+ return "$a" cmp "$b"; # compare as string
+};
+
+@EXPORT_OK = qw(raise raise_param_exc raise_perm_exc);
+
+sub new {
+ my ($class, $msg, %param) = @_;
+
+ $class = ref($class) || $class;
+
+ my $self = {
+ msg => $msg,
+ };
+
+ foreach my $p (keys %param) {
+ next if defined($self->{$p});
+ my $v = $param{$p};
+ $self->{$p} = ref($v) ? dclone($v) : $v;
+ }
+
+ return bless $self;
+}
+
+sub raise {
+
+ my $exc = PVE::APIClient::Exception->new(@_);
+
+ my ($pkg, $filename, $line) = caller;
+
+ $exc->{filename} = $filename;
+ $exc->{line} = $line;
+
+ die $exc;
+}
+
+sub raise_perm_exc {
+ my ($what) = @_;
+
+ my $param = { code => HTTP_FORBIDDEN };
+
+ my $msg = "Permission check failed";
+
+ $msg .= " ($what)" if $what;
+
+ my $exc = PVE::APIClient::Exception->new("$msg\n", %$param);
+
+ my ($pkg, $filename, $line) = caller;
+
+ $exc->{filename} = $filename;
+ $exc->{line} = $line;
+
+ die $exc;
+}
+
+sub is_param_exc {
+ my ($self) = @_;
+
+ return $self->{code} && $self->{code} eq HTTP_BAD_REQUEST;
+}
+
+sub raise_param_exc {
+ my ($errors, $usage) = @_;
+
+ my $param = {
+ code => HTTP_BAD_REQUEST,
+ errors => $errors,
+ };
+
+ $param->{usage} = $usage if $usage;
+
+ my $exc = PVE::APIClient::Exception->new("Parameter verification failed.\n", %$param);
+
+ my ($pkg, $filename, $line) = caller;
+
+ $exc->{filename} = $filename;
+ $exc->{line} = $line;
+
+ die $exc;
+}
+
+sub stringify {
+ my $self = shift;
+
+ my $msg = $self->{msg};
+ if (my $code = $self->{code}) {
+ if ($msg !~ /^\s*\Q$code\E[\s:,]/) { # avoid duplicating the error code heuristically
+ $msg = "$code $msg";
+ }
+ }
+
+ if ($msg !~ m/\n$/) {
+
+ if ($self->{filename} && $self->{line}) {
+ $msg .= " at $self->{filename} line $self->{line}";
+ }
+
+ $msg .= "\n";
+ }
+
+ if ($self->{errors}) {
+ foreach my $e (keys %{$self->{errors}}) {
+ $msg .= "$e: $self->{errors}->{$e}\n";
+ }
+ }
+
+ if ($self->{propagate}) {
+ foreach my $pi (@{$self->{propagate}}) {
+ $msg .= "\t...propagated at $pi->[0] line $pi->[1]\n";
+ }
+ }
+
+ if ($self->{usage}) {
+ $msg .= $self->{usage};
+ $msg .= "\n" if $msg !~ m/\n$/;
+ }
+
+ return $msg;
+}
+
+sub PROPAGATE {
+ my ($self, $file, $line) = @_;
+
+ push @{$self->{propagate}}, [$file, $line];
+
+ return $self;
+}
+
+1;
--- /dev/null
+package PVE::APIClient::LWP;
+
+use strict;
+use warnings;
+
+use Carp;
+use HTTP::Request::Common;
+use IO::Socket::SSL; # important for SSL_verify_callback
+use JSON;
+use LWP::UserAgent;
+use Net::SSLeay;
+use URI::Escape;
+use URI;
+
+use PVE::APIClient::Exception qw(raise);
+
+my $extract_data = sub {
+ my ($res) = @_;
+
+ croak "undefined result" if !defined($res);
+ croak "undefined result data" if !exists($res->{data});
+
+ return $res->{data};
+};
+
+sub get_raw {
+ my ($self, $path, $param) = @_;
+
+ return $self->call('GET', $path, $param);
+}
+
+sub get {
+ my ($self, $path, $param) = @_;
+
+ return $extract_data->($self->call('GET', $path, $param));
+}
+
+sub post_raw {
+ my ($self, $path, $param) = @_;
+
+ return $self->call('POST', $path, $param);
+}
+
+sub post {
+ my ($self, $path, $param) = @_;
+
+ return $extract_data->($self->call('POST', $path, $param));
+}
+
+sub put_raw {
+ my ($self, $path, $param) = @_;
+
+ return $self->call('PUT', $path, $param);
+}
+
+sub put {
+ my ($self, $path, $param) = @_;
+
+ return $extract_data->($self->call('PUT', $path, $param));
+}
+
+sub delete_raw {
+ my ($self, $path, $param) = @_;
+
+ return $self->call('DELETE', $path, $param);
+}
+
+sub delete {
+ my ($self, $path, $param) = @_;
+
+ return $extract_data->($self->call('DELETE', $path, $param));
+}
+
+sub update_csrftoken {
+ my ($self, $csrftoken) = @_;
+
+ $self->{csrftoken} = $csrftoken;
+
+ my $agent = $self->{useragent};
+
+ $agent->default_header('CSRFPreventionToken', $self->{csrftoken});
+}
+
+sub update_ticket {
+ my ($self, $ticket) = @_;
+
+ my $agent = $self->{useragent};
+
+ $self->{ticket} = $ticket;
+
+ my $encticket = uri_escape($ticket);
+ my $cookie = "$self->{cookie_name}=$encticket; path=/; secure; SameSite=Strict;";
+ $agent->default_header('Cookie', $cookie);
+}
+
+my sub two_factor_auth_login_old : prototype($$$) {
+ my ($self, $type, $challenge) = @_;
+
+ if ($type eq 'PVE:tfa') {
+ raise("TFA-enabled login currently works only with a TTY.") if !-t STDIN;
+ print "\nEnter OTP code for user $self->{username}: ";
+ my $tfa_response = <STDIN>;
+ chomp $tfa_response;
+ return $self->post('/api2/json/access/tfa', {response => $tfa_response});
+ } elsif ($type eq 'PVE:u2f') {
+ # TODO: implement u2f-enabled join
+ raise("U2F-enabled login is currently not implemented.");
+ } else {
+ raise("Authentication type '$type' not recognized, aborting!");
+ }
+}
+
+my sub extra_login_params : prototype($) {
+ my ($self) = @_;
+ return $self->{pve_new_format} ? ('new-format' => 1) : ();
+}
+
+my sub two_factor_auth_login : prototype($$$) {
+ my ($self, $challenge, $ticket) = @_;
+
+ raise("TFA-enabled login currently works only with a TTY.") if !-t STDIN;
+
+ $challenge = eval { from_json($challenge, { utf8 => 1 }) };
+ if (my $err = $@) {
+ raise("Bad TFA challenge: $err");
+ }
+ raise("Bad TFA challenge!") if !$challenge;
+
+ my @available;
+ push @available, 'totp' if $challenge->{totp};
+ push @available, 'recovery' if $challenge->{recovery};
+ push @available, 'yubico' if $challenge->{yubico};
+
+ my $selected;
+ if (@available == 1) {
+ $selected = $available[0];
+ } elsif (@available > 1) {
+ while (!defined($selected)) {
+ print "Available TFA methods:\n";
+ print "$_: $available[$_]\n" for (0..(@available - 1));
+ print "Select TFA method: ";
+ STDOUT->flush;
+ my $response = <STDIN>;
+ if ($response =~ /^\s*(\d+)\s*$/) {
+ $selected = int($response);
+ }
+ }
+ $selected = $available[$selected];
+ } else {
+ raise("TFA required, but none of the configure factors is supported over TTY, aborting!");
+ }
+
+ if ($selected eq 'recovery') {
+ my $keys = $challenge->{recovery};
+ if (@$keys <= 3) {
+ print("WARNING: Few recovery keys remaining: ");
+ } else {
+ print("The following recovery codes are available: ");
+ }
+ print(join(', ', @$keys), "\n");
+ }
+
+ print "Enter $selected code for user $self->{username}: ";
+ STDOUT->flush;
+ my $tfa_response = <STDIN>;
+ chomp $tfa_response;
+
+ return $self->post(
+ '/api2/json/access/ticket',
+ {
+ username => $self->{username},
+ password => "$selected:$tfa_response",
+ 'tfa-challenge' => $ticket,
+ (extra_login_params($self))
+ },
+ );
+}
+
+my $new_tfa_ticket_re = qr/^[^\s:]+:!tfa!([^:]+):/;
+my $old_tfa_ticket_re = qr/^([^\s!]+)![^!]*(!([0-9a-zA-Z\/.=_\-+]+))?$/;
+sub login {
+ my ($self) = @_;
+
+ my $uri = URI->new();
+ $uri->scheme($self->{protocol});
+ $uri->host($self->{host});
+ $uri->port($self->{port});
+ $uri->path('/api2/json/access/ticket');
+
+ my $ua = $self->{useragent};
+ my $username = $self->{username} // 'unknown',
+
+ delete $self->{fingerprint}->{last_unknown};
+
+ my $exec_login = sub {
+ return $ua->post($uri, {
+ username => $username,
+ password => $self->{password} || '',
+ (extra_login_params($self))
+ });
+ };
+
+ my $response = $exec_login->();
+
+ if (!$response->is_success) {
+ if (my $fp = delete($self->{fingerprint}->{last_unknown})) {
+ if ($self->manual_verify_fingerprint($fp)) {
+ $response = $exec_login->(); # try again
+ }
+ }
+ }
+
+ if (!$response->is_success) {
+ raise($response->status_line ."\n", code => $response->code)
+ }
+
+ my $res = from_json($response->decoded_content, {utf8 => 1, allow_nonref => 1});
+
+ my $data = $extract_data->($res);
+ $self->update_ticket($data->{ticket});
+ $self->update_csrftoken($data->{CSRFPreventionToken});
+
+ # handle two-factor login
+ my $ticket = $data->{ticket};
+ if ($ticket =~ $new_tfa_ticket_re) {
+ my $challenge = uri_unescape($1);
+ $data = two_factor_auth_login($self, $challenge, $ticket);
+ $self->update_ticket($data->{ticket});
+ } elsif ($ticket =~ $old_tfa_ticket_re) {
+ # handle old-style two-factor login for PVE:
+ my ($type, $challenge) = ($1, $2);
+ $data = two_factor_auth_login_old($self, $type, $challenge);
+ $self->update_ticket($data->{ticket});
+ }
+
+ return $data;
+}
+
+sub manual_verify_fingerprint {
+ my ($self, $fingerprint) = @_;
+
+ if (!$self->{manual_verification}) {
+ raise("fingerprint '$fingerprint' not verified, abort!\n");
+ }
+
+ print "The authenticity of host '$self->{host}' can't be established.\n" .
+ "X509 SHA256 key fingerprint is $fingerprint.\n" .
+ "Are you sure you want to continue connecting (yes/no)? ";
+
+ my $answer = <STDIN>;
+
+ my $valid = ($answer =~ m/^\s*yes\s*$/i) ? 1 : 0;
+
+ $self->{fingerprint}->{cache}->{$fingerprint} = $valid;
+
+ raise("Fingerprint not verified, abort!\n") if !$valid;
+
+ if (my $cb = $self->{register_fingerprint_cb}) {
+ $cb->($fingerprint) if $valid;
+ }
+
+ return $valid;
+}
+
+sub call {
+ my ($self, $method, $path, $param) = @_;
+
+ delete $self->{fingerprint}->{last_unknown};
+
+ my $ticket = $self->{ticket};
+ my $apitoken = $self->{apitoken};
+
+ my $ua = $self->{useragent};
+
+ # fixme: check ticket lifetime?
+
+ if (!$ticket && !$apitoken && $self->{username} && $self->{password}) {
+ $self->login();
+ }
+
+ my $uri = URI->new();
+ $uri->scheme($self->{protocol});
+ $uri->host($self->{host});
+ $uri->port($self->{port});
+
+ $path =~ s!^/+!!;
+
+ if ($path !~ m!^api2/!) {
+ $uri->path("api2/json/$path");
+ } else {
+ $uri->path($path);
+ }
+
+ #print "CALL $method : " . $uri->as_string() . "\n";
+
+ my $exec_method = sub {
+
+ my $response;
+ if ($method eq 'GET') {
+ $uri->query_form($param);
+ $response = $ua->request(HTTP::Request::Common::GET($uri));
+ } elsif ($method eq 'POST') {
+ $response = $ua->request(HTTP::Request::Common::POST($uri, Content => $param));
+ } elsif ($method eq 'PUT') {
+ # We use another temporary URI object to format
+ # the application/x-www-form-urlencoded content.
+
+ my $tmpurl = URI->new('http:');
+ $tmpurl->query_form(%$param);
+ my $content = $tmpurl->query;
+
+ $response = $ua->request(HTTP::Request::Common::PUT($uri, 'Content-Type' => 'application/x-www-form-urlencoded', Content => $content));
+
+ } elsif ($method eq 'DELETE') {
+ $response = $ua->request(HTTP::Request::Common::DELETE($uri));
+ } else {
+ raise("method $method not implemented\n");
+ }
+ return $response;
+ };
+
+ my $response = $exec_method->();
+
+ if (my $fp = delete($self->{fingerprint}->{last_unknown})) {
+ if ($self->manual_verify_fingerprint($fp)) {
+ $response = $exec_method->(); # try again
+ }
+ }
+
+ my $ct = $response->header('Content-Type') || '';
+
+ if ($response->is_success) {
+
+ raise("got unexpected content type", code => $response->code)
+ if $ct !~ m|application/json|;
+
+ return from_json($response->decoded_content, {utf8 => 1, allow_nonref => 1});
+
+ } else {
+
+ my $msg = $response->message;
+ my $errors = eval {
+ return if $ct !~ m|application/json|;
+ my $res = from_json($response->decoded_content, {utf8 => 1, allow_nonref => 1});
+ return $res->{errors};
+ };
+
+ raise("$msg\n", code => $response->code, errors => $errors);
+ }
+}
+
+my sub verify_cert_callback {
+ my ($fingerprint, $cert, $verify_cb) = @_;
+
+ # check server certificate against cache of pinned FPs
+ # get fingerprint of server certificate
+ my $fp = Net::SSLeay::X509_get_fingerprint($cert, 'sha256');
+ return 0 if !defined($fp) || $fp eq ''; # error
+
+ my $valid = $fingerprint->{cache}->{$fp};
+ return $valid if defined($valid); # return cached result
+
+ if ($verify_cb) {
+ $valid = $verify_cb->($cert);
+ $fingerprint->{cache}->{$fp} = $valid;
+ return $valid;
+ }
+
+ $fingerprint->{last_unknown} = $fp;
+
+ return 0;
+};
+
+sub new {
+ my ($class, %param) = @_;
+
+ my $ssl_opts = $param{ssl_opts} || {};
+
+ if (!defined($ssl_opts->{verify_hostname})) {
+ if (scalar(keys $param{cached_fingerprints}->%*) > 0) {
+ # purely trust the configured fingerprints, by default
+ $ssl_opts->{verify_hostname} = 0;
+ } else {
+ # no fingerprints passed, enforce hostname verification, by default
+ $ssl_opts->{verify_hostname} = 1;
+ }
+ }
+ # we can only really trust openssl result if it also verifies the hostname,
+ # else it's easy to intercept (MITM using valid Lets Encrypt)
+ my $trust_openssl = $ssl_opts->{verify_hostname} ? 1 : 0;
+
+ my $self = {
+ username => $param{username},
+ password => $param{password},
+ host => $param{host} || 'localhost',
+ port => $param{port},
+ protocol => $param{protocol},
+ cookie_name => $param{cookie_name} // 'PVEAuthCookie',
+ manual_verification => $param{manual_verification},
+ fingerprint => {
+ cache => $param{cached_fingerprints} || {},
+ last_unknown => undef,
+ },
+ register_fingerprint_cb => $param{register_fingerprint_cb},
+ timeout => $param{timeout} || 60,
+ pve_new_format => $param{pve_new_format},
+ };
+ bless $self, $class;
+
+ if (!$ssl_opts->{SSL_verify_callback}) {
+ $ssl_opts->{'SSL_verify_mode'} = SSL_VERIFY_PEER;
+
+ my $fingerprints = $self->{fingerprint}; # avoid passing $self, that's a RC cycle!
+ my $verify_fingerprint_cb = $param{verify_fingerprint_cb};
+ $ssl_opts->{'SSL_verify_callback'} = sub {
+ my ($openssl_valid, undef, undef, undef, $cert, $depth) = @_;
+
+ return 1 if $trust_openssl && $openssl_valid;
+
+ # Openssl encountered validation error, only allow validation to
+ # pass if fingerprint is verified
+ $trust_openssl = 0;
+
+ # We don't care about intermediate or root certificates if we don't
+ # trust openssl's validation result
+ return 1 if $depth != 0;
+
+ # We've reached the leaf certificate and the chain didn't pass
+ # openssl's validation - let's verify the fingerprint!
+ return verify_cert_callback($fingerprints, $cert, $verify_fingerprint_cb);
+ }
+ }
+
+ if (!$self->{port}) {
+ $self->{port} = $self->{host} eq 'localhost' ? 85 : 8006;
+ }
+ if (!$self->{protocol}) {
+ # cope that PBS and PVE can be installed on the same host, and one may thus use
+ # 'localhost' then - so only default to http for privileged ports, in that case,
+ # as the HTTP daemons normally run with those (e.g., 85 or 87)
+ $self->{protocol} = $self->{host} eq 'localhost' && $self->{port} < 1024
+ ? 'http'
+ : 'https'
+ ;
+ }
+
+ $self->{useragent} = LWP::UserAgent->new(
+ protocols_allowed => [ 'http', 'https'],
+ ssl_opts => $ssl_opts,
+ timeout => $self->{timeout},
+ keep_alive => $param{keep_alive} // 50,
+ );
+
+ $self->{useragent}->default_header('Accept-Encoding' => 'gzip'); # allow gzip
+
+ if ($param{apitoken} && $param{password}) {
+ warn "password will be ignored in favor of API token\n";
+ delete $self->{password};
+ }
+ if ($param{ticket}) {
+ if ($param{apitoken}) {
+ warn "ticket will be ignored in favor of API token\n";
+ } else {
+ $self->update_ticket($param{ticket});
+ }
+ }
+ $self->update_csrftoken($param{csrftoken}) if $param{csrftoken};
+
+ if ($param{apitoken}) {
+ my $agent = $self->{useragent};
+
+ $self->{apitoken} = $param{apitoken};
+
+ $agent->default_header('Authorization', $param{apitoken});
+ }
+
+ return $self;
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+# NOTE: you need to run this on a PVE host, or modify the source to
+# provide username/password/hostname from somewhere else.
+
+use strict;
+use warnings;
+
+use PVE::APIClient::LWP;
+
+use PVE::AccessControl;
+use PVE::INotify;
+use JSON;
+
+# normally you use username/password,
+# but we can simply create a ticket and CRSF token if we are root
+# running on a pve host
+
+my $hostname = PVE::INotify::read_file("hostname");
+
+my $ticket = PVE::AccessControl::assemble_ticket('root@pam');
+my $csrftoken = PVE::AccessControl::assemble_csrf_prevention_token('root@pam');
+
+my $conn = PVE::APIClient::LWP->new(
+ #username => 'root@pam',
+ #password => 'yourpassword',
+ ticket => $ticket,
+ csrftoken => $csrftoken,
+ host => $hostname,
+ # allow manual fingerprint verification
+ manual_verification => 1,
+ );
+
+my $res = $conn->get("/", {});
+
+print to_json($res, { pretty => 1, canonical => 1});
--- /dev/null
+#!/usr/bin/perl
+
+# NOTE: you need to run this on a PVE host, or modify the source to
+# provide username/password/hostname from somewhere else.
+
+use strict;
+use warnings;
+
+use PVE::APIClient::LWP;
+
+use PVE::AccessControl;
+use PVE::INotify;
+use JSON;
+
+# normally you use username/password,
+# but we can simply create a ticket and CRSF token if we are root
+# running on a pve host
+
+my $hostname = PVE::INotify::read_file("hostname");
+
+my $ticket = PVE::AccessControl::assemble_ticket('root@pam');
+my $csrftoken = PVE::AccessControl::assemble_csrf_prevention_token('root@pam');
+
+sub get_local_cert_fingerprint {
+ my ($node) = @_;
+
+ my $cert_path = "/etc/pve/nodes/$node/pve-ssl.pem";
+ my $custom_cert_path = "/etc/pve/nodes/$node/pveproxy-ssl.pem";
+
+ $cert_path = $custom_cert_path if -f $custom_cert_path;
+
+ my $bio = Net::SSLeay::BIO_new_file($cert_path, 'r');
+ my $cert = Net::SSLeay::PEM_read_bio_X509($bio);
+ Net::SSLeay::BIO_free($bio);
+
+ my $fp = Net::SSLeay::X509_get_fingerprint($cert, 'sha256');
+ die "got empty fingerprint" if !defined($fp) || ($fp eq '');
+
+ return $fp;
+}
+
+my $local_fingerprint = get_local_cert_fingerprint($hostname);
+
+my $conn = PVE::APIClient::LWP->new(
+ #username => 'root@pam',
+ #password => 'yourpassword',
+ ticket => $ticket,
+ csrftoken => $csrftoken,
+ host => $hostname,
+ # add local hosts cert fingerprint
+ cached_fingerprints => {
+ $local_fingerprint => 1,
+ });
+
+my $res = $conn->get("api2/json/access/domains", {});
+print to_json($res, { pretty => 1, canonical => 1});
--- /dev/null
+#!/usr/bin/perl
+
+# NOTE: you need to set the API token and PVE host below for this to work
+
+use strict;
+use warnings;
+
+use PVE::APIClient::LWP;
+
+use JSON;
+
+my $apitoken = 'PVEAPIToken=USER@REALM!TOKENID=TOKENVALUE';
+my $hostname = "127.0.0.1";
+
+my $conn = PVE::APIClient::LWP->new(
+ apitoken => $apitoken,
+ host => $hostname,
+ # allow manual fingerprint verification
+ manual_verification => 1,
+ );
+
+my $res = $conn->get("/access/permissions", {});
+
+print to_json($res, { pretty => 1, canonical => 1});
--- /dev/null
+#!/usr/bin/perl
+
+# NOTE: you need to run this on a PVE host, or modify the source to
+# provide username/password/hostname from somewhere else.
+
+use strict;
+use warnings;
+
+use JSON;
+
+use PVE::APIClient::LWP;
+
+sub usage {
+ print STDERR "usage: $0 <host> [<user>]\n";
+ print STDERR "\n";
+ print STDERR "Pass password in PMX_CLIENT_PASSWORD env. variable\n";
+ print STDERR "User is either CLI argument, PMX_CLIENT_USER env. variable or 'root\@pam'\n";
+ print STDERR "Pass PMX_CLIENT_FINGERPRINT env. variable for self-signed certificates.";
+ exit(1);
+}
+
+my $host = shift || usage();
+my $user = shift || $ENV{'PMX_CLIENT_USER'} || 'root@pam';
+my $pass = $ENV{'PMX_CLIENT_PASSWORD'} || usage();
+
+my $fps = {};
+
+if (my $fp = $ENV{'PMX_CLIENT_FINGERPRINT'}) {
+ $fps->{$fp} = 1;
+}
+
+my $conn = PVE::APIClient::LWP->new(
+ username => $user,
+ password => $pass,
+ host => $host,
+ cached_fingerprints => $fps,
+);
+
+my $res = $conn->get("api2/json/version", {});
+print to_json($res, { pretty => 1, canonical => 1, utf8 => 1});
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+# NOTE: you need to run this on a PVE host, or modify the source to
+# provide username/password/hostname from somewhere else.
+
+use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
+
+use PVE::APIClient::LWP;
+use PVE::AccessControl;
+use PVE::INotify;
+use JSON;
+
+# normally you use username/password,
+# but we can simply create a ticket and CRSF token if we are root
+# running on a pve host
+
+my $hostname = PVE::INotify::read_file("hostname");
+my $ticket = PVE::AccessControl::assemble_ticket('root@pam');
+my $csrftoken = PVE::AccessControl::assemble_csrf_prevention_token('root@pam');
+
+my $wcount = 10;
+my $qcount = 100;
+
+sub get_local_cert_fingerprint { my ($node) = @_; my $cert_path =
+ "/etc/pve/nodes/$node/pve-ssl.pem"; my $custom_cert_path =
+ "/etc/pve/nodes/$node/pveproxy-ssl.pem";
+
+ $cert_path = $custom_cert_path if -f $custom_cert_path;
+
+ my $bio = Net::SSLeay::BIO_new_file($cert_path, 'r'); my $cert =
+ Net::SSLeay::PEM_read_bio_X509($bio); Net::SSLeay::BIO_free($bio);
+
+ my $fp = Net::SSLeay::X509_get_fingerprint($cert, 'sha256'); die
+ "got empty fingerprint" if !defined($fp) || ($fp eq '');
+
+ return $fp; }
+
+my $local_fingerprint = get_local_cert_fingerprint($hostname);
+
+sub test_rpc {
+ my ($host) = @_;
+
+ my $conn = PVE::APIClient::LWP->new(
+ #username => 'root@pam',
+ #password => 'yourpassword',
+ ticket => $ticket,
+ csrftoken => $csrftoken,
+ host => $host,
+ # add local hosts cert fingerprint
+ cached_fingerprints => {
+ $local_fingerprint => 1,
+ });
+
+ for (my $i = 0; $i < $qcount; $i++) {
+ eval {
+ my $res = $conn->get("/", {});
+ };
+ if (my $err = $@) {
+ print "ERROR: $err\n";
+ last;
+ }
+ }
+}
+
+sub run_tests {
+ my ($host) = @_;
+
+ my $workers;
+
+ my $starttime = [gettimeofday];
+
+ for (my $i = 0; $i < $wcount; $i++) {
+ if (my $pid = fork ()) {
+ $workers->{$pid} = 1;
+ } else {
+ test_rpc($host);
+ exit (0);
+ }
+ }
+
+ # wait for children
+ 1 while (wait > 0);
+
+ my $elapsed = int(tv_interval ($starttime) * 1000);
+
+ my $tpq = $elapsed / ($wcount*$qcount);
+
+ print "$host: $tpq ms per query\n";
+}
+
+run_tests("localhost"); # test 'pvedaemon'
+
+run_tests($hostname); # test 'pveproxy'
projects / pve-apiclient.git / commitdiff