├── debian ├── docs ├── source │ └── format ├── triggers ├── rules ├── copyright └── control ├── test ├── etc_network_interfaces │ ├── active_interfaces │ ├── Makefile │ ├── t.base.pl │ ├── ip_link_details │ ├── t.unhandled-interfaces-to-manual.pl │ ├── loopback │ ├── base │ ├── base-allow-hotplug │ ├── base-auto-allow-hotplug │ ├── t.parsed_options.pl │ ├── brbase │ ├── t.keep-option-order.pl │ ├── t.base-auto-allow-hotplug.pl │ ├── t.vlan-parsing.pl │ ├── t.ifupdown2-typeless.pl │ ├── t.bridge-v4-v6.pl │ ├── t.update_network.pl │ ├── t.unknown_order.pl │ ├── t.ovs_bridge_allow.pl │ ├── t.list-interfaces.pl │ ├── runtest.pl │ └── t.create_network.pl ├── Makefile ├── file-test.pl ├── format_test.pl ├── procfs_tests.pl ├── convert_size_test.pl ├── api_parameter_test.pl ├── is_deeply_test.pl ├── lock_file.pl ├── json-schema-test.pl ├── upid-test.pl ├── calendar_event_test.pl ├── section_config_test.pl └── section_config_property_isolation_test.pl ├── .gitignore ├── src ├── PVE │ ├── AtomicFile.pm │ ├── SafeSyslog.pm │ ├── CalendarEvent.pm │ ├── Format.pm │ ├── Exception.pm │ ├── UPID.pm │ ├── Syscall.pm │ ├── IPRoute2.pm │ ├── Job │ │ └── Registry.pm │ ├── CpuSet.pm │ ├── OTP.pm │ ├── Ticket.pm │ ├── LDAP.pm │ ├── File.pm │ ├── PTY.pm │ ├── Systemd.pm │ ├── PBSClient.pm │ └── Certificate.pm └── Makefile ├── Makefile └── README.dev /debian/docs: -------------------------------------------------------------------------------- 1 | debian/SOURCE 2 | -------------------------------------------------------------------------------- /debian/source/format: -------------------------------------------------------------------------------- 1 | 3.0 (native) 2 | -------------------------------------------------------------------------------- /debian/triggers: -------------------------------------------------------------------------------- 1 | activate-noawait pve-api-updates 2 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/active_interfaces: -------------------------------------------------------------------------------- 1 | lo 2 | eth0 3 | vmbr0 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | *.deb 3 | *.changes 4 | *.buildinfo 5 | *.dsc 6 | *.tar.xz 7 | /libpve-common-perl[-_][0-9]*/ 8 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | .PHONY: check install clean distclean 3 | install: check 4 | clean: 5 | distclean: clean 6 | check: 7 | ./runtest.pl 8 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.base.pl: -------------------------------------------------------------------------------- 1 | my $wanted = load('base'); 2 | 3 | # parse the empty file 4 | r(''); 5 | expect $wanted; 6 | 7 | # idempotency 8 | # save, re-parse, and re-check 9 | r(w()); 10 | expect $wanted; 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /src/PVE/AtomicFile.pm: -------------------------------------------------------------------------------- 1 | package PVE::AtomicFile; 2 | 3 | use strict; 4 | use warnings; 5 | use IO::AtomicFile; 6 | 7 | our @ISA = qw(IO::AtomicFile); 8 | 9 | sub new { 10 | my $class = shift; 11 | my $self = $class->SUPER::new(@_); 12 | $self; 13 | } 14 | 15 | sub DESTROY { 16 | # don't close atomatically (explicit close required to commit changes) 17 | } 18 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/ip_link_details: -------------------------------------------------------------------------------- 1 | { 2 | "lo": { 3 | "ifindex": 1, 4 | "ifname": "lo", 5 | "link_type": "loopback" 6 | }, 7 | "eth0": { 8 | "ifindex": 2, 9 | "ifname": "eth0", 10 | "link_type": "ether" 11 | }, 12 | "vmbr0": { 13 | "ifindex": 3, 14 | "ifname": "vmbr0", 15 | "link_type": "ether", 16 | "linkinfo": { 17 | "info_kind": "bridge" 18 | } 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | # -*- makefile -*- 3 | # Sample debian/rules that uses debhelper. 4 | # This file was originally written by Joey Hess and Craig Small. 5 | # As a special exception, when this file is copied by dh-make into a 6 | # dh-make output file, you may use that output file without restriction. 7 | # This special exception was added by Craig Small in version 0.37 of dh-make. 8 | 9 | # Uncomment this to turn on verbose mode. 10 | #export DH_VERBOSE=1 11 | 12 | %: 13 | dh $@ 14 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.unhandled-interfaces-to-manual.pl: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Storable qw(dclone); 3 | 4 | my $ip_links = decode_json(load('ip_link_details')); 5 | 6 | for my $idx (1 .. 3) { 7 | my $entry = dclone($ip_links->{eth0}); 8 | $entry->{ifname} = "eth$idx"; 9 | 10 | $ip_links->{"eth$idx"} = $entry; 11 | } 12 | 13 | r('', $ip_links); 14 | 15 | expect load('base') . <<'IFACES'; 16 | iface eth1 inet manual 17 | 18 | iface eth2 inet manual 19 | 20 | iface eth3 inet manual 21 | 22 | IFACES 23 | 24 | 1; 25 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/loopback: -------------------------------------------------------------------------------- 1 | # network interface settings; autogenerated 2 | # Please do NOT modify this file directly, unless you know what 3 | # you're doing. 4 | # 5 | # If you want to manage parts of the network configuration manually, 6 | # please utilize the 'source' or 'source-directory' directives to do 7 | # so. 8 | # PVE will preserve these directives, but will NOT read its network 9 | # configuration from sourced files, so do not attempt to move any of 10 | # the PVE managed interfaces into external files! 11 | 12 | auto lo 13 | iface lo inet loopback 14 | 15 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/base: -------------------------------------------------------------------------------- 1 | # network interface settings; autogenerated 2 | # Please do NOT modify this file directly, unless you know what 3 | # you're doing. 4 | # 5 | # If you want to manage parts of the network configuration manually, 6 | # please utilize the 'source' or 'source-directory' directives to do 7 | # so. 8 | # PVE will preserve these directives, but will NOT read its network 9 | # configuration from sourced files, so do not attempt to move any of 10 | # the PVE managed interfaces into external files! 11 | 12 | auto lo 13 | iface lo inet loopback 14 | 15 | iface eth0 inet manual 16 | 17 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/base-allow-hotplug: -------------------------------------------------------------------------------- 1 | # network interface settings; autogenerated 2 | # Please do NOT modify this file directly, unless you know what 3 | # you're doing. 4 | # 5 | # If you want to manage parts of the network configuration manually, 6 | # please utilize the 'source' or 'source-directory' directives to do 7 | # so. 8 | # PVE will preserve these directives, but will NOT read its network 9 | # configuration from sourced files, so do not attempt to move any of 10 | # the PVE managed interfaces into external files! 11 | 12 | auto lo 13 | iface lo inet loopback 14 | 15 | allow-hotplug ens18 16 | iface ens18 inet dhcp 17 | 18 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | SUBDIRS = etc_network_interfaces 2 | TESTS = lock_file.test \ 3 | calendar_event_test.test \ 4 | convert_size_test.test \ 5 | procfs_tests.test \ 6 | format_test.test \ 7 | section_config_test.test \ 8 | api_parameter_test.test \ 9 | json-schema-test.pl \ 10 | upid-test.pl \ 11 | is_deeply_test.test \ 12 | section_config_property_isolation_test.pl \ 13 | file-test.pl \ 14 | 15 | all: 16 | 17 | .PHONY: check install clean distclean 18 | 19 | export PERLLIB=../src 20 | 21 | check: $(TESTS) 22 | for d in $(SUBDIRS); do $(MAKE) -C $$d check; done 23 | 24 | %.test: %.pl 25 | TZ=UTC-1 ./$< 26 | 27 | distclean: clean 28 | clean: 29 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/base-auto-allow-hotplug: -------------------------------------------------------------------------------- 1 | # network interface settings; autogenerated 2 | # Please do NOT modify this file directly, unless you know what 3 | # you're doing. 4 | # 5 | # If you want to manage parts of the network configuration manually, 6 | # please utilize the 'source' or 'source-directory' directives to do 7 | # so. 8 | # PVE will preserve these directives, but will NOT read its network 9 | # configuration from sourced files, so do not attempt to move any of 10 | # the PVE managed interfaces into external files! 11 | 12 | auto lo 13 | iface lo inet loopback 14 | 15 | auto ens18 16 | allow-hotplug ens18 17 | iface ens18 inet dhcp 18 | 19 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.parsed_options.pl: -------------------------------------------------------------------------------- 1 | save('proc_net_dev', <<'/proc/net/dev'); 2 | eth0: 3 | eth1: 4 | /proc/net/dev 5 | 6 | # Check for dropped or duplicated options 7 | 8 | my $ip = '192.168.0.2'; 9 | my $nm = '255.255.255.0'; 10 | my $gw = '192.168.0.1'; 11 | my $ip6 = 'fc05::2'; 12 | my $nm6 = '112'; 13 | my $gw6 = 'fc05::1'; 14 | 15 | # Load 16 | my $cfg = load('base') . <<"CHECK"; 17 | iface eth1 inet manual 18 | 19 | auto vmbr0 20 | iface vmbr0 inet static 21 | address 10.0.0.2/24 22 | gateway 10.0.0.1 23 | bridge-ports eth0 24 | bridge-stp off 25 | bridge-fd 0 26 | bridge-vlan-aware yes 27 | bridge-vids 2-4094 28 | 29 | CHECK 30 | 31 | r $cfg; 32 | expect $cfg; 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/brbase: -------------------------------------------------------------------------------- 1 | # network interface settings; autogenerated 2 | # Please do NOT modify this file directly, unless you know what 3 | # you're doing. 4 | # 5 | # If you want to manage parts of the network configuration manually, 6 | # please utilize the 'source' or 'source-directory' directives to do 7 | # so. 8 | # PVE will preserve these directives, but will NOT read its network 9 | # configuration from sourced files, so do not attempt to move any of 10 | # the PVE managed interfaces into external files! 11 | 12 | auto lo 13 | iface lo inet loopback 14 | 15 | source-directory interfaces.d 16 | 17 | iface eth0 inet manual 18 | 19 | auto vmbr0 20 | iface vmbr0 inet static 21 | address 10.0.0.2 22 | netmask 255.255.255.0 23 | gateway 10.0.0.1 24 | bridge_ports eth0 25 | bridge_stp off 26 | bridge_fd 0 27 | -------------------------------------------------------------------------------- /debian/copyright: -------------------------------------------------------------------------------- 1 | Copyright (C) 2010 - 2020 Proxmox Server Solutions GmbH 2 | 3 | This software is written by Proxmox Server Solutions GmbH 4 | 5 | This program is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU Affero General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU Affero General Public License for more details. 14 | 15 | You should have received a copy of the GNU Affero General Public License 16 | along with this program. If not, see . 17 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.keep-option-order.pl: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Storable qw(dclone); 3 | 4 | my $ip_links = decode_json(load('ip_link_details')); 5 | 6 | for my $idx (1 .. 3) { 7 | my $entry = dclone($ip_links->{eth0}); 8 | $entry->{ifname} = "eth$idx"; 9 | 10 | $ip_links->{"eth$idx"} = $entry; 11 | } 12 | 13 | # 14 | # Order of option lines between interfaces should be preserved: 15 | # eth0 is unconfigured and will thus end up at the end as 'manual' 16 | # 17 | my $ordered = <<'ORDERED'; 18 | source /etc/network/config1 19 | 20 | iface eth1 inet manual 21 | 22 | source-directory /etc/network/interfaces.d 23 | 24 | iface eth2 inet manual 25 | 26 | iface eth3 inet manual 27 | 28 | ORDERED 29 | 30 | r($ordered, $ip_links); 31 | 32 | expect(load('loopback') . $ordered . "iface eth0 inet manual\n\n"); 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.base-auto-allow-hotplug.pl: -------------------------------------------------------------------------------- 1 | use JSON; 2 | 3 | my $active_ifaces = ['lo', 'ens18', 'ens']; 4 | 5 | my $ip_links = decode_json(load('ip_link_details')); 6 | $ip_links->{ens18} = delete $ip_links->{eth0}; 7 | $ip_links->{ens18}->{ifname} = ens18; 8 | 9 | my $wanted = load('base-allow-hotplug'); 10 | 11 | # parse the config 12 | r($wanted, $ip_links, $active_ifaces); 13 | 14 | $wanted =~ s/allow-hotplug ens18/auto ens18/; # FIXME: hack! rather we need to keep allow-hotplug! 15 | 16 | expect $wanted; 17 | 18 | # idempotency (save, re-parse, and re-check) 19 | r(w(), $ip_links, $active_ifaces); 20 | expect $wanted; 21 | 22 | # parse one with both, "auto" and "allow-hotplug" 23 | my $bad = load('base-auto-allow-hotplug'); 24 | r($bad, $ip_links, $active_ifaces); 25 | 26 | # should drop the first occuring one of the conflicting options ("auto" currently) 27 | expect $wanted; 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.vlan-parsing.pl: -------------------------------------------------------------------------------- 1 | save('proc_net_dev', <<'/proc/net/dev'); 2 | eth0: 3 | eth1: 4 | /proc/net/dev 5 | 6 | # Check for dropped or duplicated options 7 | 8 | my $ip = '192.168.0.2'; 9 | my $nm = '255.255.255.0'; 10 | my $gw = '192.168.0.1'; 11 | my $ip6 = 'fc05::2'; 12 | my $nm6 = '112'; 13 | my $gw6 = 'fc05::1'; 14 | 15 | # Load 16 | my $cfg = load('base') . <<"CHECK"; 17 | iface eth1 inet manual 18 | 19 | auto vmbr0 20 | iface vmbr0 inet static 21 | address 10.0.0.2/24 22 | gateway 10.0.0.1 23 | bridge-ports eth0 24 | bridge-stp off 25 | bridge-fd 0 26 | bridge-vlan-aware yes 27 | bridge-vids 2-4094 28 | 29 | auto vmbr0.10 30 | iface vmbr0.10 inet static 31 | 32 | auto vmbr0.20 33 | iface vmbr0.20 inet static 34 | 35 | auto vmbr0.30 36 | iface vmbr0.30 inet static 37 | 38 | auto vmbr0.40 39 | iface vmbr0.40 inet static 40 | 41 | auto vmbr0.100 42 | iface vmbr0.100 inet static 43 | 44 | auto zmgmt 45 | iface zmgmt inet static 46 | vlan-id 1 47 | vlan-raw-device vmbr0 48 | 49 | CHECK 50 | 51 | r $cfg; 52 | expect $cfg; 53 | 54 | 1; 55 | -------------------------------------------------------------------------------- /src/PVE/SafeSyslog.pm: -------------------------------------------------------------------------------- 1 | package PVE::SafeSyslog; 2 | 3 | use strict; 4 | use warnings; 5 | use File::Basename; 6 | use Sys::Syslog (); 7 | use Encode; 8 | use base 'Exporter'; 9 | 10 | our $VERSION = '1.00'; 11 | 12 | our @EXPORT = qw(syslog initlog); 13 | 14 | my $log_tag = "unknown"; 15 | 16 | # never log to console - thats too slow, and 17 | # it corrupts the DBD database connection! 18 | 19 | sub syslog { 20 | my ($level, @param) = @_; 21 | 22 | $level = 'warning' if $level eq 'warn'; 23 | 24 | eval { Sys::Syslog::syslog($level, @param); }; # ignore errors 25 | } 26 | 27 | sub initlog { 28 | my ($tag, $facility) = @_; 29 | 30 | if ($tag) { 31 | $tag = basename($tag); 32 | 33 | $tag = encode("ascii", decode_utf8($tag)); 34 | 35 | $log_tag = $tag; 36 | } 37 | 38 | $facility = "daemon" if !$facility; 39 | 40 | # never log to console - thats too slow 41 | Sys::Syslog::setlogsock('unix'); 42 | 43 | Sys::Syslog::openlog($log_tag, 'pid', $facility); 44 | } 45 | 46 | sub tag { 47 | return $log_tag; 48 | } 49 | 50 | 1; 51 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.ifupdown2-typeless.pl: -------------------------------------------------------------------------------- 1 | my $ip = '10.0.0.2/24'; 2 | my $gw = '10.0.0.1'; 3 | my $ip6 = 'fc05::1:2/112'; 4 | my $gw6 = 'fc05::1:1'; 5 | 6 | r(load('base') . <<"EOF"); 7 | auto vmbr1 8 | iface vmbr1 9 | address 1.2.3.4/24 10 | address fccc::a:1/64 11 | gateway 1.2.3.1 12 | gateway fccc::1 13 | bridge-ports eth0 14 | bridge-stp off 15 | bridge-fd 0 16 | # Comment 17 | 18 | EOF 19 | 20 | my $run = 'first'; 21 | my $ifaces = $config->{ifaces}; 22 | 23 | my $ck = sub { 24 | my ($i, $v, $e) = @_; 25 | $ifaces->{$i}->{$v} eq $e 26 | or die "$run run: $i variable $v: got \"$ifaces->{$i}->{$v}\", expected: $e\n"; 27 | }; 28 | 29 | my $check_config = sub { 30 | $ck->('vmbr1', type => 'bridge'); 31 | $ck->('vmbr1', cidr => '1.2.3.4/24'); 32 | $ck->('vmbr1', gateway => '1.2.3.1'); 33 | $ck->('vmbr1', cidr6 => 'fccc::a:1/64'); 34 | $ck->('vmbr1', gateway6 => 'fccc::1'); 35 | }; 36 | 37 | $check_config->(); 38 | 39 | # idempotency 40 | save('idem', w()); 41 | r(load('idem')); 42 | expect load('idem'); 43 | 44 | $run = 'second'; 45 | $check_config->(); 46 | 47 | 1; 48 | -------------------------------------------------------------------------------- /src/PVE/CalendarEvent.pm: -------------------------------------------------------------------------------- 1 | package PVE::CalendarEvent; 2 | 3 | use strict; 4 | use warnings; 5 | use Data::Dumper; 6 | use Time::Local; 7 | use PVE::JSONSchema; 8 | use PVE::Tools qw(trim); 9 | use Proxmox::RS::CalendarEvent; 10 | 11 | # Note: This class implements a parser/utils for systemd like calendar exents 12 | # Date specification is currently not implemented 13 | 14 | my $dow_names = { 15 | sun => 0, 16 | mon => 1, 17 | tue => 2, 18 | wed => 3, 19 | thu => 4, 20 | fri => 5, 21 | sat => 6, 22 | }; 23 | 24 | PVE::JSONSchema::register_format('pve-calendar-event', \&pve_verify_calendar_event); 25 | 26 | sub pve_verify_calendar_event { 27 | my ($text, $noerr) = @_; 28 | 29 | eval { parse_calendar_event($text); }; 30 | if (my $err = $@) { 31 | return undef if $noerr; 32 | die "invalid calendar event '$text' - $err\n"; 33 | } 34 | return $text; 35 | } 36 | 37 | # The parser. 38 | # returns a $calspec hash which can be passed to compute_next_event() 39 | sub parse_calendar_event { 40 | my ($event) = @_; 41 | 42 | $event = trim($event); 43 | 44 | if ($event eq '') { 45 | die "unable to parse calendar event - event is empty\n"; 46 | } 47 | 48 | return Proxmox::RS::CalendarEvent->new($event); 49 | } 50 | 51 | sub compute_next_event { 52 | my ($calspec, $last) = @_; 53 | 54 | return $calspec->compute_next_event($last); 55 | } 56 | 57 | 1; 58 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | 2 | PREFIX=/usr 3 | BINDIR=$(PREFIX)/bin 4 | MANDIR=$(PREFIX)/share/man 5 | DOCDIR=$(PREFIX)/share/doc 6 | MAN1DIR=$(MANDIR)/man1/ 7 | PERLDIR=$(PREFIX)/share/perl5 8 | 9 | LIB_SOURCES = \ 10 | AtomicFile.pm \ 11 | CGroup.pm \ 12 | CLIFormatter.pm \ 13 | CLIHandler.pm \ 14 | CalendarEvent.pm \ 15 | Certificate.pm \ 16 | CpuSet.pm \ 17 | Daemon.pm \ 18 | Exception.pm \ 19 | File.pm \ 20 | Format.pm \ 21 | INotify.pm \ 22 | IPRoute2.pm \ 23 | JSONSchema.pm \ 24 | Job/Registry.pm \ 25 | LDAP.pm \ 26 | Network.pm \ 27 | OTP.pm \ 28 | PBSClient.pm \ 29 | PTY.pm \ 30 | ProcFSTools.pm \ 31 | RESTEnvironment.pm \ 32 | RESTHandler.pm \ 33 | SafeSyslog.pm \ 34 | SectionConfig.pm \ 35 | SysFSTools.pm \ 36 | Syscall.pm \ 37 | Systemd.pm \ 38 | Ticket.pm \ 39 | Tools.pm \ 40 | UPID.pm \ 41 | 42 | all: 43 | 44 | install: $(addprefix PVE/,$(LIB_SOURCES)) 45 | install -d -m 0755 $(DESTDIR)$(PERLDIR)/PVE 46 | install -d -m 0755 $(DESTDIR)$(PERLDIR)/PVE/Job 47 | for i in $(LIB_SOURCES); do install -D -m 0644 PVE/$$i $(DESTDIR)$(PERLDIR)/PVE/$$i; done 48 | 49 | .PHONY: check check-pod check-syntax 50 | check: check-pod check-syntax 51 | 52 | check-pod: $(addprefix PVE/,$(LIB_SOURCES)) 53 | podchecker -nowarnings $^ || [ $$? -eq 2 ] 54 | 55 | check-syntax: $(addprefix check-syntax-PVE/,$(LIB_SOURCES)) 56 | 57 | check-syntax-PVE/%: 58 | perl -I. -wc PVE/$* 59 | 60 | 61 | .PHONY: clean 62 | clean: 63 | rm -rf *~ 64 | 65 | .PHONY: distclean 66 | distclean: clean 67 | 68 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include /usr/share/dpkg/pkg-info.mk 2 | 3 | PACKAGE=libpve-common-perl 4 | 5 | ARCH=all 6 | 7 | BUILDDIR ?= $(PACKAGE)-$(DEB_VERSION_UPSTREAM) 8 | 9 | DEB=$(PACKAGE)_$(DEB_VERSION_UPSTREAM_REVISION)_$(ARCH).deb 10 | DSC=$(PACKAGE)_$(DEB_VERSION_UPSTREAM_REVISION).dsc 11 | 12 | all: 13 | $(MAKE) -C src 14 | 15 | .PHONY: tidy 16 | tidy: 17 | git ls-files ':*.p[ml]'| xargs -n4 -P0 proxmox-perltidy 18 | 19 | .PHONY: dinstall 20 | dinstall: deb 21 | dpkg -i $(DEB) 22 | 23 | $(BUILDDIR): src debian test 24 | rm -rf $(BUILDDIR) $(BUILDDIR).tmp; mkdir $(BUILDDIR).tmp 25 | cp -a -t $(BUILDDIR).tmp $^ Makefile 26 | echo "git clone git://git.proxmox.com/git/pve-common.git\\ngit checkout $(shell git rev-parse HEAD)" > $(BUILDDIR).tmp/debian/SOURCE 27 | mv $(BUILDDIR).tmp $(BUILDDIR) 28 | 29 | .PHONY: deb 30 | deb: $(DEB) 31 | $(DEB): $(BUILDDIR) 32 | cd $(BUILDDIR); dpkg-buildpackage -b -us -uc 33 | lintian $(DEB) 34 | 35 | .PHONY: dsc 36 | dsc: $(DSC) 37 | $(DSC): $(BUILDDIR) 38 | cd $(BUILDDIR); dpkg-buildpackage -S -us -uc -d 39 | lintian $(DSC) 40 | 41 | sbuild: $(DSC) 42 | sbuild $(DSC) 43 | 44 | .PHONY: clean distclean 45 | distclean: clean 46 | clean: 47 | rm -rf *~ *.deb *.changes $(PACKAGE)-[0-9]*/ *.buildinfo *.build *.dsc *.tar.?z 48 | 49 | .PHONY: check 50 | check: check-test check-src 51 | check-%: 52 | $(MAKE) -C $* check 53 | 54 | .PHONY: install 55 | install: 56 | $(MAKE) -C src install 57 | 58 | .PHONY: upload 59 | upload: UPLOAD_DIST ?= $(DEB_DISTRIBUTION) 60 | upload: $(DEB) 61 | tar cf - $(DEB)|ssh -X repoman@repo.proxmox.com -- upload --product pve,pmg --dist $(UPLOAD_DIST) 62 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.bridge-v4-v6.pl: -------------------------------------------------------------------------------- 1 | my $ip = '10.0.0.2/24'; 2 | my $gw = '10.0.0.1'; 3 | my $ip6 = 'fc05::1:2/112'; 4 | my $gw6 = 'fc05::1:1'; 5 | 6 | r(load('base')); 7 | 8 | new_iface('vmbr0', 'bridge', [{ family => 'inet' }], autostart => 1, bridge_ports => 'eth0'); 9 | 10 | expect load('base') . <<"EOF"; 11 | auto vmbr0 12 | iface vmbr0 inet manual 13 | bridge-ports eth0 14 | bridge-stp off 15 | bridge-fd 0 16 | 17 | EOF 18 | 19 | # add an ip and disable previously enabled autostart 20 | update_iface( 21 | 'vmbr0', 22 | [{ 23 | family => 'inet', 24 | address => $ip, 25 | gateway => $gw, 26 | }], 27 | autostart => 0, 28 | ); 29 | 30 | expect load('base') . <<"EOF"; 31 | iface vmbr0 inet static 32 | address $ip 33 | gateway $gw 34 | bridge-ports eth0 35 | bridge-stp off 36 | bridge-fd 0 37 | 38 | EOF 39 | save('with-ipv4', w()); 40 | 41 | update_iface( 42 | 'vmbr0', 43 | [{ 44 | family => 'inet6', 45 | address => $ip6, 46 | gateway => $gw6, 47 | }], 48 | ); 49 | 50 | expect load('with-ipv4') . <<"EOF"; 51 | iface vmbr0 inet6 static 52 | address $ip6 53 | gateway $gw6 54 | 55 | EOF 56 | 57 | # idempotency 58 | save('idem', w()); 59 | r(load('idem')); 60 | expect load('idem'); 61 | 62 | # delete vmbr0's inet 63 | delete_iface('vmbr0', 'inet'); 64 | 65 | # bridge ports must now appear in the inet6 block 66 | expect load('base') . <<"EOF"; 67 | iface vmbr0 inet6 static 68 | address $ip6 69 | gateway $gw6 70 | bridge-ports eth0 71 | bridge-stp off 72 | bridge-fd 0 73 | 74 | EOF 75 | 76 | # idempotency 77 | save('idem', w()); 78 | r(load('idem')); 79 | expect load('idem'); 80 | 81 | # delete vmbr0 completely 82 | delete_iface('vmbr0'); 83 | expect load('base'); 84 | 85 | 1; 86 | -------------------------------------------------------------------------------- /test/file-test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Basic tests for the File module 4 | 5 | use v5.36; 6 | 7 | use lib '../src'; 8 | 9 | use PVE::File; 10 | 11 | use Encode; 12 | use File::Path qw(remove_tree); 13 | use Test::More; 14 | 15 | # TODO: 16 | # - better structure the read-write tests (array of hash or the like) 17 | # - add coverage for other parameter and methods 18 | # - more tests 19 | 20 | my $test_dir = "/tmp/test-file-$$"; 21 | mkdir($test_dir) or $!{EEXIST} or die "failed to create test-dir - $!\n"; 22 | 23 | my $first_line = "Et repudiandae deleniti dolorem harum deleniti enim."; 24 | my $last_line = "Reprehenderit minus ratione quia magnam."; 25 | my $two_lines = "$first_line\n$last_line\n"; 26 | 27 | # simple write-read-compare test 28 | 29 | PVE::File::file_set_contents("$test_dir/two_lines", $two_lines); 30 | my $two_lines_written = PVE::File::file_get_contents("$test_dir/two_lines"); 31 | is_deeply($two_lines, $two_lines_written, "simple write-read-compare test with two lines"); 32 | 33 | my $first_line_written = PVE::File::file_read_first_line("$test_dir/two_lines"); 34 | is_deeply($first_line, $first_line_written, "read only first line"); 35 | 36 | my $last_line_written = PVE::File::file_read_last_line("$test_dir/two_lines"); 37 | is_deeply($last_line, $last_line_written, "read only first line"); 38 | 39 | 40 | # try $force_utf8 41 | my $wide_chars; 42 | { 43 | use utf8; 44 | $wide_chars = "ÄÖÜ™🚀🚀\n"; 45 | } 46 | my $wide_chars_encoded = Encode::encode('utf-8', $wide_chars); 47 | 48 | PVE::File::file_set_contents("$test_dir/wide_chars", $wide_chars, undef, 1); 49 | my $wide_chars_written = PVE::File::file_get_contents("$test_dir/wide_chars"); 50 | is_deeply( 51 | $wide_chars_encoded, 52 | $wide_chars_written, 53 | "simple write-read-compare test with wide-characters", 54 | ); 55 | 56 | done_testing(); 57 | 58 | remove_tree($test_dir); 59 | -------------------------------------------------------------------------------- /debian/control: -------------------------------------------------------------------------------- 1 | Source: libpve-common-perl 2 | Section: perl 3 | Priority: optional 4 | Maintainer: Proxmox Support Team 5 | Build-Depends: debhelper-compat (= 13), 6 | libanyevent-perl, 7 | libclone-perl, 8 | libdevel-cycle-perl, 9 | libfilesys-df-perl, 10 | libhttp-message-perl, 11 | libjson-perl, 12 | liblinux-inotify2-perl, 13 | libnet-ip-perl, 14 | libnetaddr-ip-perl, 15 | libproxmox-rs-perl, 16 | libstring-shellquote-perl, 17 | libtest-mockmodule-perl, 18 | libyaml-libyaml-perl, 19 | Standards-Version: 4.6.2 20 | 21 | Package: libpve-common-perl 22 | Architecture: all 23 | Depends: libanyevent-perl, 24 | libclone-perl, 25 | libcrypt-openssl-random-perl, 26 | libcrypt-openssl-rsa-perl, 27 | libdevel-cycle-perl, 28 | libfilesys-df-perl, 29 | libhttp-daemon-perl, 30 | libhttp-message-perl, 31 | libio-stringy-perl, 32 | libjson-perl, 33 | liblinux-inotify2-perl, 34 | libmime-base32-perl, 35 | libnet-dbus-perl, 36 | libnet-ip-perl, 37 | libnetaddr-ip-perl, 38 | libproxmox-acme-perl, 39 | libproxmox-rs-perl, 40 | libstring-shellquote-perl, 41 | libtimedate-perl, 42 | liburi-perl, 43 | libwww-perl, 44 | libyaml-libyaml-perl, 45 | ${misc:Depends}, 46 | ${perl:Depends}, 47 | Breaks: ifupdown2 (<< 2.0.1-1+pve5), 48 | libpve-guest-common-perl (<< 5.0.1), 49 | pmg-api (<< 7.1-5), 50 | pve-container (<< 4.3-1), 51 | pve-manager (<< 7.2-9), 52 | qemu-server (<< 8.0.1), 53 | Description: Proxmox VE base library 54 | This package contains the base library used by other Proxmox VE components. 55 | -------------------------------------------------------------------------------- /test/format_test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use lib '../src'; 7 | use PVE::JSONSchema; 8 | use PVE::CLIFormatter; 9 | 10 | use Test::More; 11 | use Test::MockModule; 12 | 13 | my $valid_configids = [ 14 | 'aa', 'a0', 'a_', 'a-', 'a-a', 'a' x 100, 'Aa', 'AA', 15 | ]; 16 | my $invalid_configids = [ 17 | 'a', 'a+', '1a', '_a', '-a', '+a', 'A', 18 | ]; 19 | 20 | my $noerr = 1; # easier to test 21 | foreach my $id (@$valid_configids) { 22 | is(PVE::JSONSchema::pve_verify_configid($id, $noerr), $id, 'valid configid'); 23 | } 24 | foreach my $id (@$invalid_configids) { 25 | is(PVE::JSONSchema::pve_verify_configid($id, $noerr), undef, 'invalid configid'); 26 | } 27 | 28 | # test some string rendering 29 | my $render_data = [ 30 | ["timestamp", 0, undef, "1970-01-01 01:00:00"], 31 | ["timestamp", 1612776831, undef, "2021-02-08 10:33:51"], 32 | ["timestamp_gmt", 0, undef, "1970-01-01 00:00:00"], 33 | ["timestamp_gmt", 1612776831, undef, "2021-02-08 09:33:51"], 34 | ["duration", undef, undef, "0s"], 35 | ["duration", 0.3, undef, "0s"], 36 | ["duration", 0, undef, "0s"], 37 | ["duration", 40, undef, "40s"], 38 | ["duration", 59.64432, undef, "1m"], 39 | ["duration", 110, undef, "1m 50s"], 40 | ["duration", 7 * 24 * 3829 * 2, undef, "2w 21h 22m 24s"], 41 | ["fraction_as_percentage", 0.412, undef, "41.20%"], 42 | ["bytes", 0, undef, "0.00 B"], 43 | ["bytes", 1023, 4, "1023.0000 B"], 44 | ["bytes", 1024, undef, "1.00 KiB"], 45 | ["bytes", 1024 * 1024 * 123 + 1024 * 300, 1, "123.3 MiB"], 46 | ["bytes", 1024 * 1024 * 1024 * 1024 * 4 + 1024 * 1024 * 2048 * 8, undef, "4.02 TiB"], 47 | ]; 48 | 49 | foreach my $data (@$render_data) { 50 | my ($renderer_name, $p1, $p2, $expected) = @$data; 51 | my $renderer = PVE::JSONSchema::get_renderer($renderer_name); 52 | my $actual = $renderer->($p1, $p2); 53 | is($actual, $expected, "string format '$renderer_name'"); 54 | } 55 | 56 | done_testing(); 57 | -------------------------------------------------------------------------------- /test/procfs_tests.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use lib '../src'; 7 | 8 | use Test::More; 9 | use Test::MockModule; 10 | 11 | use PVE::Tools; 12 | use PVE::ProcFSTools; 13 | 14 | # the proc "state" 15 | my $proc = { 16 | version => '', 17 | }; 18 | 19 | my $pve_common_tools; 20 | $pve_common_tools = Test::MockModule->new('PVE::Tools'); 21 | $pve_common_tools->mock( 22 | file_read_firstline => sub { 23 | my ($filename) = @_; 24 | 25 | $filename =~ s!^/proc/!!; 26 | 27 | my $res = $proc->{$filename}; 28 | 29 | if (ref($res) eq 'CODE') { 30 | $res = $res->(); 31 | } 32 | 33 | chomp $res; 34 | return $res; 35 | }, 36 | ); 37 | 38 | # version tests 39 | 40 | my @kernel_versions = ( 41 | { 42 | version => 43 | 'Linux version 5.3.10-1-pve (build@pve) (gcc version 8.3.0 (Debian 8.3.0-6)) #1 SMP PVE 5.3.10-1 (Thu, 14 Nov 2019 10:43:13 +0100)', 44 | expect => [5, 3, 10, '1-pve', '5.3.10-1-pve'], 45 | }, 46 | { 47 | version => 48 | 'Linux version 5.0.21-5-pve (build@pve) (gcc version 8.3.0 (Debian 8.3.0-6)) #1 SMP PVE 5.0.21-10 (Wed, 13 Nov 2019 08:27:10 +0100)', 49 | expect => [5, 0, 21, '5-pve', '5.0.21-5-pve'], 50 | }, 51 | { 52 | version => 53 | 'Linux version 5.0.21+ (build@pve) (gcc version 8.3.0 (Debian 8.3.0-6)) #27 SMP Tue Nov 12 10:30:36 CET 2019', 54 | expect => [5, 0, 21, '+', '5.0.21+'], 55 | }, 56 | { 57 | version => 58 | 'Linu$ version 2 (build@pve) (gcc version 8.3.0 (Debian 8.3.0-6)) #27 SMP Tue Nov 12 10:30:36 CET 2019', 59 | expect => [0, 0, 0, '', ''], 60 | }, 61 | ); 62 | 63 | subtest 'test kernel_version parser' => sub { 64 | for my $test (@kernel_versions) { 65 | $proc->{version} = $test->{version}; 66 | 67 | my $res = [PVE::ProcFSTools::kernel_version()]; 68 | 69 | is_deeply($res, $test->{expect}, "got version <" . $res->[4] . "> same as expected"); 70 | } 71 | }; 72 | 73 | done_testing(); 74 | -------------------------------------------------------------------------------- /src/PVE/Format.pm: -------------------------------------------------------------------------------- 1 | package PVE::Format; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use POSIX qw(strftime round); 7 | 8 | use base 'Exporter'; 9 | our @EXPORT_OK = qw( 10 | render_timestamp 11 | render_timestamp_gmt 12 | render_duration 13 | render_fraction_as_percentage 14 | render_bytes 15 | ); 16 | 17 | sub render_timestamp { 18 | my ($epoch) = @_; 19 | 20 | # ISO 8601 date format 21 | return strftime("%F %H:%M:%S", localtime($epoch)); 22 | } 23 | 24 | sub render_timestamp_gmt { 25 | my ($epoch) = @_; 26 | 27 | # ISO 8601 date format, standard Greenwich time zone 28 | return strftime("%F %H:%M:%S", gmtime($epoch)); 29 | } 30 | 31 | sub render_duration { 32 | my ($duration_in_seconds, $auto_limit_accuracy) = @_; 33 | 34 | my $text = ''; 35 | my $rest = round($duration_in_seconds // 0); 36 | 37 | return "0s" if !$rest; 38 | 39 | my $step = sub { 40 | my ($unit, $unitlength) = @_; 41 | 42 | if ((my $v = int($rest / $unitlength)) > 0) { 43 | $text .= " " if length($text); 44 | $text .= "${v}${unit}"; 45 | $rest -= $v * $unitlength; 46 | return 1; 47 | } 48 | return undef; 49 | }; 50 | 51 | my $weeks = $step->('w', 7 * 24 * 3600); 52 | my $days = $step->('d', 24 * 3600) || $weeks; 53 | $step->('h', 3600); 54 | $step->('m', 60) if !$auto_limit_accuracy || !$weeks; 55 | $step->('s', 1) if !$auto_limit_accuracy || !$days; 56 | 57 | return $text; 58 | } 59 | 60 | sub render_fraction_as_percentage { 61 | my ($fraction) = @_; 62 | 63 | return sprintf("%.2f%%", $fraction * 100); 64 | } 65 | 66 | sub render_bytes { 67 | my ($value, $precision) = @_; 68 | 69 | $precision = $precision->{precision} if ref($precision) eq 'HASH'; 70 | 71 | my @units = qw(B KiB MiB GiB TiB PiB); 72 | 73 | my $max_unit = 0; 74 | if ($value > 1023) { 75 | $max_unit = int(log($value) / log(1024)); 76 | $value /= 1024**($max_unit); 77 | } 78 | my $unit = $units[$max_unit]; 79 | return sprintf "%." . ($precision || 2) . "f $unit", $value; 80 | } 81 | 82 | 1; 83 | -------------------------------------------------------------------------------- /test/convert_size_test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib '../src'; 4 | use strict; 5 | use warnings; 6 | use Data::Dumper; 7 | use Test::More; 8 | 9 | use PVE::Tools; 10 | 11 | my $tests = [ 12 | [ 13 | 1, # input value 14 | 'gb', # from 15 | 'kb', # to 16 | undef, # no_round_up 17 | 1 * 1024 * 1024, # result 18 | undef, # error string 19 | ], 20 | [-1, 'gb', 'kb', undef, 1 * 1024 * 1024, "value '-1' is not a valid, positive number"], 21 | [1.5, 'gb', 'kb', undef, 1.5 * 1024 * 1024], 22 | [0.0005, 'gb', 'mb', undef, 1], 23 | [0.0005, 'gb', 'mb', 1, 0], 24 | ['.5', 'gb', 'kb', undef, .5 * 1024 * 1024], 25 | ['1.', 'gb', 'kb', undef, 1. * 1024 * 1024], 26 | [0.5, 'mb', 'gb', undef, 1], 27 | [0.5, 'mb', 'gb', 1, 0], 28 | ['.', 'gb', 'kb', undef, 0, "value '.' is not a valid, positive number"], 29 | ['', 'gb', 'kb', undef, 0, "no value given"], 30 | ['1.1.', 'gb', 'kb', undef, 0, "value '1.1.' is not a valid, positive number"], 31 | [500, 'kb', 'kb', undef, 500], 32 | [500000, 'b', 'kb', undef, 489], 33 | [500000, 'b', 'kb', 0, 489], 34 | [500000, 'b', 'kb', 1, 488], 35 | [128 * 1024 - 1, 'b', 'kb', 0, 128], 36 | [128 * 1024 - 1, 'b', 'kb', 1, 127], 37 | ["abcdef", 'b', 'kb', 0, 0, "value 'abcdef' is not a valid, positive number"], 38 | [undef, 'b', 'kb', 0, 0, "no value given"], 39 | [0, 'b', 'pb', 0, 0], 40 | [0, 'b', 'yb', 0, 0, "unknown 'from' and/or 'to' units (b => yb)"], 41 | [0, 'b', undef, 0, 0, "unknown 'from' and/or 'to' units (b => )"], 42 | ]; 43 | 44 | foreach my $test (@$tests) { 45 | my ($input, $from, $to, $no_round_up, $expect, $error) = @$test; 46 | 47 | my $result = eval { PVE::Tools::convert_size($input, $from, $to, $no_round_up); }; 48 | my $err = $@; 49 | $input = $input // ""; 50 | $from = $from // ""; 51 | $to = $to // ""; 52 | if ($error) { 53 | like($err, qr/^\Q$error\E/, "expected error for $input $from -> $to: $error"); 54 | } else { 55 | my $round = $no_round_up ? 'floor' : 'ceil'; 56 | is($result, $expect, "$input $from converts to $expect $to ($round)"); 57 | } 58 | } 59 | 60 | done_testing(); 61 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.update_network.pl: -------------------------------------------------------------------------------- 1 | save('proc_net_dev', <<'/proc/net/dev'); 2 | eth0: 3 | eth1: 4 | /proc/net/dev 5 | 6 | my $ip = '192.168.0.2/24'; 7 | my $gw = '192.168.0.1'; 8 | my $ip6 = 'fc05::2/112'; 9 | my $gw6 = 'fc05::1'; 10 | 11 | # Load 12 | r(load('brbase')); 13 | 14 | # Create eth1 15 | $config->{ifaces}->{eth1} = { 16 | type => 'eth', 17 | method => 'static', 18 | address => $ip, 19 | gateway => $gw, 20 | families => ['inet'], 21 | autostart => 1, 22 | }; 23 | 24 | # Check 25 | expect load('loopback') . <<"CHECK"; 26 | source-directory interfaces.d 27 | 28 | iface eth0 inet manual 29 | 30 | auto eth1 31 | iface eth1 inet static 32 | address $ip 33 | gateway $gw 34 | 35 | auto vmbr0 36 | iface vmbr0 inet static 37 | address 10.0.0.2/24 38 | gateway 10.0.0.1 39 | bridge-ports eth0 40 | bridge-stp off 41 | bridge-fd 0 42 | 43 | CHECK 44 | 45 | # Reload then modify 46 | save('ipv4', w()); 47 | r(load('ipv4')); 48 | expect load('ipv4'); 49 | 50 | $config->{ifaces}->{eth1}->{ $_->[0] } = $_->[1] 51 | foreach ( 52 | [method6 => 'static'], 53 | [address6 => $ip6], 54 | [netmask6 => $nm6], 55 | [gateway6 => $gw6], 56 | [families => ['inet', 'inet6']], 57 | ); 58 | 59 | # Check 60 | my $final = load('loopback') . <<"CHECK"; 61 | source-directory interfaces.d 62 | 63 | iface eth0 inet manual 64 | 65 | auto eth1 66 | iface eth1 inet static 67 | address $ip 68 | gateway $gw 69 | 70 | iface eth1 inet6 static 71 | address $ip6 72 | gateway $gw6 73 | 74 | auto vmbr0 75 | iface vmbr0 inet static 76 | address 10.0.0.2/24 77 | gateway 10.0.0.1 78 | bridge-ports eth0 79 | bridge-stp off 80 | bridge-fd 0 81 | 82 | CHECK 83 | expect $final; 84 | 85 | save('both', w()); 86 | r(load('both')); 87 | expect load('both'); 88 | 89 | # Reload ipv4 and replace instead of modifying 90 | r(load('ipv4')); 91 | 92 | $config->{ifaces}->{eth1} = { 93 | type => 'eth', 94 | method => 'static', 95 | address => $ip, 96 | netmask => $nm, 97 | gateway => $gw, 98 | method6 => 'static', 99 | address6 => $ip6, 100 | netmask6 => $nm6, 101 | gateway6 => $gw6, 102 | families => ['inet', 'inet6'], 103 | autostart => 1, 104 | }; 105 | expect $final; 106 | r(w()); 107 | expect $final; 108 | 109 | 1; 110 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.unknown_order.pl: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Storable qw(dclone); 3 | 4 | my $ip_links = decode_json(load('ip_link_details')); 5 | 6 | for my $idx (1 .. 5) { 7 | my $entry = dclone($ip_links->{eth0}); 8 | $entry->{ifname} = "eth$idx"; 9 | 10 | $ip_links->{"eth$idx"} = $entry; 11 | } 12 | 13 | my $base = load('loopback'); 14 | 15 | sub wanted($) { 16 | my ($ip) = @_; 17 | return $base . <<"IFACES"; 18 | auto eth0 19 | iface eth0 inet manual 20 | 21 | auto eth1 22 | iface eth1 inet manual 23 | 24 | auto eth2 25 | iface eth2 inet manual 26 | 27 | auto eth3 28 | iface eth3 inet manual 29 | 30 | auto eth4 31 | iface eth4 inet manual 32 | 33 | auto eth5 34 | iface eth5 inet manual 35 | 36 | iface eth6 inet manual 37 | 38 | iface eth7 inet manual 39 | 40 | iface bond0 inet manual 41 | bond-slaves eth0 eth1 42 | bond-miimon 100 43 | bond-mode balance-alb 44 | 45 | auto bond1 46 | iface bond1 inet static 47 | address 10.10.10.$ip/24 48 | bond-slaves eth2 eth3 49 | bond-miimon 100 50 | bond-mode balance-alb 51 | # pre-up ifconfig bond1 mtu 9000 52 | 53 | auto bond2 54 | iface bond2 inet manual 55 | bond-slaves eth4 eth5 56 | bond-miimon 100 57 | bond-mode balance-alb 58 | # Private networking 59 | 60 | iface unknown3 inet static 61 | address 0.0.0.0 62 | 63 | iface unknown4 inet static 64 | address 0.0.0.0 65 | 66 | iface unknown5 inet static 67 | address 0.0.0.0 68 | 69 | auto vmbr0 70 | iface vmbr0 inet static 71 | address 192.168.100.13/24 72 | gateway 192.168.100.1 73 | bridge-ports bond0 74 | bridge-stp off 75 | bridge-fd 0 76 | 77 | auto unknown6 78 | iface unknown6 inet static 79 | address 10.10.11.13/24 80 | pre-up ifconfig bond0 up 81 | 82 | auto vmbr3 83 | iface vmbr3 inet manual 84 | bridge-ports unknown3 85 | bridge-stp off 86 | bridge-fd 0 87 | pre-up ifup unknown3 88 | 89 | auto vmbr4 90 | iface vmbr4 inet manual 91 | bridge-ports unknown4 92 | bridge-stp off 93 | bridge-fd 0 94 | pre-up ifup unknown4 95 | 96 | auto vmbr5 97 | iface vmbr5 inet manual 98 | bridge-ports unknown5 99 | bridge-stp off 100 | bridge-fd 0 101 | pre-up ifup unknown5 102 | 103 | IFACES 104 | } 105 | 106 | r(wanted(13), $ip_links); 107 | update_iface('bond1', [{ family => 'inet', address => '10.10.10.11/24' }]); 108 | expect wanted(11); 109 | 110 | 1; 111 | -------------------------------------------------------------------------------- /test/api_parameter_test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | package PVE::TestAPIParameters; 3 | 4 | # Tests the automatic conversion of -list and array parameter types 5 | 6 | use strict; 7 | use warnings; 8 | 9 | use lib '../src'; 10 | 11 | use PVE::RESTHandler; 12 | use PVE::JSONSchema; 13 | 14 | use Test::More; 15 | 16 | use base qw(PVE::RESTHandler); 17 | 18 | my $setup = [ 19 | { 20 | name => 'list-format-with-list', 21 | parameter => { 22 | type => 'string', 23 | format => 'pve-configid-list', 24 | }, 25 | value => "foo,bar", 26 | 'value-expected' => "foo,bar", 27 | }, 28 | { 29 | name => 'array-format-with-array', 30 | parameter => { 31 | type => 'array', 32 | items => { 33 | type => 'string', 34 | format => 'pve-configid', 35 | }, 36 | }, 37 | value => ['foo', 'bar'], 38 | 'value-expected' => ['foo', 'bar'], 39 | }, 40 | # TODO: below behaviour should be deprecated with 9.x and fail with 10.x 41 | { 42 | name => 'list-format-with-alist', 43 | parameter => { 44 | type => 'string', 45 | format => 'pve-configid-list', 46 | }, 47 | value => "foo\0bar", 48 | 'value-expected' => "foo\0bar", 49 | }, 50 | { 51 | name => 'array-format-with-non-array', 52 | parameter => { 53 | type => 'array', 54 | items => { 55 | type => 'string', 56 | format => 'pve-configid', 57 | }, 58 | }, 59 | value => "foo", 60 | 'value-expected' => ['foo'], 61 | }, 62 | { 63 | name => 'list-format-with-array', 64 | parameter => { 65 | type => 'string', 66 | format => 'pve-configid-list', 67 | }, 68 | value => ['foo', 'bar'], 69 | 'value-expected' => "foo,bar", 70 | }, 71 | ]; 72 | 73 | for my $data ($setup->@*) { 74 | __PACKAGE__->register_method({ 75 | name => $data->{name}, 76 | path => $data->{name}, 77 | method => 'POST', 78 | parameters => { 79 | additionalProperties => 0, 80 | properties => { 81 | param => $data->{parameter}, 82 | }, 83 | }, 84 | returns => { type => 'null' }, 85 | code => sub { 86 | my ($param) = @_; 87 | return $param->{param}; 88 | }, 89 | }); 90 | 91 | my ($handler, $info) = __PACKAGE__->find_handler('POST', $data->{name}); 92 | my $param = { 93 | param => $data->{value}, 94 | }; 95 | 96 | my $res = $handler->handle($info, $param); 97 | is_deeply($res, $data->{'value-expected'}, $data->{name}); 98 | } 99 | 100 | done_testing(); 101 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.ovs_bridge_allow.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | 3 | use JSON; 4 | use Storable qw(dclone); 5 | 6 | my $ip_links = decode_json(load('ip_link_details')); 7 | 8 | for my $idx (1 .. 3) { 9 | my $entry = dclone($ip_links->{eth0}); 10 | $entry->{ifname} = "eth$idx"; 11 | 12 | $ip_links->{"eth$idx"} = $entry; 13 | } 14 | 15 | my $ip = '192.168.0.100/24'; 16 | my $gw = '192.168.0.1'; 17 | 18 | r('', $ip_links); 19 | 20 | new_iface( 21 | 'vmbr0', 22 | 'OVSBridge', 23 | [{ 24 | family => 'inet', 25 | address => $ip, 26 | gateway => $gw, 27 | }], 28 | autostart => 1, 29 | ); 30 | 31 | update_iface('eth0', [], autostart => 1); 32 | update_iface('eth1', [], autostart => 1); 33 | update_iface('eth2', [], autostart => 1); 34 | #update_iface('eth3', [], autostart => 1); 35 | 36 | # Check the bridge and eth interfaces 37 | expect load('loopback') . <<"/etc/network/interfaces"; 38 | auto eth0 39 | iface eth0 inet manual 40 | 41 | auto eth1 42 | iface eth1 inet manual 43 | 44 | auto eth2 45 | iface eth2 inet manual 46 | 47 | iface eth3 inet manual 48 | 49 | auto vmbr0 50 | iface vmbr0 inet static 51 | address $ip 52 | gateway $gw 53 | ovs_type OVSBridge 54 | 55 | /etc/network/interfaces 56 | 57 | # Adding an interface to the bridge needs to add allow- lines and remove 58 | # its autostart property. 59 | update_iface('vmbr0', [], ovs_ports => 'eth1 eth2'); 60 | expect load('loopback') . <<"/etc/network/interfaces"; 61 | auto eth0 62 | iface eth0 inet manual 63 | 64 | auto eth1 65 | iface eth1 inet manual 66 | ovs_type OVSPort 67 | ovs_bridge vmbr0 68 | 69 | auto eth2 70 | iface eth2 inet manual 71 | ovs_type OVSPort 72 | ovs_bridge vmbr0 73 | 74 | iface eth3 inet manual 75 | 76 | auto vmbr0 77 | iface vmbr0 inet static 78 | address $ip 79 | gateway $gw 80 | ovs_type OVSBridge 81 | ovs_ports eth1 eth2 82 | 83 | /etc/network/interfaces 84 | 85 | # Idempotency - make sure "allow-$BRIDGE $IFACE" don't get duplicated 86 | # they're stripped from $config->{options} at load-time since they're 87 | # auto-generated when writing OVSPorts. 88 | save('idem', w()); 89 | r(load('idem'), $ip_links); 90 | expect load('idem'); 91 | 92 | # Removing an ovs_port also has to remove the corresponding allow- line! 93 | # Also remember that adding interfaces to the ovs bridge removed their 94 | # autostart property, so eth2 is now without an autostart! 95 | update_iface('vmbr0', [], ovs_ports => 'eth1'); 96 | # eth2 is now autoremoved and thus loses its priority, so it appears after eth3 97 | expect load('loopback') . <<"/etc/network/interfaces"; 98 | auto eth0 99 | iface eth0 inet manual 100 | 101 | auto eth1 102 | iface eth1 inet manual 103 | ovs_type OVSPort 104 | ovs_bridge vmbr0 105 | 106 | iface eth3 inet manual 107 | 108 | iface eth2 inet manual 109 | 110 | auto vmbr0 111 | iface vmbr0 inet static 112 | address $ip 113 | gateway $gw 114 | ovs_type OVSBridge 115 | ovs_ports eth1 116 | 117 | /etc/network/interfaces 118 | 119 | 1; 120 | -------------------------------------------------------------------------------- /src/PVE/Exception.pm: -------------------------------------------------------------------------------- 1 | package PVE::Exception; 2 | 3 | # a way to add more information to exceptions (see man perlfunc (die)) 4 | # use PVE::Exception qw(raise); 5 | # raise ("my error message", code => 400, errors => { param1 => "err1", ...} ); 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use HTTP::Status qw(:constants); 11 | use Storable qw(dclone); 12 | 13 | use overload '""' => sub { local $@; shift->stringify }; 14 | use overload 'cmp' => sub { 15 | my ($a, $b) = @_; 16 | local $@; 17 | return "$a" cmp "$b"; # compare as string 18 | }; 19 | 20 | use base 'Exporter'; 21 | our @EXPORT_OK = qw(raise raise_param_exc raise_perm_exc); 22 | 23 | sub new { 24 | my ($class, $msg, %param) = @_; 25 | 26 | $class = ref($class) || $class; 27 | 28 | my $self = { 29 | msg => $msg, 30 | }; 31 | 32 | foreach my $p (keys %param) { 33 | next if defined($self->{$p}); 34 | my $v = $param{$p}; 35 | $self->{$p} = ref($v) ? dclone($v) : $v; 36 | } 37 | 38 | return bless $self, $class; 39 | } 40 | 41 | sub raise { 42 | 43 | my $exc = PVE::Exception->new(@_); 44 | 45 | my ($pkg, $filename, $line) = caller; 46 | 47 | $exc->{filename} = $filename; 48 | $exc->{line} = $line; 49 | 50 | die $exc; 51 | } 52 | 53 | sub raise_perm_exc { 54 | my ($what) = @_; 55 | 56 | my $param = { code => HTTP_FORBIDDEN }; 57 | 58 | my $msg = "Permission check failed"; 59 | 60 | $msg .= " ($what)" if $what; 61 | 62 | my $exc = PVE::Exception->new("$msg\n", %$param); 63 | 64 | my ($pkg, $filename, $line) = caller; 65 | 66 | $exc->{filename} = $filename; 67 | $exc->{line} = $line; 68 | 69 | die $exc; 70 | } 71 | 72 | sub is_param_exc { 73 | my ($self) = @_; 74 | 75 | return $self->{code} && $self->{code} eq HTTP_BAD_REQUEST; 76 | } 77 | 78 | sub raise_param_exc { 79 | my ($errors, $usage) = @_; 80 | 81 | my $param = { 82 | code => HTTP_BAD_REQUEST, 83 | errors => $errors, 84 | }; 85 | 86 | $param->{usage} = $usage if $usage; 87 | 88 | my $exc = PVE::Exception->new("Parameter verification failed.\n", %$param); 89 | 90 | my ($pkg, $filename, $line) = caller; 91 | 92 | $exc->{filename} = $filename; 93 | $exc->{line} = $line; 94 | 95 | die $exc; 96 | } 97 | 98 | sub stringify { 99 | my $self = shift; 100 | 101 | my $msg = $self->{code} ? "$self->{code} $self->{msg}" : $self->{msg}; 102 | 103 | if ($msg !~ m/\n$/) { 104 | 105 | if ($self->{filename} && $self->{line}) { 106 | $msg .= " at $self->{filename} line $self->{line}"; 107 | } 108 | 109 | $msg .= "\n"; 110 | } 111 | 112 | if ($self->{errors}) { 113 | foreach my $e (keys %{ $self->{errors} }) { 114 | $msg .= "$e: $self->{errors}->{$e}\n"; 115 | } 116 | } 117 | 118 | if ($self->{propagate}) { 119 | foreach my $pi (@{ $self->{propagate} }) { 120 | $msg .= "\t...propagated at $pi->[0] line $pi->[1]\n"; 121 | } 122 | } 123 | 124 | if ($self->{usage}) { 125 | $msg .= $self->{usage}; 126 | $msg .= "\n" if $msg !~ m/\n$/; 127 | } 128 | 129 | return $msg; 130 | } 131 | 132 | sub PROPAGATE { 133 | my ($self, $file, $line) = @_; 134 | 135 | push @{ $self->{propagate} }, [$file, $line]; 136 | 137 | return $self; 138 | } 139 | 140 | 1; 141 | -------------------------------------------------------------------------------- /test/is_deeply_test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib '../src'; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Test::More; 9 | use PVE::Tools; 10 | 11 | my $tests = [ 12 | { 13 | name => 'both undef', 14 | a => undef, 15 | b => undef, 16 | expected => 1, 17 | }, 18 | { 19 | name => 'empty string', 20 | a => '', 21 | b => '', 22 | expected => 1, 23 | }, 24 | { 25 | name => 'empty string and undef', 26 | a => '', 27 | b => undef, 28 | expected => 0, 29 | }, 30 | { 31 | name => '0 and undef', 32 | a => 0, 33 | b => undef, 34 | expected => 0, 35 | }, 36 | { 37 | name => 'equal strings', 38 | a => 'test', 39 | b => 'test', 40 | expected => 1, 41 | }, 42 | { 43 | name => 'unequal strings', 44 | a => 'test', 45 | b => 'tost', 46 | expected => 0, 47 | }, 48 | { 49 | name => 'equal numerics', 50 | a => 42, 51 | b => 42, 52 | expected => 1, 53 | }, 54 | { 55 | name => 'unequal numerics', 56 | a => 42, 57 | b => 420, 58 | expected => 0, 59 | }, 60 | { 61 | name => 'equal arrays', 62 | a => ['foo', 'bar'], 63 | b => ['foo', 'bar'], 64 | expected => 1, 65 | }, 66 | { 67 | name => 'equal empty arrays', 68 | a => [], 69 | b => [], 70 | expected => 1, 71 | }, 72 | { 73 | name => 'unequal arrays', 74 | a => ['foo', 'bar'], 75 | b => ['bar', 'foo'], 76 | expected => 0, 77 | }, 78 | { 79 | name => 'equal empty hashes', 80 | a => {}, 81 | b => {}, 82 | expected => 1, 83 | }, 84 | { 85 | name => 'equal hashes', 86 | a => { foo => 'bar' }, 87 | b => { foo => 'bar' }, 88 | expected => 1, 89 | }, 90 | { 91 | name => 'unequal hashes', 92 | a => { foo => 'bar' }, 93 | b => { bar => 'foo' }, 94 | expected => 0, 95 | }, 96 | { 97 | name => 'equal nested hashes', 98 | a => { 99 | foo => 'bar', 100 | bar => 1, 101 | list => ['foo', 'bar'], 102 | properties => { 103 | baz => 'boo', 104 | }, 105 | }, 106 | b => { 107 | foo => 'bar', 108 | bar => 1, 109 | list => ['foo', 'bar'], 110 | properties => { 111 | baz => 'boo', 112 | }, 113 | }, 114 | expected => 1, 115 | }, 116 | { 117 | name => 'unequal nested hashes', 118 | a => { 119 | foo => 'bar', 120 | bar => 1, 121 | list => ['foo', 'bar'], 122 | properties => { 123 | baz => 'boo', 124 | }, 125 | }, 126 | b => { 127 | foo => 'bar', 128 | bar => 1, 129 | list => ['foo', 'bar'], 130 | properties => { 131 | baz => undef, 132 | }, 133 | }, 134 | expected => 0, 135 | }, 136 | ]; 137 | 138 | for my $test ($tests->@*) { 139 | is(PVE::Tools::is_deeply($test->{a}, $test->{b}), $test->{expected}, $test->{name}); 140 | } 141 | 142 | done_testing(); 143 | -------------------------------------------------------------------------------- /src/PVE/UPID.pm: -------------------------------------------------------------------------------- 1 | package PVE::UPID; 2 | 3 | use v5.36; 4 | 5 | use PVE::File; 6 | 7 | # UPID means 'Unique Process ID' amd uniquely identifies a process in a cluster of nodes. 8 | # 9 | # UPIDs use the following format: 10 | # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user" 11 | 12 | my $pvelogdir = "/var/log/pve"; 13 | my $pvetaskdir = "$pvelogdir/tasks"; 14 | 15 | mkdir $pvelogdir; 16 | mkdir $pvetaskdir; 17 | 18 | sub encode($d) { 19 | # Note: pstart can be > 32bit if uptime > 497 days, so that field can get longer than 8 chars. 20 | return sprintf( 21 | "UPID:%s:%08X:%08X:%08X:%s:%s:%s:", 22 | $d->{node}, 23 | $d->{pid}, 24 | $d->{pstart}, 25 | $d->{starttime}, 26 | $d->{type}, 27 | $d->{id}, 28 | $d->{user}, 29 | ); 30 | } 31 | 32 | sub decode($upid, $noerr = 0) { 33 | # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user" 34 | # Note: allow up to 9 characters for pstart, that works for 20 years continuous uptime. 35 | if ($upid =~ 36 | m|^UPID:([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8,9}):([0-9A-Fa-f]{8}):([^:\s/]+):([^:\s/]*):([^:\s/]+):$| 37 | ) { 38 | my $res = { 39 | node => $1, 40 | pid => hex($3), 41 | # NOTE: for 9-digit hex-number perl warns about non-portable, but it still works as 42 | # asserted by a test case, we could silence the WARN handler or use Math::BigInt? 43 | pstart => hex($4), 44 | starttime => hex($5), 45 | type => $6, 46 | id => $7, 47 | user => $8, 48 | }; 49 | 50 | my $subdir = substr($5, 7, 8); 51 | my $filename = "$pvetaskdir/$subdir/$upid"; 52 | 53 | return wantarray ? ($res, $filename) : $res; 54 | } 55 | 56 | return undef if $noerr; 57 | die "unable to parse worker upid '$upid'\n"; 58 | } 59 | 60 | sub open_log($upid) { 61 | my ($task, $filename) = decode($upid); 62 | 63 | my $wwwid = getpwnam('www-data') || die "getpwnam failed"; 64 | 65 | my $new_log_fh = PVE::File::create_owned_file_fh($filename, $wwwid); 66 | 67 | return $new_log_fh; 68 | } 69 | 70 | sub read_status($upid) { 71 | my ($task, $filename) = decode($upid); 72 | 73 | my $line = eval { PVE::File::file_read_last_line($filename) }; 74 | return "unable to get last line from task log - $@" if $@; 75 | 76 | if ($line =~ m/^TASK OK$/) { 77 | return 'OK'; 78 | } elsif ($line =~ m/^TASK ERROR: (.+)$/) { 79 | return $1; 80 | } elsif ($line =~ m/^TASK (WARNINGS: \d+)$/) { 81 | return $1; 82 | } else { 83 | return "unexpected status"; 84 | } 85 | } 86 | 87 | # Check if the status returned by read_status is an error status. 88 | # If the status could not be parsed it's also treated as an error. 89 | sub status_is_error($status) { 90 | return !($status eq 'OK' || $status =~ m/^WARNINGS: \d+$/); 91 | } 92 | 93 | # takes the parsed status and returns the type, either ok, warning, error or unknown 94 | sub normalize_status_type($status) { 95 | if (!$status) { 96 | return 'unknown'; 97 | } elsif ($status eq 'OK') { 98 | return 'ok'; 99 | } elsif ($status =~ m/^WARNINGS: \d+$/) { 100 | return 'warning'; 101 | } elsif ($status eq 'unexpected status') { 102 | return 'unknown'; 103 | } else { 104 | return 'error'; 105 | } 106 | } 107 | 108 | 1; 109 | -------------------------------------------------------------------------------- /src/PVE/Syscall.pm: -------------------------------------------------------------------------------- 1 | package PVE::Syscall; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | my %syscalls; 7 | my %fsmount_constants; 8 | 9 | BEGIN { 10 | die "syscall.ph can only be required once!\n" if $INC{'syscall.ph'}; 11 | require("syscall.ph"); 12 | %syscalls = ( 13 | unshare => &SYS_unshare, 14 | setns => &SYS_setns, 15 | syncfs => &SYS_syncfs, 16 | fsync => &SYS_fsync, 17 | openat => &SYS_openat, 18 | close => &SYS_close, 19 | mkdirat => &SYS_mkdirat, 20 | mknod => &SYS_mknod, 21 | faccessat => &SYS_faccessat, 22 | setresuid => &SYS_setresuid, 23 | fallocate => &SYS_fallocate, 24 | fchownat => &SYS_fchownat, 25 | mount => &SYS_mount, 26 | renameat2 => &SYS_renameat2, 27 | open_tree => &SYS_open_tree, 28 | move_mount => &SYS_move_mount, 29 | fsopen => &SYS_fsopen, 30 | fsconfig => &SYS_fsconfig, 31 | fsmount => &SYS_fsmount, 32 | fspick => &SYS_fspick, 33 | getxattr => &SYS_getxattr, 34 | setxattr => &SYS_setxattr, 35 | fgetxattr => &SYS_fgetxattr, 36 | fsetxattr => &SYS_fsetxattr, 37 | prctl => &SYS_prctl, 38 | 39 | # Below aren't yet in perl's syscall.ph but use asm-generic, so the same across (sane) archs 40 | # -> none unknown currently, yay 41 | ); 42 | 43 | %fsmount_constants = ( 44 | OPEN_TREE_CLONE => 0x0000_0001, 45 | OPEN_TREE_CLOEXEC => 000200_0000, # octal! 46 | 47 | MOVE_MOUNT_F_SYMLINKS => 0x0000_0001, 48 | MOVE_MOUNT_F_AUTOMOUNTS => 0x0000_0002, 49 | MOVE_MOUNT_F_EMPTY_PATH => 0x0000_0004, 50 | MOVE_MOUNT_F_MASK => 0x0000_0007, 51 | 52 | MOVE_MOUNT_T_SYMLINKS => 0x0000_0010, 53 | MOVE_MOUNT_T_AUTOMOUNTS => 0x0000_0020, 54 | MOVE_MOUNT_T_EMPTY_PATH => 0x0000_0040, 55 | MOVE_MOUNT_T_MASK => 0x0000_0070, 56 | 57 | FSMOUNT_CLOEXEC => 0x0000_0001, 58 | 59 | FSOPEN_CLOEXEC => 0x0000_0001, 60 | 61 | MOUNT_ATTR_RDONLY => 0x0000_0001, 62 | MOUNT_ATTR_NOSUID => 0x0000_0002, 63 | MOUNT_ATTR_NODEV => 0x0000_0004, 64 | MOUNT_ATTR_NOEXEC => 0x0000_0008, 65 | MOUNT_ATTR_RELATIME => 0x0000_0000, 66 | MOUNT_ATTR_NOATIME => 0x0000_0010, 67 | MOUNT_ATTR_STRICTATIME => 0x0000_0020, 68 | MOUNT_ATTR_NODIRATIME => 0x0000_0080, 69 | 70 | FSPICK_CLOEXEC => 0x0000_0001, 71 | FSPICK_SYMLINK_NOFOLLOW => 0x0000_0002, 72 | FSPICK_NO_AUTOMOUNT => 0x0000_0004, 73 | FSPICK_EMPTY_PATH => 0x0000_0008, 74 | 75 | FSCONFIG_SET_FLAG => 0, 76 | FSCONFIG_SET_STRING => 1, 77 | FSCONFIG_SET_BINARY => 2, 78 | FSCONFIG_SET_PATH => 3, 79 | FSCONFIG_SET_PATH_EMPTY => 4, 80 | FSCONFIG_SET_FD => 5, 81 | FSCONFIG_CMD_CREATE => 6, 82 | FSCONFIG_CMD_RECONFIGURE => 7, 83 | ); 84 | } 85 | 86 | use constant \%syscalls; 87 | use constant \%fsmount_constants; 88 | 89 | use base 'Exporter'; 90 | 91 | our @EXPORT_OK = (keys(%syscalls), keys(%fsmount_constants), 'file_handle_result'); 92 | our %EXPORT_TAGS = (fsmount => [keys(%fsmount_constants)]); 93 | 94 | # Create a file handle from a numeric file descriptor (to make sure it's close()d when it goes out 95 | # of scope). 96 | sub file_handle_result($) { 97 | my ($fd_num) = @_; 98 | return undef if $fd_num < 0; 99 | 100 | open(my $fh, '<&=', $fd_num) 101 | or return undef; 102 | 103 | return $fh; 104 | } 105 | 106 | 1; 107 | -------------------------------------------------------------------------------- /src/PVE/IPRoute2.pm: -------------------------------------------------------------------------------- 1 | package PVE::IPRoute2; 2 | 3 | use v5.36; 4 | 5 | use JSON qw(decode_json); 6 | use PVE::Tools qw(run_command); 7 | 8 | # Some simple wrappers around the iproute2 `ip` utillity. 9 | 10 | # TODO: revisit PVE::Network et al. for some other potential canidates which are mostly thin 11 | # wrappers around ip with some (relatively minimal) data juggling before/after. 12 | 13 | sub ip_link_details() { 14 | my $link_json = ''; 15 | 16 | run_command( 17 | ['ip', '-details', '-json', 'link', 'show'], 18 | outfunc => sub { 19 | $link_json .= shift; 20 | }, 21 | ); 22 | 23 | my $links = decode_json($link_json); 24 | my %ip_links = map { $_->{ifname} => $_ } $links->@*; 25 | 26 | return \%ip_links; 27 | } 28 | 29 | sub ip_link_is_physical($ip_link) { 30 | # ether alone isn't enough, as virtual interfaces can also have link_type 'ether' 31 | return $ip_link->{link_type} eq 'ether' 32 | && (!defined($ip_link->{linkinfo}) || !defined($ip_link->{linkinfo}->{info_kind})); 33 | } 34 | 35 | sub ip_link_is_bond($ip_link) { 36 | return 37 | $ip_link->{link_type} eq 'ether' 38 | && defined($ip_link->{linkinfo}) 39 | && defined($ip_link->{linkinfo}->{info_kind}) 40 | && $ip_link->{linkinfo}->{info_kind} eq 'bond'; 41 | } 42 | 43 | sub ip_link_is_bridge($ip_link) { 44 | return 45 | defined($ip_link->{linkinfo}) 46 | && defined($ip_link->{linkinfo}->{info_kind}) 47 | && $ip_link->{linkinfo}->{info_kind} eq 'bridge'; 48 | } 49 | 50 | sub bridge_is_vlan_aware($ip_link) { 51 | if (!ip_link_is_bridge($ip_link)) { 52 | warn "passed link that isn't a bridge to bridge_is_vlan_aware"; 53 | return 0; 54 | } 55 | 56 | return 57 | defined($ip_link->{linkinfo}->{info_data}) 58 | && defined($ip_link->{linkinfo}->{info_data}->{vlan_filtering}) 59 | && $ip_link->{linkinfo}->{info_data}->{vlan_filtering} == 1; 60 | } 61 | 62 | sub ip_link_is_bridge_member($ip_link) { 63 | return 64 | defined($ip_link->{linkinfo}) 65 | && defined($ip_link->{linkinfo}->{info_slave_kind}) 66 | && $ip_link->{linkinfo}->{info_slave_kind} eq "bridge"; 67 | } 68 | 69 | sub get_physical_bridge_ports($bridge, $ip_links = undef) { 70 | $ip_links = ip_link_details() if !defined($ip_links); 71 | 72 | if (!ip_link_is_bridge($ip_links->{$bridge})) { 73 | warn "passed link that isn't a bridge to get_physical_bridge_ports"; 74 | return (); 75 | } 76 | 77 | return grep { 78 | (ip_link_is_physical($ip_links->{$_}) || ip_link_is_bond($ip_links->{$_})) 79 | && defined($ip_links->{$_}->{master}) && $ip_links->{$_}->{master} eq $bridge 80 | } keys $ip_links->%*; 81 | } 82 | 83 | sub altname_mapping($ip_links) { 84 | $ip_links = ip_link_details() if !defined($ip_links); 85 | 86 | my $altnames = {}; 87 | 88 | for my $iface_name (keys $ip_links->%*) { 89 | my $iface = $ip_links->{$iface_name}; 90 | 91 | next if !$iface->{altnames}; 92 | 93 | for my $altname ($iface->{altnames}->@*) { 94 | $altnames->{$altname} = $iface_name; 95 | } 96 | } 97 | 98 | return $altnames; 99 | } 100 | 101 | sub get_vlan_information() { 102 | my $bridge_output = ''; 103 | 104 | run_command( 105 | [ 106 | 'bridge', '-compressvlans', '-json', 'vlan', 'show', 107 | ], 108 | outfunc => sub { 109 | $bridge_output .= shift; 110 | }, 111 | ); 112 | 113 | my $data = decode_json($bridge_output); 114 | my %vlan_information = map { $_->{ifname} => $_ } $data->@*; 115 | 116 | return \%vlan_information; 117 | } 118 | 119 | 1; 120 | -------------------------------------------------------------------------------- /test/lock_file.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib '../src'; 4 | use strict; 5 | use warnings; 6 | 7 | use Socket; 8 | use POSIX (); # don't import assert() 9 | 10 | use PVE::Tools 'lock_file_full'; 11 | 12 | my $name = "test.lockfile.$$-"; 13 | 14 | # Book-keeping: 15 | 16 | my %_ran; 17 | 18 | sub new { 19 | %_ran = (); 20 | } 21 | 22 | sub ran { 23 | my ($what) = @_; 24 | $_ran{$what} = 1; 25 | } 26 | 27 | sub assert { 28 | my ($what) = @_; 29 | die "code didn't run: $what\n" if !$_ran{$what}; 30 | } 31 | 32 | sub assert_not { 33 | my ($what) = @_; 34 | die "code shouldn't have run: $what\n" if $_ran{$what}; 35 | } 36 | 37 | # Does it actually lock? (shared=0) 38 | # Can we get two simultaneous shared locks? (shared=1) 39 | sub forktest1($) { 40 | my ($shared) = @_; 41 | new(); 42 | # socket pair for synchronization 43 | socketpair(my $fmain, my $fother, AF_UNIX, SOCK_STREAM, PF_UNSPEC) 44 | or die "socketpair(): $!\n"; 45 | my $other = sub { 46 | # other side 47 | close($fmain); 48 | my $line; 49 | lock_file_full( 50 | $name, 51 | 60, 52 | $shared, 53 | sub { 54 | ran('other side'); 55 | # tell parent we've acquired the lock 56 | print {$fother} "1\n"; 57 | $fother->flush(); 58 | # wait for parent to be done trying to lock 59 | $line = <$fother>; 60 | }, 61 | ); 62 | die $@ if $@; 63 | die "parent failed\n" if !$line || $line ne "2\n"; 64 | assert('other side'); 65 | return; 66 | }; 67 | my $main = sub { 68 | # main process 69 | # Wait for our child to lock: 70 | close($fother); 71 | my $line = <$fmain>; 72 | die "child failed to acquire a lock\n" if !$line || $line ne "1\n"; 73 | lock_file_full( 74 | $name, 75 | 1, 76 | $shared, 77 | sub { 78 | ran('local side'); 79 | }, 80 | ); 81 | if ($shared) { 82 | assert('local side'); 83 | } else { 84 | assert_not('local side'); 85 | } 86 | print {$fmain} "2\n"; 87 | $fmain->flush(); 88 | }; 89 | 90 | PVE::Tools::run_fork($other, { afterfork => $main }); 91 | close($fmain); 92 | } 93 | 94 | eval { 95 | # Regular lock: 96 | new(); 97 | lock_file_full($name, 10, 0, sub { ran('single lock') }); 98 | assert('single lock'); 99 | 100 | # Lock multiple times in a row: 101 | new(); 102 | lock_file_full($name, 10, 0, sub { ran('lock A') }); 103 | assert('lock A'); 104 | lock_file_full($name, 10, 0, sub { ran('lock B') }); 105 | assert('lock B'); 106 | 107 | # Nested lock: 108 | new(); 109 | lock_file_full( 110 | $name, 111 | 10, 112 | 0, 113 | sub { 114 | ran('lock A'); 115 | lock_file_full($name, 10, 0, sub { ran('lock B') }); 116 | assert('lock B'); 117 | ran('lock C'); 118 | }, 119 | ); 120 | assert('lock A'); 121 | assert('lock B'); 122 | assert('lock C'); 123 | 124 | # Independent locks: 125 | new(); 126 | lock_file_full( 127 | $name, 128 | 10, 129 | 0, 130 | sub { 131 | ran('lock A'); 132 | # locks file "${name}2" 133 | lock_file_full($name . 2, 10, 0, sub { ran('lock B') }); 134 | assert('lock B'); 135 | ran('lock C'); 136 | }, 137 | ); 138 | assert('lock A'); 139 | assert('lock B'); 140 | assert('lock C'); 141 | 142 | # Does it actually lock? (shared=0) 143 | # Can we get two simultaneous shared locks? (shared=1) 144 | forktest1(0); 145 | forktest1(1); 146 | }; 147 | my $err = $@; 148 | system("rm $name*"); 149 | die $err if $err; 150 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.list-interfaces.pl: -------------------------------------------------------------------------------- 1 | # Assuming eth0..3 and eth100 2 | # eth0 is part of vmbr0, eth100 is part of the OVS bridge vmbr1 3 | # vmbr0 has ipv4 and ipv6, OVS only ipv4 4 | # 5 | # eth1..3 are completely un-configured as if the cards had just been physically 6 | # plugged in. 7 | # The expected behavior is to notice their existance and treat them as manually 8 | # configured interfaces. 9 | # Saving the file after reading would add the corresponding 'manual' lines. 10 | 11 | use JSON; 12 | use Storable qw(dclone); 13 | 14 | my $ip_links = decode_json(load('ip_link_details')); 15 | 16 | for my $idx (1 .. 3) { 17 | my $entry = dclone($ip_links->{eth0}); 18 | $entry->{ifname} = "eth$idx"; 19 | 20 | $ip_links->{"eth$idx"} = $entry; 21 | } 22 | 23 | my $entry = dclone($ip_links->{eth0}); 24 | $entry->{ifname} = "eth100"; 25 | $ip_links->{"eth100"} = $entry; 26 | 27 | my %wanted = ( 28 | vmbr0 => { 29 | address => '192.168.1.2', 30 | netmask => '24', 31 | cidr => '192.168.1.2/24', 32 | gateway => '192.168.1.1', 33 | address6 => 'fc05::1:1', 34 | netmask6 => '112', 35 | cidr6 => 'fc05::1:1/112', 36 | }, 37 | vmbr1 => { 38 | address => '10.0.0.5', 39 | netmask => '24', 40 | cidr => '10.0.0.5/24', 41 | }, 42 | eth2 => { 43 | address => '172.16.0.1', 44 | netmask => '24', 45 | cidr => '172.16.0.1/24', 46 | address6 => 'fc05::1:2', 47 | netmask6 => '112', 48 | cidr6 => 'fc05::1:2/112', 49 | }, 50 | ); 51 | 52 | save('interfaces', <<"/etc/network/interfaces"); 53 | auto lo 54 | iface lo inet loopback 55 | 56 | source-directory interfaces.d 57 | 58 | iface eth0 inet manual 59 | 60 | iface eth2 inet static 61 | address $wanted{eth2}->{cidr} 62 | 63 | iface eth2 inet6 static 64 | address $wanted{eth2}->{cidr6} 65 | 66 | allow-vmbr1 eth100 67 | iface eth100 inet manual 68 | ovs_type OVSPort 69 | ovs_bridge vmbr1 70 | 71 | auto vmbr0 72 | iface vmbr0 inet static 73 | address $wanted{vmbr0}->{address} 74 | netmask $wanted{vmbr0}->{netmask} 75 | gateway $wanted{vmbr0}->{gateway} 76 | bridge_ports eth0 77 | bridge_stp off 78 | bridge_fd 0 79 | 80 | iface vmbr0 inet6 static 81 | address $wanted{vmbr0}->{address6} 82 | netmask $wanted{vmbr0}->{netmask6} 83 | 84 | source-directory before-ovs.d 85 | 86 | allow-ovs vmbr1 87 | iface vmbr1 inet static 88 | address $wanted{vmbr1}->{address} 89 | netmask $wanted{vmbr1}->{netmask} 90 | ovs_type OVSBridge 91 | ovs_ports eth100 92 | 93 | source after-ovs 94 | 95 | /etc/network/interfaces 96 | 97 | r(load('interfaces'), $ip_links); 98 | save('2', w()); 99 | 100 | my $ifaces = $config->{ifaces}; 101 | 102 | # check defined interfaces 103 | defined($ifaces->{"eth$_"}) 104 | or die "missing interface: eth$_\n" 105 | foreach (0, 1, 2, 3, 100); 106 | 107 | # check configuration 108 | foreach my $ifname (keys %wanted) { 109 | my $if = $wanted{$ifname}; 110 | $ifaces->{$ifname}->{$_} eq $if->{$_} 111 | or die "unexpected $_ for interface $ifname: \"" 112 | . $ifaces->{$ifname}->{$_} 113 | . "\", expected: \"$if->{$_}\"\n" 114 | foreach (keys %$if); 115 | } 116 | 117 | my $ck = sub { 118 | my ($i, $v, $e) = @_; 119 | $ifaces->{$i}->{$v} eq $e 120 | or die "$i variable $v: got \"$ifaces->{$i}->{$v}\", expected: $e\n"; 121 | }; 122 | $ck->('vmbr0', type => 'bridge'); 123 | $ck->('vmbr1', type => 'OVSBridge'); 124 | $ck->('vmbr1', ovs_type => 'OVSBridge'); 125 | $ck->('vmbr1', ovs_ports => 'eth100'); 126 | $ck->("eth$_", type => 'eth') foreach (0, 1, 2, 3); 127 | $ck->('eth100', type => 'OVSPort'); 128 | $ck->('eth100', ovs_type => 'OVSPort'); 129 | $ck->('eth100', ovs_bridge => 'vmbr1'); 130 | 131 | my @f100 = sort @{ $ifaces->{vmbr0}->{families} }; 132 | 133 | die "invalid families defined for vmbr0" 134 | if (scalar(@f100) != 2) || ($f100[0] ne 'inet') || ($f100[1] ne 'inet6'); 135 | 136 | # idempotency 137 | r(w(), $ip_links); 138 | expect load('2'); 139 | 140 | 1; 141 | -------------------------------------------------------------------------------- /test/json-schema-test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | package PVE::TestJSONSchema; 4 | 5 | # Basic tests for the behavior of the JSON schema, like property string parsing and serializing. 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use lib '../src'; 11 | 12 | use PVE::JSONSchema qw(parse_property_string); 13 | 14 | use Test::More; 15 | 16 | # Properties of a test: 17 | # 18 | # name - describes the test, should normally be < 100 characters to keep build output somewhat clean 19 | # format - the format as passed to parse_property_string. 20 | # out - the default output, useful for multiple sub-test that should result in the same data. 21 | # subtests - object with: 22 | # in - input of the sub-test 23 | # out - expected output of the sub-test, falls back to outer `out` 24 | # must_fail - if set the test must fail and the error must match the regex defined here. 25 | my $property_string_tests = [ 26 | { 27 | name => 'default-key-with-type-boolean', 28 | format => { 29 | enabled => { 30 | type => 'boolean', 31 | default_key => 1, 32 | }, 33 | }, 34 | out => { enabled => 1 }, 35 | subtests => [ 36 | { in => "1" }, 37 | { in => "true" }, 38 | { in => "yes" }, 39 | { in => "on" }, 40 | { in => "enabled=1" }, 41 | { in => "enabled=true" }, 42 | { in => "enabled=yes" }, 43 | { in => "enabled=on" }, 44 | { in => "enabled=wrong", must_fail => qr/type check \('boolean'\) failed/ }, 45 | { in => "wrong", must_fail => qr/type check \('boolean'\) failed/ }, 46 | ], 47 | }, 48 | { 49 | name => 'no-default-key-with-type-boolean', 50 | format => { 51 | enabled => { 52 | type => 'boolean', 53 | }, 54 | }, 55 | out => { enabled => 1 }, 56 | subtests => [ 57 | { 58 | in => "1", 59 | must_fail => qr/value without key, but schema does not define a default key/, 60 | }, 61 | { 62 | in => "true", 63 | must_fail => qr/value without key, but schema does not define a default key/, 64 | }, 65 | { 66 | in => "yes", 67 | must_fail => qr/value without key, but schema does not define a default key/, 68 | }, 69 | { 70 | in => "on", 71 | must_fail => qr/value without key, but schema does not define a default key/, 72 | }, 73 | { in => "enabled=1" }, 74 | { in => "enabled=true" }, 75 | { in => "enabled=yes" }, 76 | { in => "enabled=on" }, 77 | ], 78 | }, 79 | # TODO: more tests, like complex formats and ranges and the like 80 | ]; 81 | 82 | for my $test ($property_string_tests->@*) { 83 | my $subtests = $test->{subtests} // [{ in => $test->{in}, out => $test->{out} }]; 84 | 85 | subtest $test->{name}, sub { 86 | my $i = 0; 87 | for my $subtest ($subtests->@*) { 88 | $i++; 89 | my $subtest_name = ($subtest->{name} // '') . " input '$subtest->{in}'"; 90 | eval { 91 | my $res = parse_property_string($test->{format}, $subtest->{in}); 92 | is_deeply($res, $subtest->{out} // $test->{out}, $subtest_name); 93 | }; 94 | if (my $err = $@) { 95 | if ($subtest->{must_fail} && $err =~ $subtest->{must_fail}) { 96 | pass("$subtest_name failed as expected"); 97 | } else { 98 | diag($err); 99 | fail($subtest_name); 100 | } 101 | } elsif ($subtest->{must_fail}) { 102 | fail("$subtest_name was expected to fail, but passed"); 103 | } 104 | } 105 | done_testing(); 106 | } 107 | } 108 | 109 | # TODO: other tests besides parse property? 110 | 111 | done_testing(); 112 | -------------------------------------------------------------------------------- /src/PVE/Job/Registry.pm: -------------------------------------------------------------------------------- 1 | package PVE::Job::Registry; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # The job (config) base class, normally you would use this in one of two variants: 7 | # 8 | # 1) base of directly in manager and handle everything there; great for stuff that isn't residing 9 | # outside of the manager, so that there is no cyclic dependency (forbidden!) required 10 | # 11 | # 2) use two (or even more) classes, one in the library (e.g., guest-common, access-control, ...) 12 | # basing off this module, providing the basic config implementation. Then one in pve-manager 13 | # (where every dependency is available) basing off the intermediate config one, that then holds 14 | # the implementation of the 'run` method and is used in the job manager 15 | 16 | use base qw(PVE::SectionConfig); 17 | 18 | my $defaultData = { 19 | propertyList => { 20 | type => { description => "Section type." }, 21 | # FIXME: remove below? this is the section ID, schema would only be checked if a plugin 22 | # declares this as explicit option, which isn't really required as its available anyway.. 23 | id => { 24 | description => "The ID of the job.", 25 | type => 'string', 26 | format => 'pve-configid', 27 | maxLength => 64, 28 | }, 29 | enabled => { 30 | description => "Determines if the job is enabled.", 31 | type => 'boolean', 32 | default => 1, 33 | optional => 1, 34 | }, 35 | schedule => { 36 | description => 37 | "Backup schedule. The format is a subset of `systemd` calendar events.", 38 | type => 'string', 39 | format => 'pve-calendar-event', 40 | maxLength => 128, 41 | }, 42 | comment => { 43 | optional => 1, 44 | type => 'string', 45 | description => "Description for the Job.", 46 | maxLength => 512, 47 | }, 48 | 'repeat-missed' => { 49 | optional => 1, 50 | type => 'boolean', 51 | description => "If true, the job will be run as soon as possible if it was missed" 52 | . " while the scheduler was not running.", 53 | default => 0, 54 | }, 55 | }, 56 | }; 57 | 58 | sub private { 59 | return $defaultData; 60 | } 61 | 62 | sub parse_config { 63 | my ($class, $filename, $raw, $allow_unknown) = @_; 64 | 65 | my $cfg = $class->SUPER::parse_config($filename, $raw, $allow_unknown); 66 | 67 | for my $id (keys %{ $cfg->{ids} }) { 68 | my $data = $cfg->{ids}->{$id}; 69 | my $type = $data->{type}; 70 | 71 | # FIXME: below id injection is gross, guard to avoid breaking plugins that don't declare id 72 | # as option; *iff* we want this it should be handled by section config directly. 73 | if ($defaultData->{options}->{$type} && exists $defaultData->{options}->{$type}->{id}) { 74 | $data->{id} = $id; 75 | } 76 | $data->{enabled} //= 1; 77 | 78 | $data->{comment} = PVE::Tools::decode_text($data->{comment}) if defined($data->{comment}); 79 | } 80 | 81 | return $cfg; 82 | } 83 | 84 | # call the plugin specific decode/encode code 85 | sub decode_value { 86 | my ($class, $type, $key, $value) = @_; 87 | 88 | my $plugin = __PACKAGE__->lookup($type); 89 | return $plugin->decode_value($type, $key, $value); 90 | } 91 | 92 | sub encode_value { 93 | my ($class, $type, $key, $value) = @_; 94 | 95 | my $plugin = __PACKAGE__->lookup($type); 96 | return $plugin->encode_value($type, $key, $value); 97 | } 98 | 99 | sub write_config { 100 | my ($class, $filename, $cfg, $allow_unknown) = @_; 101 | 102 | for my $job (values $cfg->{ids}->%*) { 103 | $job->{comment} = PVE::Tools::encode_text($job->{comment}) if defined($job->{comment}); 104 | } 105 | 106 | $class->SUPER::write_config($filename, $cfg, $allow_unknown); 107 | } 108 | 109 | sub run { 110 | my ($class, $cfg) = @_; 111 | 112 | die "not implemented"; # implement in subclass 113 | } 114 | 115 | 1; 116 | -------------------------------------------------------------------------------- /src/PVE/CpuSet.pm: -------------------------------------------------------------------------------- 1 | package PVE::CpuSet; 2 | 3 | use strict; 4 | use warnings; 5 | use PVE::Tools; 6 | use PVE::ProcFSTools; 7 | 8 | sub new { 9 | my ($class, $members) = @_; 10 | 11 | $members //= {}; 12 | my $self = bless { members => $members }, $class; 13 | 14 | return $self; 15 | } 16 | 17 | # Create a new set with the contents of a cgroup-v1 subdirectory. 18 | # Deprecated: 19 | sub new_from_cgroup { 20 | my ($class, $cgroup, $effective) = @_; 21 | 22 | return $class->new_from_path("/sys/fs/cgroup/cpuset/$cgroup", $effective); 23 | } 24 | 25 | # Create a new set from the contents of a complete path to a cgroup directory. 26 | sub new_from_path { 27 | my ($class, $path, $effective) = @_; 28 | 29 | my $filename; 30 | if ($effective) { 31 | $filename = "$path/cpuset.effective_cpus"; 32 | if (!-e $filename) { 33 | # cgroupv2: 34 | $filename = "$path/cpuset.cpus.effective"; 35 | } 36 | } else { 37 | $filename = "$path/cpuset.cpus"; 38 | } 39 | 40 | my $set_text = PVE::Tools::file_read_firstline($filename) // ''; 41 | 42 | my ($count, $members) = parse_cpuset($set_text); 43 | 44 | return $class->new($members); 45 | } 46 | 47 | sub parse_cpuset { 48 | my ($set_text) = @_; 49 | 50 | my $members = {}; 51 | my $count = 0; 52 | 53 | foreach my $part (split(/,/, $set_text)) { 54 | if ($part =~ /^\s*(\d+)(?:-(\d+))?\s*$/) { 55 | my ($from, $to) = ($1, $2); 56 | $to //= $1; 57 | die "invalid range: $part ($to < $from)\n" if $to < $from; 58 | for (my $i = $from; $i <= $to; $i++) { 59 | $members->{$i} = 1; 60 | $count++; 61 | } 62 | } else { 63 | die "invalid range: $part\n"; 64 | } 65 | } 66 | 67 | return ($count, $members); 68 | } 69 | 70 | # Deprecated: 71 | sub write_to_cgroup { 72 | my ($self, $cgroup) = @_; 73 | 74 | return $self->write_to_path("/sys/fs/cgroup/cpuset/$cgroup"); 75 | } 76 | 77 | # Takes the cgroup directory containing the cpuset.cpus file (to be closer to 78 | # new_from_path behavior this doesn't take the complete file name). 79 | sub write_to_path { 80 | my ($self, $path) = @_; 81 | 82 | my $filename = "$path/cpuset.cpus"; 83 | 84 | my $value = ''; 85 | my @members = $self->members(); 86 | foreach my $cpuid (@members) { 87 | $value .= ',' if length($value); 88 | $value .= $cpuid; 89 | } 90 | 91 | open(my $fh, '>', $filename) || die "failed to open '$filename' - $!\n"; 92 | PVE::Tools::safe_print($filename, $fh, "$value\n"); 93 | close($fh) || die "failed to close '$filename' - $!\n"; 94 | } 95 | 96 | sub insert { 97 | my ($self, @members) = @_; 98 | 99 | my $count = 0; 100 | 101 | foreach my $cpu (@members) { 102 | next if $self->{members}->{$cpu}; 103 | $self->{members}->{$cpu} = 1; 104 | $count++; 105 | } 106 | 107 | return $count; 108 | } 109 | 110 | sub delete { 111 | my ($self, @members) = @_; 112 | 113 | my $count = 0; 114 | 115 | foreach my $cpu (@members) { 116 | next if !$self->{members}->{$cpu}; 117 | delete $self->{members}->{$cpu}; 118 | $count++; 119 | } 120 | 121 | return $count; 122 | } 123 | 124 | sub has { 125 | my ($self, $cpuid) = @_; 126 | 127 | return $self->{members}->{$cpuid}; 128 | } 129 | 130 | # members: this list is always sorted! 131 | sub members { 132 | my ($self) = @_; 133 | 134 | my @sorted_members = sort { $a <=> $b } keys %{ $self->{members} }; 135 | return @sorted_members; 136 | } 137 | 138 | sub size { 139 | my ($self) = @_; 140 | 141 | return scalar(keys %{ $self->{members} }); 142 | } 143 | 144 | sub is_equal { 145 | my ($self, $set2) = @_; 146 | 147 | my $members1 = $self->{members}; 148 | my $members2 = $set2->{members}; 149 | 150 | foreach my $id (keys %$members1) { 151 | return 0 if !$members2->{$id}; 152 | } 153 | foreach my $id (keys %$members2) { 154 | return 0 if !$members1->{$id}; 155 | } 156 | 157 | return 1; 158 | } 159 | 160 | sub short_string { 161 | my ($self) = @_; 162 | 163 | my @members = $self->members(); 164 | 165 | my $res = ''; 166 | my ($last, $next); 167 | foreach my $cpu (@members) { 168 | if (!defined($last)) { 169 | $last = $next = $cpu; 170 | } elsif (($next + 1) == $cpu) { 171 | $next = $cpu; 172 | } else { 173 | $res .= ',' if length($res); 174 | if ($last != $next) { 175 | $res .= "$last-$next"; 176 | } else { 177 | $res .= "$last"; 178 | } 179 | $last = $next = $cpu; 180 | } 181 | } 182 | 183 | if (defined($last)) { 184 | $res .= ',' if length($res); 185 | if ($last != $next) { 186 | $res .= "$last-$next"; 187 | } else { 188 | $res .= "$last"; 189 | } 190 | } 191 | 192 | return $res; 193 | } 194 | 195 | 1; 196 | -------------------------------------------------------------------------------- /test/upid-test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | package PVE::TestUPID; 4 | 5 | # Basic tests for the UPID module 6 | 7 | use v5.36; 8 | 9 | use lib '../src'; 10 | 11 | use PVE::UPID; 12 | 13 | use JSON qw(to_json); 14 | use Test::MockModule; 15 | use Test::More; 16 | 17 | # Properties of a test: 18 | # 19 | # in - input string of the test 20 | # out - expected output object of the test 21 | # must_fail - if set to truthy the test must fail 22 | my $test_upids = [ 23 | { 24 | in => 'UPID:example-node:0000C346:165A0CE4:68D7279C:aptupdate::root@pam:', 25 | out => { 26 | id => '', 27 | node => 'example-node', 28 | pid => 49990, 29 | pstart => 375000292, 30 | starttime => 1758930844, 31 | type => 'aptupdate', 32 | user => 'root@pam', 33 | }, 34 | }, 35 | { 36 | in => 'UPID:example-node:000934AF:0D015579:68BF3A41:hastart:100:root@pam:', 37 | out => { 38 | id => '100', 39 | node => 'example-node', 40 | pid => 603311, 41 | pstart => 218191225, 42 | starttime => 1757362753, 43 | type => 'hastart', 44 | user => 'root@pam', 45 | }, 46 | }, 47 | { 48 | # complex auth ID (long user name and API token) 49 | in => 50 | 'UPID:example-node:000934AF:0D015579:68BF3A41:vzdump:100:91a1da29-a47d-11f0-84e0-fafbfc944d00@pam!some-token:', 51 | out => { 52 | id => '100', 53 | node => 'example-node', 54 | pid => 603311, 55 | pstart => 218191225, 56 | starttime => 1757362753, 57 | type => 'vzdump', 58 | user => '91a1da29-a47d-11f0-84e0-fafbfc944d00@pam!some-token', 59 | }, 60 | }, 61 | { 62 | # test a 9-digit pstart (~ 20y uptime) 63 | in => 'UPID:example-node:000934AF:FFFFFFFFF:68BF3A41:fake-but-valid-type:100:root@pam:', 64 | out => { 65 | id => '100', 66 | node => 'example-node', 67 | pid => 603311, 68 | pstart => 68719476735, 69 | starttime => 1757362753, 70 | type => 'fake-but-valid-type', 71 | user => 'root@pam', 72 | }, 73 | }, 74 | { 75 | # UPID cannot contain spaces 76 | in => 'UPID:example-node:000934AF:0D015579:68BF3A41:broken type string:100:root@pam:', 77 | must_fail => 1, 78 | }, 79 | { 80 | # some simple negative case to ensure we fail there. 81 | in => 'invalid garbage', 82 | must_fail => 1, 83 | }, 84 | ]; 85 | 86 | my $i = 0; 87 | for my $test ($test_upids->@*) { 88 | $i++; 89 | my ($in, $out) = $test->@{ 'in', 'out' }; 90 | 91 | my $test_name = "decode test case $i - input '$in'"; 92 | my $task = eval { 93 | my $task = PVE::UPID::decode($in); 94 | is_deeply($task, $out, $test_name); 95 | return $task; 96 | }; 97 | if (my $err = $@) { 98 | if ($test->{must_fail}) { 99 | pass("$test_name failed as expected"); 100 | } else { 101 | diag($err); 102 | fail($test_name); 103 | } 104 | } elsif ($test->{must_fail}) { 105 | fail("$test_name was expected to fail, but passed"); 106 | } else { 107 | my $task_as_json = to_json($task, { canonical => 1 }); 108 | $test_name = "encode test case $i - input '$task_as_json'"; 109 | my $upid = PVE::UPID::encode($task); 110 | is_deeply($upid, $in, $test_name); 111 | } 112 | } 113 | 114 | my $test_task_logs = { 115 | 'task-ok' => { 116 | expected_status => 'OK', 117 | log => "Some log line\nTASK OK\n", 118 | }, 119 | 'task-err' => { 120 | expected_status => 'Some error message', 121 | log => "Some log line\nTASK ERROR: Some error message\n", 122 | }, 123 | 'task-unexpected-status' => { 124 | expected_status => 'unexpected status', 125 | log => "", 126 | }, 127 | 'task-warn' => { 128 | expected_status => 'WARNINGS: 42', 129 | log => "Some log line\nTASK WARNINGS: 42\n", 130 | }, 131 | }; 132 | my @test_task_log_names = sort keys $test_task_logs->%*; 133 | 134 | # prepare test data to make using them easier 135 | $test_task_logs->{$_}->{upid} = "UPID:example-node:0000C346:165A0CE4:68D7279C:${_}::root\@pam:" 136 | for keys $test_task_logs->%*; 137 | 138 | my $task_log_filesystem = 139 | { map { ("/var/log/pve/tasks/C/$test_task_logs->{$_}->{upid}" => $test_task_logs->{$_}) } 140 | @test_task_log_names }; 141 | 142 | my $mock_pve_file = Test::MockModule->new("PVE::File")->redefine( 143 | 'file_read_last_line' => sub($filename) { 144 | die "file '$filename' not found" if !$task_log_filesystem->{$filename}; 145 | 146 | my $file_content = $task_log_filesystem->{$filename}->{log}; 147 | 148 | return $file_content if $file_content !~ m/\n?(.+)$/; 149 | 150 | return $1; 151 | }, 152 | ); 153 | 154 | for my $task_log (sort keys $test_task_logs->%*) { 155 | my $task = $test_task_logs->{$task_log}; 156 | 157 | my $status = PVE::UPID::read_status($task->{upid}); 158 | 159 | is_deeply($status, $task->{expected_status}, "task log test '$task_log'"); 160 | } 161 | 162 | # TODO: other tests besides decode-encode cycle? 163 | 164 | done_testing(); 165 | -------------------------------------------------------------------------------- /src/PVE/OTP.pm: -------------------------------------------------------------------------------- 1 | package PVE::OTP; 2 | 3 | use strict; 4 | use warnings; 5 | use Digest::SHA; 6 | use MIME::Base32; #libmime-base32-perl 7 | use MIME::Base64; 8 | use URI::Escape; 9 | use HTTP::Request; 10 | use LWP::UserAgent; 11 | 12 | use PVE::Tools; 13 | 14 | # hotp/totp code 15 | 16 | sub hotp($$;$) { 17 | my ($binsecret, $number, $digits) = @_; 18 | 19 | $digits = 6 if !defined($digits); 20 | 21 | my $bincounter = pack('Q>', $number); 22 | my $hmac = Digest::SHA::hmac_sha1($bincounter, $binsecret); 23 | 24 | my $offset = unpack('C', substr($hmac, 19) & pack('C', 0x0F)); 25 | my $part = substr($hmac, $offset, 4); 26 | my $otp = unpack('N', $part); 27 | my $value = ($otp & 0x7fffffff) % (10**$digits); 28 | return sprintf("%0${digits}d", $value); 29 | } 30 | 31 | # experimental code for yubico OTP verification 32 | 33 | sub yubico_compute_param_sig { 34 | my ($param, $api_key) = @_; 35 | 36 | my $paramstr = ''; 37 | foreach my $key (sort keys %$param) { 38 | $paramstr .= '&' if $paramstr; 39 | $paramstr .= "$key=$param->{$key}"; 40 | } 41 | 42 | # hmac_sha1_base64 does not add '=' padding characters, so we use encode_base64 43 | my $sig = uri_escape( 44 | encode_base64(Digest::SHA::hmac_sha1($paramstr, decode_base64($api_key || '')), '')); 45 | 46 | return ($paramstr, $sig); 47 | } 48 | 49 | sub yubico_verify_otp { 50 | my ($otp, $keys, $url, $api_id, $api_key, $proxy) = @_; 51 | 52 | die "yubico: missing password\n" if !defined($otp); 53 | die "yubico: missing API ID\n" if !defined($api_id); 54 | die "yubico: missing API KEY\n" if !defined($api_key); 55 | die "yubico: no associated yubico keys\n" if $keys =~ m/^\s+$/; 56 | 57 | die "yubico: wrong OTP length\n" if (length($otp) < 32) || (length($otp) > 48); 58 | 59 | $url = 'https://api2.yubico.com/wsapi/2.0/verify' if !defined($url); 60 | 61 | my $params = { 62 | nonce => Digest::SHA::hmac_sha1_hex(time(), rand()), 63 | id => $api_id, 64 | otp => uri_escape($otp), 65 | timestamp => 1, 66 | }; 67 | 68 | my ($paramstr, $sig) = yubico_compute_param_sig($params, $api_key); 69 | 70 | $paramstr .= "&h=$sig" if $api_key; 71 | 72 | my $req = HTTP::Request->new('GET' => "$url?$paramstr"); 73 | 74 | my $ua = LWP::UserAgent->new(protocols_allowed => ['http', 'https'], timeout => 30); 75 | 76 | if ($proxy) { 77 | $ua->proxy(['http', 'https'], $proxy); 78 | } else { 79 | $ua->env_proxy; 80 | } 81 | 82 | my $response = $ua->request($req); 83 | my $code = $response->code; 84 | 85 | if ($code != 200) { 86 | my $msg = $response->message || 'unknown'; 87 | die "Invalid response from server: $code $msg\n"; 88 | } 89 | 90 | my $raw = $response->decoded_content; 91 | 92 | my $result = {}; 93 | foreach my $kvpair (split(/\n/, $raw)) { 94 | chomp $kvpair; 95 | if ($kvpair =~ /^\S+=/) { 96 | my ($k, $v) = split(/=/, $kvpair, 2); 97 | $v =~ s/\s//g; 98 | $result->{$k} = $v; 99 | } 100 | } 101 | 102 | my $rsig = $result->{h}; 103 | delete $result->{h}; 104 | 105 | if ($api_key) { 106 | my ($datastr, $vsig) = yubico_compute_param_sig($result, $api_key); 107 | $vsig = uri_unescape($vsig); 108 | die "yubico: result signature verification failed\n" if $rsig ne $vsig; 109 | } 110 | 111 | die "yubico auth failed: $result->{status}\n" if $result->{status} ne 'OK'; 112 | 113 | my $publicid = $result->{publicid} = substr(lc($result->{otp}), 0, 12); 114 | 115 | my $found; 116 | foreach my $k (PVE::Tools::split_list($keys)) { 117 | if ($k eq $publicid) { 118 | $found = 1; 119 | last; 120 | } 121 | } 122 | 123 | die "yubico auth failed: key does not belong to user\n" if !$found; 124 | 125 | return $result; 126 | } 127 | 128 | sub oath_verify_otp { 129 | my ($otp, $keys, $step, $digits) = @_; 130 | 131 | die "oath: missing password\n" if !defined($otp); 132 | die "oath: no associated oath keys\n" if $keys =~ m/^\s+$/; 133 | 134 | $step = 30 if !$step; 135 | $digits = 6 if !$digits; 136 | 137 | my $found; 138 | foreach my $k (PVE::Tools::split_list($keys)) { 139 | # Note: we generate 3 values to allow small time drift 140 | my $binkey; 141 | if ($k =~ /^v2-0x([0-9a-fA-F]+)$/) { 142 | # v2, hex 143 | $binkey = pack('H*', $1); 144 | } elsif ($k =~ /^v2-([A-Z2-7=]+)$/) { 145 | # v2, base32 146 | $binkey = MIME::Base32::decode_rfc3548($1); 147 | } elsif ($k =~ /^[A-Z2-7=]{16}$/) { 148 | $binkey = MIME::Base32::decode_rfc3548($k); 149 | } elsif ($k =~ /^[A-Fa-f0-9]{40}$/) { 150 | $binkey = pack('H*', $k); 151 | } else { 152 | die "unrecognized key format, must be hex or base32 encoded\n"; 153 | } 154 | 155 | # force integer division for time/step 156 | use integer; 157 | my $now = time() / $step - 1; 158 | $found = 1 if $otp eq hotp($binkey, $now + 0, $digits); 159 | $found = 1 if $otp eq hotp($binkey, $now + 1, $digits); 160 | $found = 1 if $otp eq hotp($binkey, $now + 2, $digits); 161 | last if $found; 162 | } 163 | 164 | die "oath auth failed\n" if !$found; 165 | } 166 | 167 | 1; 168 | -------------------------------------------------------------------------------- /src/PVE/Ticket.pm: -------------------------------------------------------------------------------- 1 | package PVE::Ticket; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Crypt::OpenSSL::Random; 7 | use Crypt::OpenSSL::RSA; 8 | use MIME::Base64; 9 | use Digest::SHA; 10 | use Time::HiRes qw(gettimeofday); 11 | use URI::Escape; 12 | 13 | use PVE::Exception qw(raise); 14 | 15 | Crypt::OpenSSL::RSA->import_random_seed(); 16 | 17 | use constant HTTP_UNAUTHORIZED => 401; 18 | 19 | sub assemble_csrf_prevention_token { 20 | my ($secret, $username) = @_; 21 | 22 | my $timestamp = sprintf("%08X", time()); 23 | 24 | my $digest = Digest::SHA::hmac_sha256_base64("$timestamp:$username", $secret); 25 | 26 | return "$timestamp:$digest"; 27 | } 28 | 29 | sub verify_csrf_prevention_token { 30 | my ($secret, $username, $token, $min_age, $max_age, $noerr) = @_; 31 | 32 | if ($token =~ m/^([A-Z0-9]{8}):(\S+)$/) { 33 | my $sig = $2; 34 | my $timestamp = $1; 35 | my $ttime = hex($timestamp); 36 | 37 | my $digest = Digest::SHA::hmac_sha256_base64("$timestamp:$username", $secret); 38 | 39 | my $age = time() - $ttime; 40 | return 1 41 | if ($digest eq $sig) 42 | && ($age > $min_age) 43 | && ($age < $max_age); 44 | } 45 | 46 | raise("Permission denied - invalid csrf token\n", code => HTTP_UNAUTHORIZED) 47 | if !$noerr; 48 | 49 | return undef; 50 | } 51 | 52 | # Note: data may not contain white spaces (verify fails in that case) 53 | sub assemble_rsa_ticket { 54 | my ($rsa_priv, $prefix, $data, $secret_data) = @_; 55 | 56 | my $timestamp = sprintf("%08X", time()); 57 | 58 | my $plain = "$prefix:"; 59 | 60 | if (defined($data)) { 61 | $data = uri_escape($data, ':'); 62 | $plain .= "$data:"; 63 | } 64 | 65 | $plain .= $timestamp; 66 | 67 | my $full = defined($secret_data) ? "$plain:$secret_data" : $plain; 68 | 69 | my $ticket = $plain . "::" . encode_base64($rsa_priv->sign($full), ''); 70 | 71 | return $ticket; 72 | } 73 | 74 | sub verify_rsa_ticket { 75 | my ($rsa_pub, $prefix, $ticket, $secret_data, $min_age, $max_age, $noerr) = @_; 76 | 77 | if ($ticket && $ticket =~ m/^(\Q$prefix\E:\S+)::([^:\s]+)$/) { 78 | my $plain = $1; 79 | my $sig = $2; 80 | 81 | my $full = defined($secret_data) ? "$plain:$secret_data" : $plain; 82 | 83 | if ($rsa_pub->verify($full, decode_base64($sig))) { 84 | if ($plain =~ m/^\Q$prefix\E:(?:(\S+):)?([A-Z0-9]{8})$/) { 85 | my $data = $1; # Note: not all tickets contains data 86 | my $timestamp = $2; 87 | my $ttime = hex($timestamp); 88 | 89 | my $age = time() - $ttime; 90 | 91 | if (defined($data)) { 92 | $data = uri_unescape($data); 93 | } 94 | 95 | if (($age > $min_age) && ($age < $max_age)) { 96 | if (defined($data)) { 97 | return wantarray ? ($data, $age) : $data; 98 | } else { 99 | return wantarray ? (1, $age) : 1; 100 | } 101 | } 102 | } 103 | } 104 | } 105 | 106 | raise("permission denied - invalid $prefix ticket\n", code => HTTP_UNAUTHORIZED) 107 | if !$noerr; 108 | 109 | return undef; 110 | } 111 | 112 | sub assemble_spice_ticket { 113 | my ($secret, $username, $vmid, $node) = @_; 114 | 115 | my ($seconds, $microseconds) = gettimeofday; 116 | 117 | my $timestamp = sprintf("%08x", $seconds); 118 | 119 | my $randomstr = 120 | "PVESPICE:$timestamp:$username:$vmid:$node:$secret:" . ':' 121 | . sprintf("%08x", $microseconds) . ':' 122 | . sprintf("%08x", $$) . ':' 123 | . rand(1); 124 | 125 | # this should be used as one-time password 126 | # max length is 60 chars (spice limit) 127 | # we pass this to qemu set_pasword and limit lifetime there 128 | # keep this secret 129 | my $ticket = Digest::SHA::sha1_hex($randomstr); 130 | 131 | # Note: spice proxy connects with HTTP, so $proxyticket is exposed to public 132 | # we use a signature/timestamp to make sure nobody can fake such a ticket 133 | # an attacker can use this $proxyticket, but he will fail because $ticket is 134 | # private. 135 | # The proxy needs to be able to extract/verify the ticket 136 | # Note: data needs to be lower case only, because virt-viewer needs that 137 | # Note: RSA signature are too long (>=256 charaters) and make problems with remote-viewer 138 | 139 | my $plain = "pvespiceproxy:${timestamp}:${vmid}:" . lc($node); 140 | 141 | # produces 40 characters 142 | my $sig = unpack("H*", Digest::SHA::sha1($plain, $secret)); 143 | 144 | #my $sig = unpack("H*", $rsa_priv->sign($plain)); # this produce too long strings (512) 145 | 146 | my $proxyticket = "${plain}::${sig}"; 147 | 148 | return ($ticket, $proxyticket); 149 | } 150 | 151 | sub verify_spice_connect_url { 152 | my ($secret, $connect_str) = @_; 153 | 154 | # Note: we pass the spice ticket as 'host', so the 155 | # spice viewer connects with "$ticket:$port" 156 | 157 | return undef if !$connect_str; 158 | 159 | if ($connect_str =~ m/^pvespiceproxy:([a-z0-9]{8}):(\d+):(\S+)::([a-z0-9]{40}):(\d+)$/) { 160 | my ($timestamp, $vmid, $node, $hexsig, $port) = ($1, $2, $3, $4, $5, $6); 161 | my $ttime = hex($timestamp); 162 | my $age = time() - $ttime; 163 | 164 | # use very limited lifetime - is this enough? 165 | return undef if !(($age > -20) && ($age < 40)); 166 | 167 | my $plain = "pvespiceproxy:$timestamp:$vmid:$node"; 168 | my $sig = unpack("H*", Digest::SHA::sha1($plain, $secret)); 169 | 170 | if ($sig eq $hexsig) { 171 | return ($vmid, $node, $port); 172 | } 173 | } 174 | 175 | return undef; 176 | } 177 | 178 | 1; 179 | -------------------------------------------------------------------------------- /test/calendar_event_test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib '../src'; 4 | use strict; 5 | use warnings; 6 | use POSIX (); 7 | use Data::Dumper; 8 | use Time::Local; 9 | use Test::More; 10 | 11 | use PVE::CalendarEvent; 12 | 13 | # Time tests should run in a controlled setting 14 | $ENV{TZ} = 'UTC'; 15 | POSIX::tzset(); 16 | 17 | my $alldays = [0, 1, 2, 3, 4, 5, 6]; 18 | my $tests = [ 19 | [ 20 | '*', undef, [ 21 | [0, 60], [30, 60], [59, 60], [60, 120], 22 | ], 23 | ], 24 | [ 25 | '*/10', undef, [ 26 | [0, 600], [599, 600], [600, 1200], [50 * 60, 60 * 60], 27 | ], 28 | ], 29 | [ 30 | '*/12:0', undef, [ 31 | [10, 43200], [13 * 3600, 24 * 3600], 32 | ], 33 | ], 34 | [ 35 | '1/12:0/15', 36 | undef, 37 | [ 38 | [0, 3600], 39 | [3600, 3600 + 15 * 60], 40 | [3600 + 16 * 60, 3600 + 30 * 60], 41 | [3600 + 30 * 60, 3600 + 45 * 60], 42 | [3600 + 45 * 60, 3600 + 12 * 3600], 43 | [13 * 3600 + 1, 13 * 3600 + 15 * 60], 44 | [13 * 3600 + 15 * 60, 13 * 3600 + 30 * 60], 45 | [13 * 3600 + 30 * 60, 13 * 3600 + 45 * 60], 46 | [13 * 3600 + 45 * 60, 25 * 3600], 47 | ], 48 | ], 49 | [ 50 | '1,4,6', undef, [ 51 | [0, 60], [60, 4 * 60], [4 * 60 + 60, 6 * 60], [6 * 60, 3600 + 60], 52 | ], 53 | ], 54 | [ 55 | '0..3', undef, 56 | ], 57 | [ 58 | '23..23:0..3', undef, 59 | ], 60 | [ 61 | 'Mon', 62 | undef, 63 | [ 64 | [0, 4 * 86400], # Note: Epoch 0 is Thursday, 1. January 1970 65 | [4 * 86400, 11 * 86400], 66 | [11 * 86400, 18 * 86400], 67 | ], 68 | ], 69 | [ 70 | 'sat..sun', 71 | undef, 72 | [ 73 | [0, 2 * 86400], [2 * 86400, 3 * 86400], [3 * 86400, 9 * 86400], 74 | ], 75 | ], 76 | [ 77 | 'sun..sat', 78 | undef, 79 | ], 80 | [ 81 | 'Fri..Mon', 82 | { error => "wrong order in range 'Fri..Mon'" }, 83 | ], 84 | [ 85 | 'wed,mon..tue,fri', 86 | undef, 87 | ], 88 | [ 89 | 'mon */15', 90 | undef, 91 | ], 92 | [ 93 | '22/1:0', 94 | undef, 95 | [ 96 | [0, 22 * 60 * 60], 97 | [22 * 60 * 60, 23 * 60 * 60], 98 | [22 * 60 * 60 + 59 * 60, 23 * 60 * 60], 99 | ], 100 | ], 101 | [ 102 | '*/2:*', 103 | undef, 104 | [ 105 | [0, 60], [60 * 60, 2 * 60 * 60], [2 * 60 * 60, 2 * 60 * 60 + 60], 106 | ], 107 | ], 108 | [ 109 | '20..22:*/30', 110 | undef, 111 | [ 112 | [0, 20 * 60 * 60], 113 | [20 * 60 * 60, 20 * 60 * 60 + 30 * 60], 114 | [22 * 60 * 60 + 30 * 60, 44 * 60 * 60], 115 | ], 116 | ], 117 | [ 118 | '61', 119 | { error => "value '61' out of range" }, 120 | ], 121 | [ 122 | '*/61', 123 | { error => "repetition '61' out of range" }, 124 | ], 125 | [ 126 | '0..80', 127 | { error => "range end '80' out of range" }, 128 | ], 129 | [ 130 | ' mon 0 0 0', 131 | { error => "unable to parse calendar event - unused parts" }, 132 | ], 133 | [ 134 | '', 135 | { error => "unable to parse calendar event - event is empty" }, 136 | ], 137 | [ 138 | ' mon 0 0', 139 | { error => "unable to parse calendar event - unused parts" }, 140 | ], 141 | [ 142 | '0,1,3..5', 143 | undef, 144 | [ 145 | [0, 60], [60, 3 * 60], [5 * 60, 60 * 60], 146 | ], 147 | ], 148 | [ 149 | '2,4:0,1,3..5', 150 | undef, 151 | [ 152 | [0, 2 * 60 * 60], 153 | [2 * 60 * 60 + 60, 2 * 60 * 60 + 3 * 60], 154 | [2 * 60 * 60 + 5 * 60, 4 * 60 * 60], 155 | ], 156 | ], 157 | ]; 158 | 159 | foreach my $test (@$tests) { 160 | my ($t, $expect, $nextsync) = @$test; 161 | 162 | $expect //= {}; 163 | 164 | my $timespec; 165 | eval { $timespec = PVE::CalendarEvent::parse_calendar_event($t); }; 166 | my $err = $@; 167 | 168 | if ($expect->{error}) { 169 | chomp $err if $err; 170 | ok(defined($err) == defined($expect->{error}), "parsing '$t' failed expectedly"); 171 | die "unable to execute nextsync tests" if $nextsync; 172 | } 173 | 174 | next if !$nextsync; 175 | 176 | foreach my $nt (@$nextsync) { 177 | my ($last, $expect_next) = @$nt; 178 | my $msg = "next event '$t' $last => ${expect_next}"; 179 | $timespec->{utc} = 1; 180 | my $next = PVE::CalendarEvent::compute_next_event($timespec, $last); 181 | is($next, $expect_next, $msg); 182 | } 183 | } 184 | 185 | sub tztest { 186 | my ($calspec, $last) = @_; 187 | my $spec = PVE::CalendarEvent::parse_calendar_event($calspec); 188 | return PVE::CalendarEvent::compute_next_event($spec, $last); 189 | } 190 | 191 | # Test loop termination at CEST/CET switch (cannot happen here in UTC) 192 | is(tztest('mon..fri', timelocal(0, 0, 0, 28, 9, 2018)), timelocal(0, 0, 0, 29, 9, 2018)); 193 | is(tztest('mon..fri UTC', timelocal(0, 0, 0, 28, 9, 2018)), timelocal(0, 0, 0, 29, 9, 2018)); 194 | 195 | # Now in the affected time zone 196 | $ENV{TZ} = ':Europe/Vienna'; 197 | POSIX::tzset(); 198 | is(tztest('mon..fri', timelocal(0, 0, 0, 28, 9, 2018)), timelocal(0, 0, 0, 29, 9, 2018)); 199 | # Specifically requesting UTC in the calendar spec means the resulting output 200 | # time as seen locally (timelocal() as opposed to timegm()) is shifted by 1 201 | # hour. 202 | is(tztest('mon..fri UTC', timelocal(0, 0, 0, 28, 9, 2018)), timelocal(0, 0, 1, 29, 9, 2018)); 203 | $ENV{TZ} = 'UTC'; 204 | POSIX::tzset(); 205 | 206 | done_testing(); 207 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/runtest.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib '../../src'; 4 | use lib '.'; 5 | use strict; 6 | use warnings; 7 | 8 | use Carp; 9 | use POSIX; 10 | use IO::Handle; 11 | use Storable qw(dclone); 12 | use JSON; # allows simple debug-dumping of variables `print to_json($foo, {pretty => 1}) ."\n"` 13 | 14 | use PVE::INotify; 15 | 16 | # Current config, r() parses a network interface string into this variable 17 | our $config; 18 | 19 | ## 20 | ## Temporary files: 21 | ## 22 | # perl conveniently lets you open a string as filehandle so we allow tests 23 | # to temporarily save interface files to virtual files: 24 | my %saved_files; 25 | 26 | # Load a temp-file and return it as a string, if it didn't exist, try loading 27 | # a real file. 28 | sub load($) { 29 | my ($from) = @_; 30 | 31 | if (my $local = $saved_files{$from}) { 32 | return $local; 33 | } 34 | 35 | open my $fh, '<', $from or die "failed to open $from: $!"; 36 | local $/ = undef; 37 | my $data = <$fh>; 38 | close $fh; 39 | return $data; 40 | } 41 | 42 | # Save a temporary file. 43 | sub save($$) { 44 | my ($file, $data) = @_; 45 | $saved_files{$file} = $data; 46 | } 47 | 48 | # Delete a temporary file 49 | sub delfile($) { 50 | my $file = @_; 51 | die "no such file: $file" if !delete $saved_files{$file}; 52 | } 53 | 54 | # Delete all temporary files. 55 | sub flush_files() { 56 | foreach (keys %saved_files) { 57 | delete $saved_files{$_} if $_ !~ m,^shared/,; 58 | } 59 | } 60 | 61 | ## 62 | ## Interface parsing: 63 | ## 64 | 65 | # Read an interfaces file with optional /proc/net/dev file content string and 66 | # the list of active interfaces, which otherwise default 67 | sub r($;$$) { 68 | my ($ifaces, $ip_links, $active) = @_; 69 | $ip_links //= decode_json(load('ip_link_details')); 70 | $active //= [split(/\s+/, load('active_interfaces'))]; 71 | open my $fh1, '<', \$ifaces; 72 | $config = PVE::INotify::__read_etc_network_interfaces($fh1, $ip_links, $active); 73 | close $fh1; 74 | } 75 | 76 | # Turn the current network config into a string. 77 | sub w() { 78 | # write shouldn't be able to change a previously parsed config 79 | my $config_clone = dclone($config); 80 | return PVE::INotify::__write_etc_network_interfaces($config_clone, 1); 81 | } 82 | 83 | ## 84 | ## Interface modification helpers 85 | ## 86 | 87 | # Update an interface 88 | sub update_iface($$%) { 89 | my ($name, $families, %extra) = @_; 90 | 91 | my $ifaces = $config->{ifaces}; 92 | my $if = $ifaces->{$name}; 93 | 94 | die "no such interface: $name\n" if !$if; 95 | 96 | $if->{exists} = 1; 97 | 98 | # merge extra flags (like bridge_ports, ovs_*) directly 99 | $if->{$_} = $extra{$_} foreach keys %extra; 100 | 101 | return if !$families; 102 | 103 | my $if_families = $if->{families} ||= []; 104 | foreach my $family (@$families) { 105 | my $type = delete $family->{family}; 106 | @$if_families = ((grep { $_ ne $type } @$if_families), $type); 107 | 108 | (my $suffix = $type) =~ s/^inet//; 109 | $if->{"method$suffix"} = $family->{address} ? 'static' : 'manual'; 110 | foreach (qw(address netmask gateway options)) { 111 | if (my $value = delete $family->{$_}) { 112 | $if->{"$_${suffix}"} = $value; 113 | } 114 | } 115 | } 116 | } 117 | 118 | # Create an interface and error if it already exists. 119 | sub new_iface($$$%) { 120 | my ($name, $type, $families, %extra) = @_; 121 | my $ifaces = $config->{ifaces}; 122 | croak "interface already exists: $name" if $ifaces->{$name}; 123 | $ifaces->{$name} = { type => $type }; 124 | update_iface($name, $families, %extra); 125 | } 126 | 127 | # Delete an interface and error if it did not exist. 128 | sub delete_iface($;$) { 129 | my ($name, $family) = @_; 130 | my $ifaces = $config->{ifaces}; 131 | my $if = $ifaces->{$name} ||= {}; 132 | croak "interface doesn't exist: $name" if !$if; 133 | 134 | if (!$family) { 135 | delete $ifaces->{$name}; 136 | return; 137 | } 138 | 139 | my $families = $if->{families}; 140 | @$families = grep { $_ ne $family } @$families; 141 | (my $suffix = $family) =~ s/^inet//; 142 | delete $if->{"$_$suffix"} foreach qw(address netmask gateway options); 143 | } 144 | 145 | ## 146 | ## Test helpers: 147 | ## 148 | 149 | # Compare two strings line by line and show a diff/error if they differ. 150 | sub diff($$) { 151 | my ($a, $b) = @_; 152 | return if $a eq $b; 153 | 154 | my ($ra, $wa) = POSIX::pipe(); 155 | my ($rb, $wb) = POSIX::pipe(); 156 | my $ha = IO::Handle->new_from_fd($wa, 'w'); 157 | my $hb = IO::Handle->new_from_fd($wb, 'w'); 158 | 159 | open my $diffproc, '-|', 'diff', '-up', "/dev/fd/$ra", "/dev/fd/$rb" 160 | or die "failed to run program 'diff': $!"; 161 | POSIX::close($ra); 162 | POSIX::close($rb); 163 | 164 | open my $f1, '<', \$a; 165 | open my $f2, '<', \$b; 166 | my ($line1, $line2); 167 | do { 168 | $ha->print($line1) if defined($line1 = <$f1>); 169 | $hb->print($line2) if defined($line2 = <$f2>); 170 | } while (defined($line1 // $line2)); 171 | close $f1; 172 | close $f2; 173 | close $ha; 174 | close $hb; 175 | 176 | local $/ = undef; 177 | my $diff = <$diffproc>; 178 | close $diffproc; 179 | die "files differ:\n$diff"; 180 | } 181 | 182 | # Write the current interface config and compare the result to a string. 183 | sub expect($) { 184 | my ($expected) = @_; 185 | my $got = w(); 186 | diff($expected, $got); 187 | } 188 | 189 | ## 190 | ## Main test execution: 191 | ## 192 | # (sorted, it's not used right now but tests could pass on temporary files by 193 | # prefixing the name with shared/ and thus you might want to split a larger 194 | # test into t.01.first-part.pl, t.02.second-part.pl, etc. 195 | my $total = 0; 196 | my $failed = 0; 197 | for our $Test (sort ) { 198 | $total++; 199 | flush_files(); 200 | eval { require $Test; }; 201 | if ($@) { 202 | print "FAIL: $Test\n$@\n\n"; 203 | $failed++; 204 | } else { 205 | print "PASS: $Test\n"; 206 | } 207 | } 208 | 209 | die "$failed out of $total tests failed\n" if $failed; 210 | -------------------------------------------------------------------------------- /src/PVE/LDAP.pm: -------------------------------------------------------------------------------- 1 | package PVE::LDAP; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Net::IP; 7 | use Net::LDAP; 8 | use Net::LDAP::Control::Paged; 9 | use Net::LDAP::Constant qw(LDAP_CONTROL_PAGED); 10 | 11 | sub ldap_connect { 12 | my ($servers, $scheme, $port, $opts) = @_; 13 | 14 | my $start_tls = 0; 15 | 16 | if ($scheme eq 'ldap+starttls') { 17 | $scheme = 'ldap'; 18 | $start_tls = 1; 19 | } 20 | 21 | my %ldap_opts = ( 22 | scheme => $scheme, 23 | port => $port, 24 | timeout => 10, 25 | ); 26 | 27 | my $hosts = []; 28 | for my $host (@$servers) { 29 | if (Net::IP::ip_is_ipv6($host)) { 30 | push @$hosts, "[$host]"; 31 | } else { 32 | push @$hosts, $host; 33 | } 34 | } 35 | 36 | for my $opt (qw(clientcert clientkey capath cafile sslversion verify)) { 37 | $ldap_opts{$opt} = $opts->{$opt} if $opts->{$opt}; 38 | } 39 | 40 | my $ldap = Net::LDAP->new($hosts, %ldap_opts) || die "$@\n"; 41 | 42 | if ($start_tls) { 43 | my $res = $ldap->start_tls(%$opts); 44 | die $res->error . "\n" if $res->code; 45 | } 46 | 47 | return $ldap; 48 | } 49 | 50 | sub ldap_bind { 51 | my ($ldap, $dn, $pw) = @_; 52 | 53 | my $res; 54 | if (defined($dn) && defined($pw)) { 55 | $res = $ldap->bind($dn, password => $pw); 56 | } else { # anonymous bind 57 | $res = $ldap->bind(); 58 | } 59 | 60 | my $code = $res->code; 61 | my $err = $res->error; 62 | 63 | die "ldap bind failed: $err\n" if $code; 64 | } 65 | 66 | sub get_user_dn { 67 | my ($ldap, $name, $attr, $base_dn) = @_; 68 | 69 | # search for dn 70 | my $result = $ldap->search( 71 | base => $base_dn // "", 72 | scope => "sub", 73 | filter => "$attr=$name", 74 | attrs => ['dn'], 75 | ); 76 | die $result->error . "\n" if $result->code; 77 | return undef if !$result->entries; 78 | my @entries = $result->entries; 79 | return $entries[0]->dn; 80 | } 81 | 82 | sub auth_user_dn { 83 | my ($ldap, $dn, $pw, $noerr) = @_; 84 | 85 | if (!$dn) { 86 | return undef if $noerr; 87 | die "user dn is empty\n"; 88 | } 89 | 90 | my $res = $ldap->bind($dn, password => $pw); 91 | 92 | my $code = $res->code; 93 | my $err = $res->error; 94 | 95 | if ($code) { 96 | return undef if $noerr; 97 | die "$err\n"; 98 | } 99 | 100 | return 1; 101 | } 102 | 103 | sub query_users { 104 | my ($ldap, $filter, $attributes, $base_dn, $classes) = @_; 105 | 106 | # build filter from given filter and attribute list 107 | my $tmp = "(|"; 108 | foreach my $att (@$attributes) { 109 | $tmp .= "($att=*)"; 110 | } 111 | $tmp .= ")"; 112 | 113 | if ($classes) { 114 | $tmp = "(&$tmp(|"; 115 | for my $class (@$classes) { 116 | $tmp .= "(objectclass=$class)"; 117 | } 118 | $tmp .= "))"; 119 | } 120 | 121 | if ($filter) { 122 | $filter = "($filter)" if $filter !~ m/^\(.*\)$/; 123 | $filter = "(&${filter}${tmp})"; 124 | } else { 125 | $filter = $tmp; 126 | } 127 | 128 | my $page = Net::LDAP::Control::Paged->new(size => 900); 129 | 130 | my @args = ( 131 | base => $base_dn // "", 132 | scope => "subtree", 133 | filter => $filter, 134 | control => [$page], 135 | attrs => [@$attributes, 'memberOf'], 136 | ); 137 | 138 | my $cookie; 139 | my $err; 140 | my $users = []; 141 | 142 | while (1) { 143 | 144 | my $mesg = $ldap->search(@args); 145 | 146 | # stop on error 147 | if ($mesg->code) { 148 | $err = "ldap user search error: " . $mesg->error; 149 | last; 150 | } 151 | 152 | #foreach my $entry ($mesg->entries) { $entry->dump; } 153 | foreach my $entry ($mesg->entries) { 154 | my $user = { 155 | dn => $entry->dn, 156 | attributes => {}, 157 | groups => [$entry->get_value('memberOf')], 158 | }; 159 | 160 | foreach my $attr (@$attributes) { 161 | my $vals = [$entry->get_value($attr)]; 162 | if (scalar(@$vals)) { 163 | $user->{attributes}->{$attr} = $vals; 164 | } 165 | } 166 | 167 | push @$users, $user; 168 | } 169 | 170 | # Get cookie from paged control 171 | my ($resp) = $mesg->control(LDAP_CONTROL_PAGED) or last; 172 | $cookie = $resp->cookie; 173 | 174 | last if (!defined($cookie) || !length($cookie)); 175 | 176 | # Set cookie in paged control 177 | $page->cookie($cookie); 178 | } 179 | 180 | if (defined($cookie) && length($cookie)) { 181 | # We had an abnormal exit, so let the server know we do not want any more 182 | $page->cookie($cookie); 183 | $page->size(0); 184 | $ldap->search(@args); 185 | $err = "LDAP user query unsuccessful" if !$err; 186 | } 187 | 188 | die "$err\n" if $err; 189 | 190 | return $users; 191 | } 192 | 193 | sub query_groups { 194 | my ($ldap, $base_dn, $classes, $filter, $group_name_attr) = @_; 195 | 196 | my $tmp = "(|"; 197 | for my $class (@$classes) { 198 | $tmp .= "(objectclass=$class)"; 199 | } 200 | $tmp .= ")"; 201 | 202 | if ($filter) { 203 | $filter = "($filter)" if $filter !~ m/^\(.*\)$/; 204 | $filter = "(&${filter}${tmp})"; 205 | } else { 206 | $filter = $tmp; 207 | } 208 | 209 | my $page = Net::LDAP::Control::Paged->new(size => 100); 210 | 211 | my $attrs = ['member', 'uniqueMember']; 212 | push @$attrs, $group_name_attr if $group_name_attr; 213 | my @args = ( 214 | base => $base_dn, 215 | scope => "subtree", 216 | filter => $filter, 217 | control => [$page], 218 | attrs => $attrs, 219 | ); 220 | 221 | my $cookie; 222 | my $err; 223 | my $groups = []; 224 | 225 | while (1) { 226 | 227 | my $mesg = $ldap->search(@args); 228 | 229 | # stop on error 230 | if ($mesg->code) { 231 | $err = "ldap group search error: " . $mesg->error; 232 | last; 233 | } 234 | 235 | foreach my $entry ($mesg->entries) { 236 | my $group = { 237 | dn => $entry->dn, 238 | members => [], 239 | }; 240 | my $members = [$entry->get_value('member')]; 241 | if (!scalar(@$members)) { 242 | $members = [$entry->get_value('uniqueMember')]; 243 | } 244 | $group->{members} = $members; 245 | if ($group_name_attr && (my $name = $entry->get_value($group_name_attr))) { 246 | $group->{name} = $name; 247 | } 248 | push @$groups, $group; 249 | } 250 | 251 | # Get cookie from paged control 252 | my ($resp) = $mesg->control(LDAP_CONTROL_PAGED) or last; 253 | $cookie = $resp->cookie; 254 | 255 | last if (!defined($cookie) || !length($cookie)); 256 | 257 | # Set cookie in paged control 258 | $page->cookie($cookie); 259 | } 260 | 261 | if ($cookie) { 262 | # We had an abnormal exit, so let the server know we do not want any more 263 | $page->cookie($cookie); 264 | $page->size(0); 265 | $ldap->search(@args); 266 | $err = "LDAP group query unsuccessful" if !$err; 267 | } 268 | 269 | die "$err\n" if $err; 270 | 271 | return $groups; 272 | } 273 | 274 | 1; 275 | -------------------------------------------------------------------------------- /src/PVE/File.pm: -------------------------------------------------------------------------------- 1 | package PVE::File; 2 | 3 | use v5.36; 4 | 5 | use Encode qw(encode); 6 | use Fcntl qw(SEEK_SET SEEK_END); 7 | use File::Basename qw(dirname); 8 | use File::Path qw(make_path); 9 | use IO::File qw(O_CREAT O_DIRECTORY O_EXCL O_RDWR O_WRONLY); 10 | use IO::Dir (); 11 | use POSIX qw(EEXIST EOPNOTSUPP); 12 | 13 | use base 'Exporter'; 14 | 15 | our @EXPORT_OK = qw( 16 | file_set_contents 17 | file_get_contents 18 | file_read_first_line 19 | file_read_last_line 20 | dir_glob_regex 21 | dir_glob_foreach 22 | file_copy 23 | O_PATH 24 | O_TMPFILE 25 | AT_EMPTY_PATH 26 | AT_FDCWD 27 | ); 28 | 29 | use constant { 30 | O_PATH => 0x00200000, 31 | O_CLOEXEC => 0x00080000, 32 | O_TMPFILE => 0x00400000 | O_DIRECTORY, 33 | }; 34 | 35 | use constant { 36 | AT_EMPTY_PATH => 0x1000, 37 | AT_FDCWD => -100, 38 | }; 39 | 40 | # from 41 | use constant { 42 | RENAME_NOREPLACE => (1 << 0), 43 | RENAME_EXCHANGE => (1 << 1), 44 | RENAME_WHITEOUT => (1 << 2), 45 | }; 46 | 47 | sub file_set_contents { 48 | my ($filename, $data, $perm, $force_utf8) = @_; 49 | 50 | $perm = 0644 if !defined($perm); 51 | 52 | my $tmpname = "$filename.tmp.$$"; 53 | 54 | eval { 55 | my ($fh, $tries) = (undef, 0); 56 | while (!$fh && $tries++ < 3) { 57 | $fh = IO::File->new($tmpname, O_WRONLY | O_CREAT | O_EXCL, $perm); 58 | if (!$fh && $! == EEXIST) { 59 | unlink($tmpname) or die "unable to delete old temp file: $!\n"; 60 | } 61 | } 62 | die "unable to open file '$tmpname' - $!\n" if !$fh; 63 | 64 | if ($force_utf8) { 65 | $data = encode("utf8", $data); 66 | } else { 67 | # Encode wide characters with print before passing them to syswrite 68 | my $unencoded_data = $data; 69 | # Preload PerlIO::scalar at compile time to prevent runtime loading issues when 70 | # file_set_contents is called with PVE::LXC::Setup::protected_call. Normally, 71 | # PerlIO::scalar is loaded implicitly during the execution of 72 | # `open(my $data_fh, '>', \$data)`. However, this fails if it is executed within a 73 | # chroot environment where the necessary PerlIO.pm module file is inaccessible. 74 | # Preloading the module ensures it is available regardless of the execution context. 75 | use PerlIO::scalar; 76 | open(my $data_fh, '>', \$data) or die "failed to open in-memory variable - $!\n"; 77 | print $data_fh $unencoded_data; 78 | close($data_fh); 79 | } 80 | 81 | my $offset = 0; 82 | my $len = length($data); 83 | 84 | while ($offset < $len) { 85 | my $written_bytes = syswrite($fh, $data, $len - $offset, $offset) 86 | or die "unable to write '$tmpname' - $!\n"; 87 | $offset += $written_bytes; 88 | } 89 | 90 | close $fh or die "closing file '$tmpname' failed - $!\n"; 91 | }; 92 | my $err = $@; 93 | 94 | if ($err) { 95 | unlink $tmpname; 96 | die $err; 97 | } 98 | 99 | if (!rename($tmpname, $filename)) { 100 | my $msg = "close (rename) atomic file '$filename' failed: $!\n"; 101 | unlink $tmpname; 102 | die $msg; 103 | } 104 | } 105 | 106 | sub file_get_contents($filename, $max = undef) { 107 | my $fh = IO::File->new($filename, "r") || die "can't open '$filename' - $!\n"; 108 | 109 | my $content = safe_read_from($fh, $max, 0, $filename); 110 | 111 | close $fh; 112 | 113 | return $content; 114 | } 115 | 116 | sub file_copy($filename, $dst, $max = undef, $perm = undef) { 117 | file_set_contents($dst, file_get_contents($filename, $max), $perm); 118 | } 119 | 120 | sub file_read_first_line($filename) { 121 | my $fh = IO::File->new($filename, "r"); 122 | if (!$fh) { 123 | return undef if $! == POSIX::ENOENT; 124 | die "file '$filename' exists but open for reading failed - $!\n"; 125 | } 126 | my $res = <$fh>; 127 | chomp $res if $res; 128 | $fh->close; 129 | return $res; 130 | } 131 | 132 | sub file_read_last_line($filename) { 133 | my $fh = IO::File->new($filename, 'r'); 134 | if (!$fh) { 135 | return undef if $! == POSIX::ENOENT; 136 | die "file '$filename' exists but open for reading failed - $!\n"; 137 | } 138 | binmode($fh, ':raw'); # operate on bytes 139 | 140 | my $pos_end = sysseek($fh, 0, SEEK_END) // die "sysseek failed - $!"; 141 | return '' if $pos_end == 0; # empty file 142 | 143 | my $buf = ''; 144 | my $chunk = 4096; 145 | 146 | my $pos = $pos_end; 147 | while ($pos > 0) { 148 | my $first_read = $pos == $pos_end; 149 | my $read = $pos < $chunk ? $pos : $chunk; 150 | $pos = sysseek($fh, $pos - $read, SEEK_SET) // "sysseek failed - $!"; 151 | my $tmp = ''; 152 | sysread($fh, $tmp, $read) // die "sysread failed - $!"; 153 | $buf = $tmp . $buf; 154 | 155 | my $newline_pos = rindex($buf, "\n"); 156 | 157 | if ($first_read && $newline_pos == $read - 1) { 158 | # allow files to end with a trailing \n and skip that to avoid returning empty string 159 | chop $buf; 160 | $newline_pos = rindex($buf, "\n"); 161 | } 162 | 163 | return substr($buf, $newline_pos + 1) if $newline_pos >= 0; 164 | } 165 | 166 | # no newline in file, entire file is a single (possibly unterminated) line 167 | return $buf; 168 | } 169 | 170 | sub safe_read_from($fh, $max, $oneline, $filename) { 171 | # pmxcfs file size limit 172 | $max = 1024 * 1024 if !$max; 173 | 174 | my $subject = defined($filename) ? "file '$filename'" : 'input'; 175 | 176 | my $br = 0; 177 | my $input = ''; 178 | my $count; 179 | while ($count = sysread($fh, $input, 8192, $br)) { 180 | $br += $count; 181 | die "$subject too long - aborting\n" if $br > $max; 182 | if ($oneline && $input =~ m/^(.*)\n/) { 183 | $input = $1; 184 | last; 185 | } 186 | } 187 | die "unable to read $subject - $!\n" if !defined($count); 188 | 189 | return $input; 190 | } 191 | 192 | # Creates a new (exclusive) file owned by $uid and returns the filehandle. 193 | # 194 | # Defaults to group id of caller and 0640 permissions. Tries to create the parent directory on a 195 | # best-effort basis. 196 | sub create_owned_file_fh($filename, $uid, $gid = -1, $perm = 0640) { 197 | my $dirname = dirname($filename); 198 | make_path($dirname); 199 | 200 | my $fh = IO::File->new($filename, O_WRONLY | O_CREAT | O_EXCL, $perm) 201 | || die "unable to create file '$filename' - $!\n"; 202 | 203 | if (!chown $uid, $gid, $fh) { 204 | my $err = "failed to change owner of '$filename' to $uid:$gid - $!"; 205 | unlink($fh) or warn "failed to unlink '$filename' after failing to set owner: $!\n"; 206 | die $err; 207 | } 208 | 209 | return $fh; 210 | } 211 | 212 | # creates a temporary file that does not shows up on the file system hierarchy. 213 | # 214 | # Uses O_TMPFILE if available, which makes it just an anon inode that never shows up in the FS. 215 | # If O_TMPFILE is not available, which unlikely nowadays (added in 3.11 kernel and all FS relevant 216 | # for us support it) back to open-create + immediate unlink while still holding the file handle. 217 | # 218 | # TODO: to avoid FS dependent features we could (transparently) switch to memfd_create as backend 219 | sub tempfile($perm, %opts) { 220 | # default permissions are stricter than with file_set_contents 221 | $perm = 0600 if !defined($perm); 222 | 223 | my $dir = $opts{dir}; 224 | if (!$dir) { 225 | if (-d "/run/user/$<") { 226 | $dir = "/run/user/$<"; 227 | } elsif ($< == 0) { 228 | $dir = "/run"; 229 | } else { 230 | $dir = "/tmp"; 231 | } 232 | } 233 | my $mode = $opts{mode} // O_RDWR; 234 | $mode |= O_EXCL if !$opts{allow_links}; 235 | 236 | my $fh = IO::File->new($dir, $mode | O_TMPFILE, $perm); 237 | if (!$fh && $! == EOPNOTSUPP) { 238 | $dir = '/tmp' if !defined($opts{dir}); 239 | $dir .= "/.tmpfile.$$"; 240 | $fh = IO::File->new($dir, $mode | O_CREAT | O_EXCL, $perm); 241 | unlink($dir) if $fh; 242 | } 243 | die "failed to create tempfile: $!\n" if !$fh; 244 | return $fh; 245 | } 246 | 247 | # create an (ideally) anon file with the $data as content and return its FD-path and FH 248 | sub tempfile_contents($data, $perm, %opts) { 249 | my $fh = tempfile($perm, %opts); 250 | eval { 251 | die "unable to write to tempfile: $!\n" if !print {$fh} $data; 252 | die "unable to flush to tempfile: $!\n" if !defined($fh->flush()); 253 | }; 254 | if (my $err = $@) { 255 | close $fh; 256 | die $err; 257 | } 258 | 259 | return ("/proc/$$/fd/" . $fh->fileno, $fh); 260 | } 261 | 262 | sub dir_glob_regex($dir, $regex) { 263 | my $dh = IO::Dir->new($dir); 264 | return wantarray ? () : undef if !$dh; 265 | 266 | while (defined(my $tmp = $dh->read)) { 267 | if (my @res = $tmp =~ m/^($regex)$/) { 268 | $dh->close; 269 | return wantarray ? @res : $tmp; 270 | } 271 | } 272 | $dh->close; 273 | 274 | return wantarray ? () : undef; 275 | } 276 | 277 | sub dir_glob_foreach($dir, $regex, $func) { 278 | my $dh = IO::Dir->new($dir); 279 | if (defined $dh) { 280 | while (defined(my $tmp = $dh->read)) { 281 | if (my @res = $tmp =~ m/^($regex)$/) { 282 | $func->(@res); 283 | } 284 | } 285 | } 286 | } 287 | 288 | 1; 289 | -------------------------------------------------------------------------------- /README.dev: -------------------------------------------------------------------------------- 1 | = Setup PVE Development Environment = 2 | 3 | 0. Read https://pve.proxmox.com/wiki/Developer_Documentation 4 | 1. Install Debian 12 Bookworm (you can also start from a PVE installation and 5 | skip step 2 - 5, 7 - 11) 6 | 2. Configure the network interface(s) 7 | 3. Change the IP address of your hostname for proper name resolution 8 | in /etc/hosts 9 | Using 127.0.1.1 will not work, so change it to an IP address from your 10 | local network! 11 | 12 | 4: Check that the Debian repositories are set properly. 13 | See https://wiki.debian.org/SourcesList for more information. 14 | 15 | 5. Optional: Install openssh-server and connect via ssh to the host. 16 | 17 | run: apt-get update && apt-get install openssh-server 18 | Connect via ssh to host and switch user to root 19 | 20 | 6. Configure 'pvetest' repository in /etc/apt/sources.list.d/: 21 | 22 | run: echo "deb http://download.proxmox.com/debian bookworm pvetest" > /etc/apt/sources.list.d/pve-development.list 23 | 24 | 7. Add the repository key, run: 25 | 26 | wget -O /etc/apt/trusted.gpg.d/proxmox-release-bookworm.gpg "https://enterprise.proxmox.com/debian/proxmox-release-bookworm.gpg" 27 | 28 | 8. run: apt-get update && apt-get dist-upgrade 29 | 9. run: apt-get install proxmox-ve 30 | 10. run: mv /etc/apt/sources.list.d/pve-enterprise.list /etc/apt/sources.list.d/pve-enterprise.list.bak 31 | 32 | 11. You should now have a working Proxmox VE installation. 33 | Open a browser: https://:8006 e.g. https://10.0.0.90:8006 34 | 35 | 36 | = Install build prerequisites for development environment = 37 | 38 | NOTE: this is a huge and probably outdated list intended to be able to build 39 | (almost) all packages, from the UI/API components to backend components to our 40 | Linux Kernel. If you only want to hack on specific topics you won't need most 41 | of those. 42 | Instead we try to have a complete list of build dependencies in each source 43 | repositories 'debian/control' file. If you run `make deb` dpkg-buildpackage 44 | will stop and tell you if you miss some required packages. 45 | 46 | 12. For installing the most important, always needed, ones run: 47 | 48 | apt-get install build-essential git git-email debhelper pve-doc-generator 49 | 50 | Additionally, for quickly installing (almost) all build dependencies run: 51 | 52 | WARNING: this list is almost for sure outdated! Use the build-deps definitions 53 | defined in each package! You could install `devscripts` (huge package, but nice 54 | helpers) and use: 55 | # mk-build-deps --install 56 | in the top-level directory of a git repository. 57 | 58 | apt-get install autotools-dev autogen dh-autoreconf dkms doxygen check pkg-config \ 59 | groff quilt dpatch automake autoconf libtool lintian libdevel-cycle-perl \ 60 | libjson-perl libcommon-sense-perl liblinux-inotify2-perl libio-stringy-perl \ 61 | libstring-shellquote-perl dh-systemd rpm2cpio libsqlite3-dev sqlite3 \ 62 | libglib2.0-dev librrd-dev librrds-perl rrdcached libdigest-hmac-perl \ 63 | libxml-parser-perl gdb libcrypt-openssl-random-perl \ 64 | libcrypt-openssl-rsa-perl libnet-ldap-perl libauthen-pam-perl \ 65 | libjson-xs-perl libterm-readline-gnu-perl oathtool libmime-base32-perl \ 66 | liboath0 libpci-dev texi2html libsdl1.2-dev libgnutls28-dev \ 67 | libspice-protocol-dev xfslibs-dev libnuma-dev libaio-dev \ 68 | pve-libspice-server-dev libusbredirparser-dev glusterfs-common \ 69 | libusb-1.0-0-dev librbd-dev libpopt-dev iproute bridge-utils numactl \ 70 | glusterfs-common ceph-common python-ceph libgoogle-perftools4 \ 71 | libfile-chdir-perl lvm2 glusterfs-client liblockfile-simple-perl \ 72 | libsystemd-dev libreadline-gplv2-dev libio-multiplex-perl \ 73 | libnetfilter-log-dev libipset3 ipset socat libsasl2-dev libogg-dev \ 74 | python-pyparsing libfilesys-df-perl libcrypt-ssleay-perl \ 75 | libfile-readbackwards-perl libanyevent-perl libanyevent-http-perl \ 76 | unzip liblocale-po-perl libfile-sync-perl cstream \ 77 | lzop dtach hdparm gdisk parted ttf-dejavu-core \ 78 | liblzma-dev dosfstools mtools libxen-dev libfuse-dev libcpg-dev libquorum-dev \ 79 | libcmap-dev libuuid-perl libqb-dev libapparmor-dev docbook2x libcap-dev \ 80 | dh-apparmor graphviz libseccomp-dev libglib-perl libgtk3-perl libnss3-dev \ 81 | libdlm-dev libudev-dev asciidoc-dblatex source-highlight libiscsi-dev \ 82 | libiscsi7 librsvg2-bin libarchive-dev libgpgme-dev libcurl4-gnutls-dev \ 83 | libtest-mockmodule-perl libjemalloc-dev libjpeg-dev 84 | 85 | 86 | = Compile PVE packages from Source = 87 | 88 | 13: Download and install git repositories as Proxmox modules: 89 | 90 | run: mkdir /root/proxmox && cd /root/proxmox 91 | 92 | run: git clone git://git.proxmox.com/git/pve-common.git 93 | 94 | 'pve-common.git' is some kind of starting repository and needed for some 95 | other repositories as dependency. 96 | Install this to get an idea of how the installation process is working. 97 | 98 | See https://git.proxmox.com/ for all available repositories. 99 | 100 | 14: Most packages can be installed with 'make dinstall' command. 101 | run: cd pve-common && make dinstall 102 | 103 | 15: Reboot the system. 104 | 16. Learn to use the quilt patch scripts. 105 | 17. Happy coding! 106 | 107 | 108 | = REST vs. SOAP = 109 | 110 | We decided to change our SOAP API (1.X) and use a REST like API. The 111 | concept is described in [1] (Resource Oriented Architecture 112 | (ROA)). The main advantage is that we are able to remove a lot of code 113 | (the whole SOAP stack) to reduce software complexity. 114 | 115 | We also moved away from server side content generation. Instead we use 116 | the ExtJS Rich Internet Application Framework 117 | (http://www.sencha.com). 118 | 119 | That framework, like any other AJAX toolkit, can talk directly to the 120 | REST API using JSON. So we were able to remove the server side 121 | template toolkit completely. 122 | 123 | = JSON and JSON Schema = 124 | 125 | We use JSON as data format, because it is simple and parse-able by any 126 | web browser. 127 | 128 | Additionally, we use JSON Schema [2] to formally describe our API. So 129 | we can automatically generate the whole API Documentation, and we can 130 | verify all parameters and return values. 131 | 132 | A great side effect was that we are able to use JSON Schema to 133 | produce command line argument parsers automatically. In fact, the REST 134 | API and the command line tools use the same code. 135 | 136 | Object linkage is done using the JSON Hyper Schema (links property). 137 | 138 | A small utility called 'pvesh' exposes the whole REST API on the command 139 | line. 140 | 141 | So here is a summary of the advantage: 142 | 143 | - easy, human readable data format (native web browser format) 144 | - automatic parameter verification (we can also verify return values) 145 | - automatic generation of API documentation 146 | - easy way to create command line tools (using same API). 147 | 148 | = API Implementation (PVE::RESTHandler) = 149 | 150 | All classes exposing methods on the API use PVE::RESTHandler as base class. 151 | 152 | use base qw(PVE::RESTHandler); 153 | 154 | To expose methods, one needs to call register_method(): 155 | 156 | __PACKAGE__->register_method ($schema); 157 | 158 | Where $schema is a PVE method schema as described in 159 | PVE::JSONSchema. It includes a description of parameters and return 160 | values, and a reference to the actual code 161 | 162 | __PACKAGE__->register_method ({ 163 | name => 'echo', 164 | path => 'echo', 165 | method => 'GET', 166 | description => "simple return value of parameter 'text'", 167 | parameters => { 168 | additionalProperties => 0, 169 | properties => { 170 | text => { 171 | type => 'string', 172 | } 173 | }, 174 | }, 175 | returns => { 176 | type => 'string', 177 | }, 178 | code => sub { 179 | my ($param) = @_; 180 | 181 | return $param->{text}; 182 | } 183 | }); 184 | 185 | The 'name' property is only used if you want to call the method 186 | directly from Perl. You can do that using: 187 | 188 | print __PACKAGE__->echo({ text => "a test" }); 189 | 190 | We use Perl's AUTOLOAD feature to implement this. Note: You need to 191 | pass parameters a HASH reference. 192 | 193 | There is a special helper method called cli_handler(). This is used by 194 | the CLIHandler Class for command line tools, where you want to pass 195 | arguments as array of strings. This uses Getopt::Long to parse parameters. 196 | 197 | There is a second way to map names to methods - using the 'path' 198 | property. And you can register subclasses. That way you can set up a 199 | filesystem like hierarchy to access methods. 200 | 201 | Here is an example: 202 | ---------------------------- 203 | package C1; 204 | 205 | __PACKAGE__->register_method ({ 206 | subclass => "C2", 207 | path => 'sub2', 208 | }); 209 | 210 | 211 | __PACKAGE__->register_method ({ 212 | name => 'list1', 213 | path => 'index', 214 | method => 'GET', 215 | ... 216 | }); 217 | 218 | package C2; 219 | 220 | __PACKAGE__->register_method ({ 221 | name => 'list2', 222 | path => 'index', 223 | method => 'GET', 224 | ... 225 | }); 226 | ------------------------------- 227 | 228 | The utily method find_handler (in PVE::RESTHandler) can be use to do 229 | 'path' related method lookups. 230 | 231 | C1->find_handler('GET', "/index") => C1::list1 232 | C1->find_handler('GET', "/sub2/index") => C2::list2 233 | 234 | The HTTP server use the URL (a path) to find the corresponding method. 235 | 236 | 237 | = References = 238 | 239 | [1] RESTful Web Services 240 | Web services for the real world 241 | 242 | By 243 | Leonard Richardson, Sam Ruby 244 | Publisher: 245 | O'Reilly Media 246 | Released: 247 | May 2007 248 | 249 | [2] JSON Schema links: http://json-schema.org/ 250 | -------------------------------------------------------------------------------- /src/PVE/PTY.pm: -------------------------------------------------------------------------------- 1 | package PVE::PTY; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Fcntl; 7 | use POSIX qw(O_RDWR O_NOCTTY); 8 | 9 | # Constants 10 | 11 | use constant { 12 | TCGETS => 0x5401, # fixed, from asm-generic/ioctls.h 13 | TCSETS => 0x5402, # fixed, from asm-generic/ioctls.h 14 | TIOCGWINSZ => 0x5413, # fixed, from asm-generic/ioctls.h 15 | TIOCSWINSZ => 0x5414, # fixed, from asm-generic/ioctls.h 16 | TIOCSCTTY => 0x540E, # fixed, from asm-generic/ioctls.h 17 | TIOCNOTTY => 0x5422, # fixed, from asm-generic/ioctls.h 18 | TIOCGPGRP => 0x540F, # fixed, from asm-generic/ioctls.h 19 | TIOCSPGRP => 0x5410, # fixed, from asm-generic/ioctls.h 20 | 21 | # IOC: dir:2 size:14 type:8 nr:8 22 | # Get pty number: dir=2 size=4 type='T' nr=0x30 23 | TIOCGPTN => 0x80045430, 24 | 25 | # Set pty lock: dir=1 size=4 type='T' nr=0x31 26 | TIOCSPTLCK => 0x40045431, 27 | 28 | # Send signal: dir=1 size=4 type='T' nr=0x36 29 | TIOCSIG => 0x40045436, 30 | 31 | # c_cc indices: 32 | VINTR => 0, 33 | VQUIT => 1, 34 | VERASE => 2, 35 | VKILL => 3, 36 | VEOF => 4, 37 | VTIME => 5, 38 | VMIN => 6, 39 | VSWTC => 7, 40 | VSTART => 8, 41 | VSTOP => 9, 42 | VSUSP => 10, 43 | VEOL => 11, 44 | VREPRINT => 12, 45 | VDISCARD => 13, 46 | VWERASE => 14, 47 | VLNEXT => 15, 48 | VEOL2 => 16, 49 | }; 50 | 51 | # Utility functions 52 | 53 | sub createpty() { 54 | # Open the master file descriptor: 55 | sysopen(my $master, '/dev/ptmx', O_RDWR | O_NOCTTY) 56 | or die "failed to create pty: $!\n"; 57 | 58 | # Find the tty number 59 | my $ttynum = pack('L', 0); 60 | ioctl($master, TIOCGPTN, $ttynum) 61 | or die "failed to query pty number: $!\n"; 62 | $ttynum = unpack('L', $ttynum); 63 | 64 | # Get the slave name/path 65 | my $ttyname = "/dev/pts/$ttynum"; 66 | 67 | # Unlock 68 | my $false = pack('L', 0); 69 | ioctl($master, TIOCSPTLCK, $false) 70 | or die "failed to unlock pty: $!\n"; 71 | 72 | return ($master, $ttyname); 73 | } 74 | 75 | my $openslave = sub { 76 | my ($ttyname) = @_; 77 | 78 | # Create a slave file descriptor: 79 | sysopen(my $slave, $ttyname, O_RDWR | O_NOCTTY) 80 | or die "failed to open slave pty handle: $!\n"; 81 | return $slave; 82 | }; 83 | 84 | sub lose_controlling_terminal() { 85 | # Can we open our current terminal? 86 | if (sysopen(my $ttyfd, '/dev/tty', O_RDWR)) { 87 | # Disconnect: 88 | ioctl($ttyfd, TIOCNOTTY, 0) 89 | or die "failed to disconnect controlling tty: $!\n"; 90 | close($ttyfd); 91 | } 92 | } 93 | 94 | sub termios(%) { 95 | my (%termios) = @_; 96 | my $cc = $termios{cc} // []; 97 | if (@$cc < 19) { 98 | push @$cc, (0) x (19 - @$cc); 99 | } elsif (@$cc > 19) { 100 | @$cc = $$cc[0 .. 18]; 101 | } 102 | 103 | return pack('LLLLCC[19]', 104 | $termios{iflag} || 0, 105 | $termios{oflag} || 0, 106 | $termios{cflag} || 0, 107 | $termios{lflag} || 0, 108 | $termios{line} || 0, 109 | @$cc); 110 | } 111 | 112 | my $parse_termios = sub { 113 | my ($blob) = @_; 114 | my ($iflag, $oflag, $cflag, $lflag, $line, @cc) = unpack('LLLLCC[19]', $blob); 115 | return { 116 | iflag => $iflag, 117 | oflag => $oflag, 118 | cflag => $cflag, 119 | lflag => $lflag, 120 | line => $line, 121 | cc => \@cc, 122 | }; 123 | }; 124 | 125 | sub cfmakeraw($) { 126 | my ($termios) = @_; 127 | $termios->{iflag} &= 128 | ~(POSIX::IGNBRK | POSIX::BRKINT | POSIX::PARMRK | POSIX::ISTRIP | POSIX::INLCR | 129 | POSIX::IGNCR | POSIX::ICRNL | POSIX::IXON); 130 | $termios->{oflag} &= ~POSIX::OPOST; 131 | $termios->{lflag} &= 132 | ~(POSIX::ECHO | POSIX::ECHONL | POSIX::ICANON | POSIX::ISIG | POSIX::IEXTEN); 133 | $termios->{cflag} &= ~(POSIX::CSIZE | POSIX::PARENB); 134 | $termios->{cflag} |= POSIX::CS8; 135 | } 136 | 137 | sub tcgetattr($) { 138 | my ($fd) = @_; 139 | my $blob = termios(); 140 | ioctl($fd, TCGETS, $blob) or die "failed to get terminal attributes\n"; 141 | return $parse_termios->($blob); 142 | } 143 | 144 | sub tcsetattr($$) { 145 | my ($fd, $termios) = @_; 146 | my $blob = termios(%$termios); 147 | ioctl($fd, TCSETS, $blob) or die "failed to set terminal attributes\n"; 148 | } 149 | 150 | # tcgetsize -> (columns, rows) 151 | sub tcgetsize($) { 152 | my ($fd) = @_; 153 | my $struct_winsz = pack('SSSS', 0, 0, 0, 0); 154 | ioctl($fd, TIOCGWINSZ, $struct_winsz) 155 | or die "failed to get window size: $!\n"; 156 | return reverse unpack('SS', $struct_winsz); 157 | } 158 | 159 | sub tcsetsize($$$) { 160 | my ($fd, $columns, $rows) = @_; 161 | my $struct_winsz = pack('SSSS', $rows, $columns, 0, 0); 162 | ioctl($fd, TIOCSWINSZ, $struct_winsz) 163 | or die "failed to set window size: $!\n"; 164 | } 165 | 166 | sub read_line($;$$) { 167 | my ($query, $infd, $outfd) = @_; 168 | 169 | $infd //= \*STDIN; 170 | $outfd //= \*STDOUT; 171 | 172 | my $msg = -t $infd ? $query : "$query\n"; 173 | print $outfd $msg; 174 | 175 | my $input = ''; 176 | local $/ = "\n"; 177 | $input = <$infd>; 178 | chomp $input if $input; 179 | 180 | return $input; 181 | } 182 | 183 | sub read_password($;$$) { 184 | my ($query, $infd, $outfd) = @_; 185 | 186 | my $password = ''; 187 | 188 | $infd //= \*STDIN; 189 | 190 | if (!-t $infd) { # Not a terminal? Then just get a line... 191 | local $/ = "\n"; 192 | $password = <$infd>; 193 | die "EOF while reading password\n" if !defined $password; 194 | chomp $password; # Chop off the newline 195 | return $password; 196 | } 197 | 198 | $outfd //= \*STDOUT; 199 | 200 | # Raw read loop: 201 | my $old_termios; 202 | $old_termios = tcgetattr($infd); 203 | my $raw_termios = {%$old_termios}; 204 | cfmakeraw($raw_termios); 205 | tcsetattr($infd, $raw_termios); 206 | eval { 207 | my $echo = undef; 208 | my ($ch, $got); 209 | syswrite($outfd, $query, length($query)); 210 | while (($got = sysread($infd, $ch, 1))) { 211 | my ($ord) = unpack('C', $ch); 212 | last if $ord == 4; # ^D / EOF 213 | if ($ord == 0xA || $ord == 0xD) { 214 | # newline, we're done 215 | syswrite($outfd, "\r\n", 2); 216 | last; 217 | } elsif ($ord == 3) { # ^C 218 | die "password input aborted\n"; 219 | } elsif ($ord == 0x7f) { 220 | # backspace - if it's the first key disable 221 | # asterisks 222 | $echo //= 0; 223 | if (length($password)) { 224 | chop $password; 225 | syswrite($outfd, "\b \b", 3); 226 | } 227 | } elsif ($ord == 0x09) { 228 | # TAB disables the asterisk-echo 229 | $echo = 0; 230 | } else { 231 | # other character, append to password, if it's 232 | # the first character enable asterisks echo 233 | $echo //= 1; 234 | $password .= $ch; 235 | syswrite($outfd, '*', 1) if $echo; 236 | } 237 | } 238 | die "read error: $!\n" if !defined($got); 239 | }; 240 | my $err = $@; 241 | tcsetattr($infd, $old_termios); 242 | die $err if $err; 243 | return $password; 244 | } 245 | 246 | sub get_confirmed_password { 247 | my $pw1 = read_password('Enter new password: '); 248 | my $pw2 = read_password('Retype new password: '); 249 | die "passwords do not match\n" if $pw1 ne $pw2; 250 | return $pw1; 251 | } 252 | 253 | # Class functions 254 | 255 | sub new { 256 | my ($class) = @_; 257 | 258 | my ($master, $ttyname) = createpty(); 259 | 260 | my $self = { 261 | master => $master, 262 | ttyname => $ttyname, 263 | }; 264 | 265 | return bless $self, $class; 266 | } 267 | 268 | # Properties 269 | 270 | sub master { return $_[0]->{master} } 271 | sub ttyname { return $_[0]->{ttyname} } 272 | 273 | # Methods 274 | 275 | sub close { 276 | my ($self) = @_; 277 | close($self->{master}); 278 | } 279 | 280 | sub open_slave { 281 | my ($self) = @_; 282 | return $openslave->($self->{ttyname}); 283 | } 284 | 285 | sub set_size { 286 | my ($self, $columns, $rows) = @_; 287 | tcsetsize($self->{master}, $columns, $rows); 288 | } 289 | 290 | # get_size -> (columns, rows) 291 | sub get_size { 292 | my ($self) = @_; 293 | return tcgetsize($self->{master}); 294 | } 295 | 296 | sub kill { 297 | my ($self, $signal) = @_; 298 | if (!ioctl($self->{master}, TIOCSIG, $signal)) { 299 | # kill fallback if the ioctl does not work 300 | kill $signal, $self->get_foreground_pid() 301 | or die "failed to send signal: $!\n"; 302 | } 303 | } 304 | 305 | sub get_foreground_pid { 306 | my ($self) = @_; 307 | my $pid = pack('L', 0); 308 | ioctl($self->{master}, TIOCGPGRP, $pid) 309 | or die "failed to get foreground pid: $!\n"; 310 | return unpack('L', $pid); 311 | } 312 | 313 | sub has_process { 314 | my ($self) = @_; 315 | return 0 != $self->get_foreground_pid(); 316 | } 317 | 318 | sub make_controlling_terminal { 319 | my ($self) = @_; 320 | 321 | #lose_controlling_terminal(); 322 | POSIX::setsid(); 323 | my $slave = $self->open_slave(); 324 | ioctl($slave, TIOCSCTTY, 0) 325 | or die "failed to change controlling tty: $!\n"; 326 | POSIX::dup2(fileno($slave), 0) or die "failed to dup stdin\n"; 327 | POSIX::dup2(fileno($slave), 1) or die "failed to dup stdout\n"; 328 | POSIX::dup2(fileno($slave), 2) or die "failed to dup stderr\n"; 329 | CORE::close($slave) if fileno($slave) > 2; 330 | CORE::close($self->{master}); 331 | } 332 | 333 | sub getattr { 334 | my ($self) = @_; 335 | return tcgetattr($self->{master}); 336 | } 337 | 338 | sub setattr { 339 | my ($self, $termios) = @_; 340 | return tcsetattr($self->{master}, $termios); 341 | } 342 | 343 | sub send_cc { 344 | my ($self, $ccidx) = @_; 345 | my $attrs = $self->getattr(); 346 | my $data = pack('C', $attrs->{cc}->[$ccidx]); 347 | syswrite($self->{master}, $data) == 1 || die "write failed: $!\n"; 348 | } 349 | 350 | sub send_eof { 351 | my ($self) = @_; 352 | $self->send_cc(VEOF); 353 | } 354 | 355 | sub send_interrupt { 356 | my ($self) = @_; 357 | $self->send_cc(VINTR); 358 | } 359 | 360 | 1; 361 | -------------------------------------------------------------------------------- /test/section_config_test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib '../src'; 4 | 5 | package Conf; 6 | use strict; 7 | use warnings; 8 | 9 | use Test::More; 10 | 11 | use base qw(PVE::SectionConfig); 12 | 13 | my $defaultData = { 14 | propertyList => { 15 | type => { description => "Section type." }, 16 | id => { 17 | description => "ID", 18 | type => 'string', 19 | format => 'pve-configid', 20 | maxLength => 64, 21 | }, 22 | common => { 23 | type => 'string', 24 | description => 'common value', 25 | maxLength => 512, 26 | }, 27 | }, 28 | }; 29 | 30 | sub private { 31 | return $defaultData; 32 | } 33 | 34 | sub expect_success { 35 | my ($class, $filename, $expected, $raw, $allow_unknown) = @_; 36 | 37 | my $res = $class->parse_config($filename, $raw, $allow_unknown); 38 | delete $res->{digest}; 39 | 40 | is_deeply($res, $expected, $filename); 41 | 42 | my $written = $class->write_config($filename, $res, $allow_unknown); 43 | my $res2 = $class->parse_config($filename, $written, $allow_unknown); 44 | delete $res2->{digest}; 45 | 46 | is_deeply($res, $res2, "$filename - verify rewritten data"); 47 | } 48 | 49 | sub expect_fail { 50 | my ($class, $filename, $expected, $raw) = @_; 51 | 52 | eval { $class->parse_config($filename, $raw) }; 53 | die "test '$filename' succeeded unexpectedly\n" if !$@; 54 | ok(1, "$filename should fail to parse"); 55 | } 56 | 57 | package Conf::One; 58 | use strict; 59 | use warnings; 60 | 61 | use base 'Conf'; 62 | 63 | sub type { 64 | return 'one'; 65 | } 66 | 67 | sub properties { 68 | return { 69 | field1 => { 70 | description => 'Field One', 71 | type => 'integer', 72 | minimum => 3, 73 | maximum => 9, 74 | }, 75 | another => { 76 | description => 'Another field', 77 | type => 'string', 78 | }, 79 | }; 80 | } 81 | 82 | sub options { 83 | return { 84 | common => { optional => 1 }, 85 | field1 => {}, 86 | another => { optional => 1 }, 87 | }; 88 | } 89 | 90 | package Conf::Two; 91 | use strict; 92 | use warnings; 93 | 94 | use base 'Conf'; 95 | 96 | sub type { 97 | return 'two'; 98 | } 99 | 100 | sub properties { 101 | return { 102 | field2 => { 103 | description => 'Field Two', 104 | type => 'integer', 105 | minimum => 3, 106 | maximum => 9, 107 | }, 108 | arrayfield => { 109 | description => "Array Field with property string", 110 | type => 'array', 111 | items => { 112 | type => 'string', 113 | description => 'a property string', 114 | format => { 115 | subfield1 => { 116 | type => 'string', 117 | description => 'first subfield', 118 | }, 119 | subfield2 => { 120 | type => 'integer', 121 | minimum => 0, 122 | optional => 1, 123 | }, 124 | }, 125 | }, 126 | }, 127 | }; 128 | } 129 | 130 | sub options { 131 | return { 132 | common => { optional => 1 }, 133 | field2 => {}, 134 | another => {}, 135 | arrayfield => { optional => 1 }, 136 | }; 137 | } 138 | 139 | package main; 140 | 141 | use strict; 142 | use warnings; 143 | 144 | use Test::More; 145 | use PVE::JSONSchema; 146 | 147 | Conf::One->register(); 148 | Conf::Two->register(); 149 | Conf->init(); 150 | 151 | # FIXME: allow development debug warnings?! 152 | local $SIG{__WARN__} = sub { die @_; }; 153 | 154 | my sub enum { 155 | my $n = 1; 156 | return { map { $_ => $n++ } @_ }; 157 | } 158 | 159 | Conf->expect_success( 160 | 'test1', 161 | { 162 | ids => { 163 | t1 => { 164 | type => 'one', 165 | common => 'foo', 166 | field1 => 3, 167 | }, 168 | t2 => { 169 | type => 'one', 170 | common => 'foo2', 171 | field1 => 4, 172 | another => 'more-text', 173 | }, 174 | t3 => { 175 | type => 'two', 176 | field2 => 5, 177 | another => 'even more text', 178 | }, 179 | }, 180 | order => { t1 => 1, t2 => 2, t3 => 3 }, 181 | }, 182 | <<"EOF"); 183 | one: t1 184 | common foo 185 | field1 3 186 | 187 | one: t2 188 | common foo2 189 | field1 4 190 | another more-text 191 | 192 | two: t3 193 | field2 5 194 | another even more text 195 | EOF 196 | 197 | my $with_unknown_data = { 198 | ids => { 199 | t1 => { 200 | type => 'one', 201 | common => 'foo', 202 | field1 => 3, 203 | }, 204 | t2 => { 205 | type => 'one', 206 | common => 'foo2', 207 | field1 => 4, 208 | another => 'more-text', 209 | }, 210 | t3 => { 211 | type => 'two', 212 | field2 => 5, 213 | another => 'even more text', 214 | arrayfield => [ 215 | 'subfield1=test,subfield2=2', 'subfield1=test2', 216 | ], 217 | }, 218 | invalid => { 219 | type => 'bad', 220 | common => 'omg', 221 | unknownfield => 'shouldnotbehere', 222 | unknownarray => ['entry1', 'entry2'], 223 | }, 224 | }, 225 | order => enum(qw(t1 t2 invalid t3)), 226 | }; 227 | my $with_unknown_text = <<"EOF"; 228 | one: t1 229 | common foo 230 | field1 3 231 | 232 | one: t2 233 | common foo2 234 | field1 4 235 | another more-text 236 | 237 | bad: invalid 238 | common omg 239 | unknownfield shouldnotbehere 240 | unknownarray entry1 241 | unknownarray entry2 242 | 243 | two: t3 244 | field2 5 245 | another even more text 246 | arrayfield subfield1=test,subfield2=2 247 | arrayfield subfield1=test2 248 | EOF 249 | 250 | Conf->expect_fail('unknown-forbidden', $with_unknown_data, $with_unknown_text); 251 | Conf->expect_success('unknown-allowed', $with_unknown_data, $with_unknown_text, 1); 252 | 253 | # schema tests 254 | my $create_schema = Conf->createSchema(); 255 | my $expected_create_schema = { 256 | additionalProperties => 0, 257 | type => 'object', 258 | properties => { 259 | id => { 260 | description => 'ID', 261 | format => 'pve-configid', 262 | maxLength => 64, 263 | type => 'string', 264 | }, 265 | type => { 266 | description => 'Section type.', 267 | enum => ['one', 'two'], 268 | type => 'string', 269 | }, 270 | common => { 271 | type => 'string', 272 | description => 'common value', 273 | maxLength => 512, 274 | }, 275 | field1 => { 276 | description => 'Field One', 277 | maximum => 9, 278 | minimum => 3, 279 | optional => 1, 280 | type => 'integer', 281 | 282 | }, 283 | 'field2' => { 284 | 'description' => 'Field Two', 285 | 'maximum' => 9, 286 | 'minimum' => 3, 287 | 'optional' => 1, 288 | 'type' => 'integer', 289 | }, 290 | 'arrayfield' => { 291 | 'description' => 'Array Field with property string', 292 | 'items' => { 293 | 'description' => 'a property string', 294 | 'format' => { 295 | 'subfield2' => { 296 | 'optional' => 1, 297 | 'type' => 'integer', 298 | 'minimum' => 0, 299 | }, 300 | 'subfield1' => { 301 | 'description' => 'first subfield', 302 | 'type' => 'string', 303 | }, 304 | }, 305 | 'type' => 'string', 306 | }, 307 | 'optional' => 1, 308 | 'type' => 'array', 309 | }, 310 | 'another' => { 311 | 'description' => 'Another field', 312 | 'optional' => 1, 313 | 'type' => 'string', 314 | }, 315 | }, 316 | }; 317 | 318 | is_deeply($create_schema, $expected_create_schema, "create schema test"); 319 | 320 | my $update_schema = Conf->updateSchema(); 321 | my $expected_update_schema = { 322 | additionalProperties => 0, 323 | type => 'object', 324 | properties => { 325 | id => { 326 | description => 'ID', 327 | format => 'pve-configid', 328 | maxLength => 64, 329 | type => 'string', 330 | }, 331 | delete => { 332 | type => 'string', 333 | format => 'pve-configid-list', 334 | description => "A list of settings you want to delete.", 335 | maxLength => 4096, 336 | optional => 1, 337 | }, 338 | digest => PVE::JSONSchema::get_standard_option('pve-config-digest'), 339 | common => { 340 | description => 'common value', 341 | maxLength => 512, 342 | type => 'string', 343 | }, 344 | field1 => { 345 | description => 'Field One', 346 | maximum => 9, 347 | minimum => 3, 348 | optional => 1, 349 | type => 'integer', 350 | }, 351 | field2 => { 352 | description => 'Field Two', 353 | maximum => 9, 354 | minimum => 3, 355 | optional => 1, 356 | type => 'integer', 357 | }, 358 | arrayfield => { 359 | description => 'Array Field with property string', 360 | items => { 361 | type => 'string', 362 | description => 'a property string', 363 | format => { 364 | subfield2 => { 365 | type => 'integer', 366 | minimum => 0, 367 | optional => 1, 368 | }, 369 | subfield1 => { 370 | description => 'first subfield', 371 | type => 'string', 372 | }, 373 | }, 374 | }, 375 | optional => 1, 376 | type => 'array', 377 | }, 378 | another => { 379 | description => 'Another field', 380 | optional => 1, 381 | type => 'string', 382 | }, 383 | }, 384 | }; 385 | is_deeply($update_schema, $expected_update_schema, "update schema test"); 386 | 387 | done_testing(); 388 | 389 | 1; 390 | -------------------------------------------------------------------------------- /src/PVE/Systemd.pm: -------------------------------------------------------------------------------- 1 | package PVE::Systemd; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use IO::Socket::UNIX; 7 | use Net::DBus qw(dbus_uint32 dbus_uint64 dbus_boolean); 8 | use Net::DBus::Callback; 9 | use Net::DBus::Reactor; 10 | use POSIX qw(EINTR); 11 | use Socket qw(SOCK_DGRAM); 12 | 13 | use PVE::Tools qw(file_set_contents file_get_contents trim); 14 | 15 | sub escape_unit { 16 | my ($val, $is_path) = @_; 17 | 18 | # NOTE: this is not complete, but enough for our needs. normally all 19 | # characters which are not alpha-numerical, '.' or '_' would need escaping 20 | $val =~ s/\-/\\x2d/g; 21 | 22 | if ($is_path) { 23 | $val =~ s/^\///g; 24 | $val =~ s/\/$//g; 25 | } 26 | $val =~ s/\//-/g; 27 | 28 | return $val; 29 | } 30 | 31 | sub unescape_unit { 32 | my ($val) = @_; 33 | 34 | $val =~ s/-/\//g; 35 | $val =~ s/\\x([a-fA-F0-9]{2})/chr(hex($1))/eg; 36 | 37 | return $val; 38 | } 39 | 40 | # $code should take the parameters ($interface, $reactor, $finish_callback). 41 | # 42 | # $finish_callback can be used by dbus-signal-handlers to stop the reactor. 43 | # 44 | # In order to even start waiting on the reactor, $code needs to return undef, if it returns a 45 | # defined value instead, it is assumed that this is the result already and we can stop. 46 | # NOTE: This calls the dbus main loop and must not be used when another dbus 47 | # main loop is being used as we need to wait signals. 48 | sub systemd_call($;$) { 49 | my ($code, $timeout) = @_; 50 | 51 | my $bus = Net::DBus->system(); 52 | my $reactor = Net::DBus::Reactor->main(); 53 | 54 | my $service = $bus->get_service('org.freedesktop.systemd1'); 55 | my $if = $service->get_object('/org/freedesktop/systemd1', 'org.freedesktop.systemd1.Manager'); 56 | 57 | my ($finished, $current_result, $timer, $signal_info); 58 | my $finish_callback = sub { 59 | my ($result) = @_; 60 | 61 | $current_result = $result; 62 | 63 | $finished = 1; 64 | 65 | if (defined($timer)) { 66 | $reactor->remove_timeout($timer); 67 | $timer = undef; 68 | } 69 | 70 | if (defined($signal_info)) { 71 | $if->disconnect_from_signal($signal_info->{name}, $signal_info->{handle}); 72 | $signal_info = undef; 73 | } 74 | 75 | if (defined($reactor)) { 76 | $reactor->shutdown(); 77 | $reactor = undef; 78 | } 79 | }; 80 | 81 | (my $result, $signal_info) = $code->($if, $reactor, $finish_callback); 82 | # Are we done immediately? 83 | return $result if defined $result; 84 | 85 | # Alterantively $finish_callback may have been called already? 86 | return $current_result if $finished; 87 | 88 | # Otherwise wait: 89 | my $on_timeout = sub { 90 | $finish_callback->(undef); 91 | die "timeout waiting on systemd\n"; 92 | }; 93 | $timer = $reactor->add_timeout($timeout * 1000, Net::DBus::Callback->new(method => $on_timeout)) 94 | if defined($timeout); 95 | 96 | $reactor->run(); 97 | $reactor->shutdown() if defined($reactor); # $finish_callback clears it 98 | 99 | return $current_result; 100 | } 101 | 102 | # Polling the job status instead doesn't work because this doesn't give us the 103 | # distinction between success and failure. 104 | # 105 | # Note that the description is mandatory for security reasons. 106 | sub enter_systemd_scope { 107 | my ($unit, $description, %extra) = @_; 108 | die "missing description\n" if !defined($description); 109 | 110 | my $timeout = delete $extra{timeout}; 111 | 112 | $unit .= '.scope'; 113 | my $properties = [[PIDs => [dbus_uint32($$)]]]; 114 | 115 | foreach my $key (keys %extra) { 116 | if ($key eq 'Slice' || $key eq 'KillMode' || $key eq 'After' || $key eq 'Before') { 117 | push @{$properties}, [$key, $extra{$key}]; 118 | } elsif ($key eq 'SendSIGKILL') { 119 | push @{$properties}, [$key, dbus_boolean($extra{$key})]; 120 | } elsif ($key eq 'CPUShares' || $key eq 'CPUWeight' || $key eq 'TimeoutStopUSec') { 121 | push @{$properties}, [$key, dbus_uint64($extra{$key})]; 122 | } elsif ($key eq 'CPUQuota') { 123 | push @{$properties}, ['CPUQuotaPerSecUSec', dbus_uint64($extra{$key} * 10_000)]; 124 | } else { 125 | die "Don't know how to encode $key for systemd scope\n"; 126 | } 127 | } 128 | 129 | systemd_call( 130 | sub { 131 | my ($if, $reactor, $finish_cb) = @_; 132 | 133 | my $job; 134 | 135 | my $signal_name = 'JobRemoved'; 136 | my $signal_handle = $if->connect_to_signal( 137 | $signal_name, 138 | sub { 139 | my ($id, $removed_job, $signaled_unit, $result) = @_; 140 | return if $signaled_unit ne $unit || $removed_job ne $job; 141 | if ($result ne 'done') { 142 | # I seem to remember $reactor->run() catching die() at some point? 143 | # so better call finish to be sure...: 144 | $finish_cb->(0); 145 | die "systemd job failed\n"; 146 | } else { 147 | $finish_cb->(1); 148 | } 149 | }, 150 | ); 151 | 152 | $job = $if->StartTransientUnit($unit, 'fail', $properties, []); 153 | 154 | my $signal_info = { 155 | name => $signal_name, 156 | handle => $signal_handle, 157 | }; 158 | 159 | return (undef, $signal_info); 160 | }, 161 | $timeout, 162 | ); 163 | } 164 | 165 | sub wait_for_unit_removed($;$) { 166 | my ($unit, $timeout) = @_; 167 | 168 | systemd_call( 169 | sub { 170 | my ($if, $reactor, $finish_cb) = @_; 171 | 172 | my $unit_obj = eval { $if->GetUnit($unit) }; 173 | return 1 if !$unit_obj; 174 | 175 | my $signal_name = 'UnitRemoved'; 176 | my $signal_handle = $if->connect_to_signal( 177 | $signal_name, 178 | sub { 179 | my ($id, $removed_unit) = @_; 180 | $finish_cb->(1) if $removed_unit eq $unit_obj; 181 | }, 182 | ); 183 | 184 | my $signal_info = { 185 | name => $signal_name, 186 | handle => $signal_handle, 187 | }; 188 | 189 | # Deal with what we lost between GetUnit() and connecting to UnitRemoved: 190 | my $unit_obj_new = eval { $if->GetUnit($unit) }; 191 | if (!$unit_obj_new) { 192 | return (1, $signal_info); 193 | } 194 | 195 | return (undef, $signal_info); 196 | }, 197 | $timeout, 198 | ); 199 | } 200 | 201 | sub is_unit_active($;$) { 202 | my ($unit) = @_; 203 | 204 | my $bus = Net::DBus->system(); 205 | my $reactor = Net::DBus::Reactor->main(); 206 | 207 | my $service = $bus->get_service('org.freedesktop.systemd1'); 208 | my $if = $service->get_object('/org/freedesktop/systemd1', 'org.freedesktop.systemd1.Manager'); 209 | 210 | my $unit_path = eval { $if->GetUnit($unit) } 211 | or return 0; 212 | $if = $service->get_object($unit_path, 'org.freedesktop.systemd1.Unit') 213 | or return 0; 214 | my $state = $if->ActiveState; 215 | return defined($state) && $state eq 'active'; 216 | } 217 | 218 | sub read_ini { 219 | my ($filename) = @_; 220 | 221 | my $content = file_get_contents($filename); 222 | my @lines = split /\n/, $content; 223 | 224 | my $result = {}; 225 | my $section; 226 | 227 | foreach my $line (@lines) { 228 | $line = trim($line); 229 | if ($line =~ m/^\[([^\]]+)\]/) { 230 | $section = $1; 231 | if (!defined($result->{$section})) { 232 | $result->{$section} = {}; 233 | } 234 | } elsif ($line =~ m/^(.*?)=(.*)$/) { 235 | my ($key, $val) = ($1, $2); 236 | if (!$section) { 237 | warn "key value pair found without section, skipping\n"; 238 | next; 239 | } 240 | 241 | if ($result->{$section}->{$key}) { 242 | # make duplicate properties to arrays to keep the order 243 | my $prop = $result->{$section}->{$key}; 244 | if (ref($prop) eq 'ARRAY') { 245 | push @$prop, $val; 246 | } else { 247 | $result->{$section}->{$key} = [$prop, $val]; 248 | } 249 | } else { 250 | $result->{$section}->{$key} = $val; 251 | } 252 | } 253 | # ignore everything else 254 | } 255 | 256 | return $result; 257 | } 258 | 259 | sub write_ini { 260 | my ($ini, $filename) = @_; 261 | 262 | my $content = ""; 263 | 264 | foreach my $sname (sort keys %$ini) { 265 | my $section = $ini->{$sname}; 266 | 267 | $content .= "[$sname]\n"; 268 | 269 | foreach my $pname (sort keys %$section) { 270 | my $prop = $section->{$pname}; 271 | 272 | if (!ref($prop)) { 273 | $content .= "$pname=$prop\n"; 274 | } elsif (ref($prop) eq 'ARRAY') { 275 | foreach my $val (@$prop) { 276 | $content .= "$pname=$val\n"; 277 | } 278 | } else { 279 | die "invalid property '$pname'\n"; 280 | } 281 | } 282 | $content .= "\n"; 283 | } 284 | 285 | file_set_contents($filename, $content); 286 | } 287 | 288 | =head3 notify() 289 | 290 | This is a pure Perl reimplementation of systemd's C mechanism as defined in 291 | C, based on the example implementations in C. Does not return 292 | a value, but dies upon error. 293 | 294 | =cut 295 | 296 | sub notify { 297 | my ($message) = @_; 298 | 299 | # nothing to do if there is no socket 300 | my $socket_path = $ENV{NOTIFY_SOCKET} or return; 301 | 302 | die "notify systemd invalid socket path '$socket_path'\n" if $socket_path !~ m|^[/@]|; 303 | die "notify systemd called without a message\n" if !$message; 304 | 305 | # might be an abstract socket 306 | $socket_path =~ s/^@/\0/; 307 | 308 | my $socket = IO::Socket::UNIX->new( 309 | Type => SOCK_DGRAM(), 310 | Peer => $socket_path, 311 | ) or die "notify systemd: unable to connect to socket $socket_path - $IO::Socket::errstr\n"; 312 | 313 | # we won't be reading from the socket 314 | $socket->shutdown(SHUT_RD); 315 | 316 | my $res; 317 | while (1) { 318 | $res = $socket->send($message); 319 | if ($res) { 320 | die "notify systemd: protocol error writing to socket '$socket_path'\n" 321 | if $res < length($message); 322 | last; 323 | } else { 324 | next if $! == EINTR; 325 | die "notify systemd: sending to '$socket_path' failed - $!\n"; 326 | } 327 | } 328 | 329 | close($socket); 330 | 331 | return; 332 | } 333 | 334 | 1; 335 | -------------------------------------------------------------------------------- /test/etc_network_interfaces/t.create_network.pl: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Storable qw(dclone); 3 | 4 | my $ip_links = decode_json(load('ip_link_details')); 5 | 6 | for my $idx (1 .. 5) { 7 | my $entry = dclone($ip_links->{eth0}); 8 | $entry->{ifname} = "eth$idx"; 9 | 10 | $ip_links->{"eth$idx"} = $entry; 11 | } 12 | 13 | r(load('brbase'), $ip_links); 14 | 15 | # 16 | # Variables used for the various interfaces: 17 | # 18 | 19 | my $ip = '192.168.0.2/24'; 20 | my $gw = '192.168.0.1'; 21 | my $svcnodeip = '239.192.105.237'; 22 | my $physdev = 'eth0'; 23 | my $remoteip1 = '192.168.0.3'; 24 | my $remoteip2 = '192.168.0.4'; 25 | 26 | # 27 | # Hunk for the default bridge of the 'brbase' configuration 28 | # 29 | 30 | my $vmbr0_part = <<"PART"; 31 | auto vmbr0 32 | iface vmbr0 inet static 33 | address 10.0.0.2/24 34 | gateway 10.0.0.1 35 | bridge-ports eth0 36 | bridge-stp off 37 | bridge-fd 0 38 | PART 39 | chomp $vmbr0_part; 40 | 41 | # 42 | # Configure eth1 statically, store its expected interfaces hunk in $eth1_part 43 | # and test! 44 | # 45 | 46 | $config->{ifaces}->{eth1} = { 47 | type => 'eth', 48 | method => 'static', 49 | address => $ip, 50 | gateway => $gw, 51 | families => ['inet'], 52 | autostart => 1, 53 | }; 54 | 55 | my $eth1_part = <<"PART"; 56 | auto eth1 57 | iface eth1 inet static 58 | address $ip 59 | gateway $gw 60 | PART 61 | chomp $eth1_part; 62 | 63 | expect load('loopback') . <<"CHECK"; 64 | source-directory interfaces.d 65 | 66 | iface eth0 inet manual 67 | 68 | $eth1_part 69 | 70 | iface eth2 inet manual 71 | 72 | iface eth3 inet manual 73 | 74 | iface eth4 inet manual 75 | 76 | iface eth5 inet manual 77 | 78 | $vmbr0_part 79 | 80 | CHECK 81 | 82 | # 83 | # Add a bond for eth2 & 3 and check the new output 84 | # 85 | 86 | $config->{ifaces}->{bond0} = { 87 | type => 'bond', 88 | mtu => 1400, 89 | slaves => 'eth2 eth3', 90 | bond_mode => '802.3ad', 91 | bond_xmit_hash_policy => 'layer3+4', 92 | bond_miimon => 100, 93 | method => 'manual', 94 | families => ['inet'], 95 | autostart => 1, 96 | }; 97 | my $bond0_part = <<"PART"; 98 | auto bond0 99 | iface bond0 inet manual 100 | bond-slaves eth2 eth3 101 | bond-miimon 100 102 | bond-mode 802.3ad 103 | bond-xmit-hash-policy layer3+4 104 | mtu 1400 105 | PART 106 | chomp $bond0_part; 107 | 108 | expect load('loopback') . <<"CHECK"; 109 | source-directory interfaces.d 110 | 111 | iface eth0 inet manual 112 | 113 | $eth1_part 114 | 115 | auto eth2 116 | iface eth2 inet manual 117 | 118 | auto eth3 119 | iface eth3 inet manual 120 | 121 | iface eth4 inet manual 122 | 123 | iface eth5 inet manual 124 | 125 | $bond0_part 126 | 127 | $vmbr0_part 128 | 129 | CHECK 130 | 131 | # 132 | # Add vxlan1 and 2 133 | # 134 | 135 | $config->{ifaces}->{vxlan1} = { 136 | type => 'vxlan', 137 | method => 'manual', 138 | families => ['inet'], 139 | 'vxlan-id' => 1, 140 | 'vxlan-svcnodeip' => $svcnodeip, 141 | 'vxlan-physdev' => $physdev, 142 | autostart => 1, 143 | }; 144 | 145 | $config->{ifaces}->{vxlan2} = { 146 | type => 'vxlan', 147 | method => 'manual', 148 | families => ['inet'], 149 | 'vxlan-id' => 2, 150 | 'vxlan-local-tunnelip' => $ip, 151 | autostart => 1, 152 | }; 153 | 154 | my $vxlan12_part = <<"PART"; 155 | auto vxlan1 156 | iface vxlan1 inet manual 157 | vxlan-id 1 158 | vxlan-svcnodeip $svcnodeip 159 | vxlan-physdev $physdev 160 | 161 | auto vxlan2 162 | iface vxlan2 inet manual 163 | vxlan-id 2 164 | vxlan-local-tunnelip $ip 165 | PART 166 | chomp $vxlan12_part; 167 | 168 | expect load('loopback') . <<"CHECK"; 169 | source-directory interfaces.d 170 | 171 | iface eth0 inet manual 172 | 173 | $eth1_part 174 | 175 | auto eth2 176 | iface eth2 inet manual 177 | 178 | auto eth3 179 | iface eth3 inet manual 180 | 181 | iface eth4 inet manual 182 | 183 | iface eth5 inet manual 184 | 185 | $bond0_part 186 | 187 | $vmbr0_part 188 | 189 | $vxlan12_part 190 | 191 | CHECK 192 | 193 | # 194 | # Add vxlan3 and 3 bridges using vxlan1..3 195 | # 196 | 197 | $config->{ifaces}->{vmbr1} = { 198 | mtu => 1400, 199 | type => 'bridge', 200 | method => 'manual', 201 | families => ['inet'], 202 | bridge_stp => 'off', 203 | bridge_fd => 0, 204 | bridge_ports => 'vxlan1', 205 | bridge_vlan_aware => 'yes', 206 | autostart => 1, 207 | }; 208 | 209 | $config->{ifaces}->{vmbr2} = { 210 | type => 'bridge', 211 | method => 'manual', 212 | families => ['inet'], 213 | bridge_stp => 'off', 214 | bridge_fd => 0, 215 | bridge_ports => 'vxlan2', 216 | autostart => 1, 217 | }; 218 | 219 | $config->{ifaces}->{vmbr3} = { 220 | type => 'bridge', 221 | method => 'manual', 222 | families => ['inet'], 223 | bridge_stp => 'off', 224 | bridge_fd => 0, 225 | bridge_ports => 'vxlan3', 226 | bridge_vlan_aware => 'yes', 227 | bridge_vids => '2-10', 228 | autostart => 1, 229 | }; 230 | 231 | my $vmbr123_part = <<"PART"; 232 | auto vmbr1 233 | iface vmbr1 inet manual 234 | bridge-ports vxlan1 235 | bridge-stp off 236 | bridge-fd 0 237 | bridge-vlan-aware yes 238 | bridge-vids 2-4094 239 | mtu 1400 240 | 241 | auto vmbr2 242 | iface vmbr2 inet manual 243 | bridge-ports vxlan2 244 | bridge-stp off 245 | bridge-fd 0 246 | 247 | auto vmbr3 248 | iface vmbr3 inet manual 249 | bridge-ports vxlan3 250 | bridge-stp off 251 | bridge-fd 0 252 | bridge-vlan-aware yes 253 | bridge-vids 2-10 254 | PART 255 | chomp $vmbr123_part; 256 | 257 | $config->{ifaces}->{vxlan3} = { 258 | type => 'vxlan', 259 | method => 'manual', 260 | families => ['inet'], 261 | 'vxlan-id' => 3, 262 | 'vxlan-remoteip' => [$remoteip1, $remoteip2], 263 | 'bridge-access' => 3, 264 | autostart => 1, 265 | }; 266 | 267 | my $vx = $config->{ifaces}->{vxlan2}; 268 | $vx->{'bridge-learning'} = 'off'; 269 | $vx->{'bridge-arp-nd-suppress'} = 'on'; 270 | $vx->{'bridge-unicast-flood'} = 'off'; 271 | $vx->{'bridge-multicast-flood'} = 'off'; 272 | my $vxlan123_part = $vxlan12_part . "\n" . <<"PART"; 273 | bridge-arp-nd-suppress on 274 | bridge-learning off 275 | bridge-multicast-flood off 276 | bridge-unicast-flood off 277 | 278 | auto vxlan3 279 | iface vxlan3 inet manual 280 | vxlan-id 3 281 | vxlan-remoteip $remoteip1 282 | vxlan-remoteip $remoteip2 283 | bridge-access 3 284 | PART 285 | chomp $vxlan123_part; 286 | 287 | expect load('loopback') . <<"CHECK"; 288 | source-directory interfaces.d 289 | 290 | iface eth0 inet manual 291 | 292 | $eth1_part 293 | 294 | auto eth2 295 | iface eth2 inet manual 296 | 297 | auto eth3 298 | iface eth3 inet manual 299 | 300 | iface eth4 inet manual 301 | 302 | iface eth5 inet manual 303 | 304 | $bond0_part 305 | 306 | $vmbr0_part 307 | 308 | $vmbr123_part 309 | 310 | $vxlan123_part 311 | 312 | CHECK 313 | 314 | # 315 | # Now add vlans on all types of interfaces: vmbr1, bond0 and eth1 316 | # 317 | 318 | $config->{ifaces}->{'vmbr1.100'} = { 319 | type => 'vlan', 320 | mtu => 1300, 321 | method => 'manual', 322 | families => ['inet'], 323 | autostart => 1, 324 | }; 325 | 326 | $config->{ifaces}->{'bond0.100'} = { 327 | type => 'vlan', 328 | mtu => 1300, 329 | method => 'manual', 330 | families => ['inet'], 331 | 'vlan-protocol' => '802.1ad', 332 | autostart => 1, 333 | }; 334 | 335 | $config->{ifaces}->{'bond0.100.10'} = { 336 | type => 'vlan', 337 | mtu => 1300, 338 | method => 'manual', 339 | families => ['inet'], 340 | autostart => 1, 341 | }; 342 | 343 | $config->{ifaces}->{'eth1.100'} = { 344 | type => 'vlan', 345 | mtu => 1400, 346 | method => 'manual', 347 | families => ['inet'], 348 | autostart => 1, 349 | }; 350 | 351 | $config->{ifaces}->{'vmbr4'} = { 352 | mtu => 1200, 353 | type => 'bridge', 354 | method => 'manual', 355 | families => ['inet'], 356 | bridge_stp => 'off', 357 | bridge_fd => 0, 358 | bridge_ports => 'bond0.100', 359 | autostart => 1, 360 | }; 361 | 362 | $config->{ifaces}->{'vmbr5'} = { 363 | mtu => 1100, 364 | type => 'bridge', 365 | method => 'manual', 366 | families => ['inet'], 367 | bridge_stp => 'off', 368 | bridge_fd => 0, 369 | bridge_ports => 'vmbr4.99', 370 | autostart => 1, 371 | }; 372 | 373 | $config->{ifaces}->{vmbr6} = { 374 | ovs_mtu => 1400, 375 | type => 'OVSBridge', 376 | ovs_ports => 'bond1 ovsintvlan', 377 | method => 'manual', 378 | families => ['inet'], 379 | autostart => 1, 380 | }; 381 | 382 | $config->{ifaces}->{bond1} = { 383 | ovs_mtu => 1300, 384 | type => 'OVSBond', 385 | ovs_bridge => 'vmbr6', 386 | ovs_bonds => 'eth4 eth5', 387 | ovs_options => 'bond_mode=active-backup', 388 | method => 'manual', 389 | families => ['inet'], 390 | autostart => 1, 391 | }; 392 | 393 | $config->{ifaces}->{ovsintvlan} = { 394 | ovs_mtu => 1300, 395 | type => 'OVSIntPort', 396 | ovs_bridge => 'vmbr6', 397 | ovs_options => 'tag=14', 398 | method => 'manual', 399 | families => ['inet'], 400 | autostart => 1, 401 | }; 402 | 403 | expect load('loopback') . <<"CHECK"; 404 | source-directory interfaces.d 405 | 406 | iface eth0 inet manual 407 | 408 | $eth1_part 409 | 410 | auto eth2 411 | iface eth2 inet manual 412 | 413 | auto eth3 414 | iface eth3 inet manual 415 | 416 | auto eth4 417 | iface eth4 inet manual 418 | 419 | auto eth5 420 | iface eth5 inet manual 421 | 422 | auto eth1.100 423 | iface eth1.100 inet manual 424 | mtu 1400 425 | 426 | auto ovsintvlan 427 | iface ovsintvlan inet manual 428 | ovs_type OVSIntPort 429 | ovs_bridge vmbr6 430 | ovs_mtu 1300 431 | ovs_options tag=14 432 | 433 | $bond0_part 434 | 435 | auto bond1 436 | iface bond1 inet manual 437 | ovs_bonds eth4 eth5 438 | ovs_type OVSBond 439 | ovs_bridge vmbr6 440 | ovs_mtu 1300 441 | ovs_options bond_mode=active-backup 442 | 443 | auto bond0.100 444 | iface bond0.100 inet manual 445 | mtu 1300 446 | vlan-protocol 802.1ad 447 | 448 | auto bond0.100.10 449 | iface bond0.100.10 inet manual 450 | mtu 1300 451 | 452 | $vmbr0_part 453 | 454 | $vmbr123_part 455 | 456 | auto vmbr4 457 | iface vmbr4 inet manual 458 | bridge-ports bond0.100 459 | bridge-stp off 460 | bridge-fd 0 461 | mtu 1200 462 | 463 | auto vmbr5 464 | iface vmbr5 inet manual 465 | bridge-ports vmbr4.99 466 | bridge-stp off 467 | bridge-fd 0 468 | mtu 1100 469 | 470 | auto vmbr6 471 | iface vmbr6 inet manual 472 | ovs_type OVSBridge 473 | ovs_ports bond1 ovsintvlan 474 | ovs_mtu 1400 475 | 476 | auto vmbr1.100 477 | iface vmbr1.100 inet manual 478 | mtu 1300 479 | 480 | $vxlan123_part 481 | 482 | CHECK 483 | 484 | # 485 | # Now check the new config for idempotency: 486 | # 487 | 488 | save('if', w()); 489 | r(load('if'), $ip_links); 490 | expect load('if'); 491 | 492 | # 493 | # Check a brbase with an ipv6 address on eth1 494 | # 495 | 496 | r(load('brbase'), $ip_links); 497 | 498 | my $ip = 'fc05::2'; 499 | my $nm = '112'; 500 | my $gw = 'fc05::1'; 501 | 502 | $config->{ifaces}->{eth1} = { 503 | type => 'eth', 504 | method6 => 'static', 505 | address6 => $ip, 506 | netmask6 => $nm, 507 | gateway6 => $gw, 508 | families => ['inet6'], 509 | autostart => 1, 510 | }; 511 | 512 | expect load('loopback') . <<"CHECK"; 513 | source-directory interfaces.d 514 | 515 | iface eth0 inet manual 516 | 517 | auto eth1 518 | iface eth1 inet6 static 519 | address $ip/$nm 520 | gateway $gw 521 | 522 | iface eth2 inet manual 523 | 524 | iface eth3 inet manual 525 | 526 | iface eth4 inet manual 527 | 528 | iface eth5 inet manual 529 | 530 | auto vmbr0 531 | iface vmbr0 inet static 532 | address 10.0.0.2/24 533 | gateway 10.0.0.1 534 | bridge-ports eth0 535 | bridge-stp off 536 | bridge-fd 0 537 | 538 | CHECK 539 | 540 | save('if', w()); 541 | r(load('if'), $ip_links); 542 | expect load('if'); 543 | 544 | 1; 545 | -------------------------------------------------------------------------------- /src/PVE/PBSClient.pm: -------------------------------------------------------------------------------- 1 | package PVE::PBSClient; 2 | # utility functions for interaction with Proxmox Backup client CLI executable 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC); 8 | use File::Temp qw(tempdir); 9 | use IO::File; 10 | use JSON; 11 | use POSIX qw(mkfifo strftime ENOENT); 12 | 13 | use PVE::JSONSchema qw(get_standard_option); 14 | use PVE::Tools qw(run_command file_set_contents file_get_contents file_read_firstline $IPV6RE); 15 | 16 | # returns a repository string suitable for proxmox-backup-client, pbs-restore, etc. 17 | # $scfg must have the following structure: 18 | # { 19 | # datastore 20 | # server 21 | # port (optional defaults to 8007) 22 | # username (optional defaults to 'root@pam') 23 | # } 24 | sub get_repository { 25 | my ($scfg) = @_; 26 | 27 | my $server = $scfg->{server}; 28 | die "no server given\n" if !defined($server); 29 | 30 | $server = "[$server]" if $server =~ /^$IPV6RE$/; 31 | 32 | if (my $port = $scfg->{port}) { 33 | $server .= ":$port" if $port != 8007; 34 | } 35 | 36 | my $datastore = $scfg->{datastore}; 37 | die "no datastore given\n" if !defined($datastore); 38 | 39 | my $username = $scfg->{username} // 'root@pam'; 40 | 41 | return "$username\@$server:$datastore"; 42 | } 43 | 44 | sub new { 45 | my ($class, $scfg, $storeid, $secret_dir) = @_; 46 | 47 | die "no section config provided\n" if ref($scfg) eq ''; 48 | die "undefined store id\n" if !defined($storeid); 49 | 50 | $secret_dir = '/etc/pve/priv/storage' if !defined($secret_dir); 51 | 52 | my $self = bless( 53 | { 54 | scfg => $scfg, 55 | storeid => $storeid, 56 | secret_dir => $secret_dir, 57 | }, 58 | $class, 59 | ); 60 | return $self; 61 | } 62 | 63 | my sub password_file_name { 64 | my ($self) = @_; 65 | 66 | return "$self->{secret_dir}/$self->{storeid}.pw"; 67 | } 68 | 69 | sub set_password { 70 | my ($self, $password) = @_; 71 | 72 | my $pwfile = password_file_name($self); 73 | mkdir($self->{secret_dir}); 74 | 75 | PVE::Tools::file_set_contents($pwfile, "$password\n", 0600); 76 | } 77 | 78 | sub delete_password { 79 | my ($self) = @_; 80 | 81 | my $pwfile = password_file_name($self); 82 | 83 | unlink $pwfile or $! == ENOENT or die "deleting password file failed - $!\n"; 84 | } 85 | 86 | sub get_password { 87 | my ($self) = @_; 88 | 89 | my $pwfile = password_file_name($self); 90 | 91 | return PVE::Tools::file_read_firstline($pwfile); 92 | } 93 | 94 | sub encryption_key_file_name { 95 | my ($self) = @_; 96 | 97 | return "$self->{secret_dir}/$self->{storeid}.enc"; 98 | } 99 | 100 | sub set_encryption_key { 101 | my ($self, $key) = @_; 102 | 103 | my $encfile = $self->encryption_key_file_name(); 104 | mkdir($self->{secret_dir}); 105 | 106 | PVE::Tools::file_set_contents($encfile, "$key\n", 0600); 107 | } 108 | 109 | sub delete_encryption_key { 110 | my ($self) = @_; 111 | 112 | my $encfile = $self->encryption_key_file_name(); 113 | 114 | if (!unlink($encfile)) { 115 | return if $! == ENOENT; 116 | die "failed to delete encryption key! $!\n"; 117 | } 118 | } 119 | 120 | # Returns a file handle if there is an encryption key, or `undef` if there is not. Dies on error. 121 | my sub open_encryption_key { 122 | my ($self) = @_; 123 | 124 | my $encryption_key_file = $self->encryption_key_file_name(); 125 | 126 | my $keyfd; 127 | if (!open($keyfd, '<', $encryption_key_file)) { 128 | return undef if $! == ENOENT; 129 | die "failed to open encryption key: $encryption_key_file: $!\n"; 130 | } 131 | 132 | return $keyfd; 133 | } 134 | 135 | my $USE_CRYPT_PARAMS = { 136 | 'proxmox-backup-client' => { 137 | backup => 1, 138 | restore => 1, 139 | 'upload-log' => 1, 140 | }, 141 | 'proxmox-file-restore' => { 142 | list => 1, 143 | extract => 1, 144 | }, 145 | }; 146 | 147 | my sub do_raw_client_cmd { 148 | my ($self, $client_cmd, $param, %opts) = @_; 149 | 150 | my $client_bin = delete($opts{binary}) || 'proxmox-backup-client'; 151 | my $use_crypto = $USE_CRYPT_PARAMS->{$client_bin}->{$client_cmd} // 0; 152 | 153 | my $client_exe = "/usr/bin/$client_bin"; 154 | die "executable not found '$client_exe'! $client_bin not installed?\n" if !-x $client_exe; 155 | 156 | my $scfg = $self->{scfg}; 157 | my $repo = get_repository($scfg); 158 | 159 | my $userns_cmd = delete($opts{userns_cmd}); 160 | 161 | my $cmd = []; 162 | 163 | push(@$cmd, @$userns_cmd) if defined($userns_cmd); 164 | 165 | push(@$cmd, $client_exe, $client_cmd); 166 | 167 | # This must live in the top scope to not get closed before the `run_command` 168 | my $keyfd; 169 | if ($use_crypto) { 170 | if (defined($keyfd = open_encryption_key($self))) { 171 | my $flags = fcntl($keyfd, F_GETFD, 0) 172 | // die "failed to get file descriptor flags: $!\n"; 173 | fcntl($keyfd, F_SETFD, $flags & ~FD_CLOEXEC) 174 | or die "failed to remove FD_CLOEXEC from encryption key file descriptor\n"; 175 | push(@$cmd, '--crypt-mode=encrypt', '--keyfd=' . fileno($keyfd)); 176 | } else { 177 | push(@$cmd, '--crypt-mode=none'); 178 | } 179 | } 180 | 181 | push(@$cmd, @$param) if defined($param); 182 | 183 | push(@$cmd, "--repository", $repo); 184 | if (defined(my $ns = delete($opts{namespace}))) { 185 | push(@$cmd, '--ns', $ns); 186 | } 187 | 188 | local $ENV{PBS_PASSWORD} = $self->get_password(); 189 | 190 | local $ENV{PBS_FINGERPRINT} = $scfg->{fingerprint}; 191 | 192 | # no ascii-art on task logs 193 | local $ENV{PROXMOX_OUTPUT_NO_BORDER} = 1; 194 | local $ENV{PROXMOX_OUTPUT_NO_HEADER} = 1; 195 | 196 | if (my $logfunc = $opts{logfunc}) { 197 | $logfunc->("run: " . join(' ', @$cmd)); 198 | } 199 | 200 | run_command($cmd, %opts); 201 | } 202 | 203 | my sub run_raw_client_cmd : prototype($$$%) { 204 | my ($self, $client_cmd, $param, %opts) = @_; 205 | return do_raw_client_cmd($self, $client_cmd, $param, %opts); 206 | } 207 | 208 | my sub run_client_cmd : prototype($$;$$$$) { 209 | my ($self, $client_cmd, $param, $no_output, $binary, $namespace) = @_; 210 | 211 | my $json_str = ''; 212 | my $outfunc = sub { $json_str .= "$_[0]\n" }; 213 | 214 | $binary = 'proxmox-backup-client' if !defined($binary); 215 | 216 | $param = [] if !defined($param); 217 | $param = [$param] if !ref($param); 218 | 219 | $param = [@$param, '--output-format=json'] if !$no_output; 220 | 221 | do_raw_client_cmd( 222 | $self, 223 | $client_cmd, 224 | $param, 225 | outfunc => $outfunc, 226 | errmsg => "$binary failed", 227 | binary => $binary, 228 | namespace => $namespace, 229 | ); 230 | 231 | return undef if $no_output; 232 | 233 | my $res = decode_json($json_str); 234 | 235 | return $res; 236 | } 237 | 238 | sub autogen_encryption_key { 239 | my ($self) = @_; 240 | my $encfile = $self->encryption_key_file_name(); 241 | run_command( 242 | ['proxmox-backup-client', 'key', 'create', '--kdf', 'none', $encfile], 243 | errmsg => 'failed to create encryption key', 244 | ); 245 | return file_get_contents($encfile); 246 | } 247 | 248 | # TODO remove support for namespaced parameters. Needs Breaks for pmg-api and libpve-storage-perl. 249 | # Deprecated! The namespace should be passed in as part of the config in new(). 250 | # Snapshot or group parameters can be either just a string and will then default to the namespace 251 | # that's part of the initial configuration in new(), or a tuple of `[namespace, snapshot]`. 252 | my sub split_namespaced_parameter : prototype($$) { 253 | my ($self, $snapshot) = @_; 254 | return ($self->{scfg}->{namespace}, $snapshot) if !ref($snapshot); 255 | 256 | (my $namespace, $snapshot) = @$snapshot; 257 | return ($namespace, $snapshot); 258 | } 259 | 260 | # lists all snapshots, optionally limited to a specific group 261 | sub get_snapshots { 262 | my ($self, $group) = @_; 263 | 264 | my $namespace; 265 | if (defined($group)) { 266 | ($namespace, $group) = split_namespaced_parameter($self, $group); 267 | } else { 268 | $namespace = $self->{scfg}->{namespace}; 269 | } 270 | 271 | my $param = []; 272 | push(@$param, $group) if defined($group); 273 | 274 | return run_client_cmd($self, "snapshots", $param, undef, undef, $namespace); 275 | } 276 | 277 | # create a new PXAR backup of a FS directory tree - doesn't cross FS boundary 278 | # by default. 279 | sub backup_fs_tree { 280 | my ($self, $root, $id, $pxarname, $cmd_opts) = @_; 281 | 282 | die "backup-id not provided\n" if !defined($id); 283 | die "backup root dir not provided\n" if !defined($root); 284 | die "archive name not provided\n" if !defined($pxarname); 285 | 286 | my $param = [ 287 | "$pxarname.pxar:$root", '--backup-type', 'host', '--backup-id', $id, 288 | ]; 289 | 290 | $cmd_opts = {} if !defined($cmd_opts); 291 | 292 | if (defined(my $namespace = $self->{scfg}->{namespace})) { 293 | $cmd_opts->{namespace} = $namespace; 294 | } 295 | 296 | return run_raw_client_cmd($self, 'backup', $param, %$cmd_opts); 297 | } 298 | 299 | sub restore_pxar { 300 | my ($self, $snapshot, $pxarname, $target, $cmd_opts) = @_; 301 | 302 | die "snapshot not provided\n" if !defined($snapshot); 303 | die "archive name not provided\n" if !defined($pxarname); 304 | die "restore-target not provided\n" if !defined($target); 305 | 306 | (my $namespace, $snapshot) = split_namespaced_parameter($self, $snapshot); 307 | 308 | my $param = [ 309 | "$snapshot", "$pxarname.pxar", "$target", "--allow-existing-dirs", 0, 310 | ]; 311 | $cmd_opts = {} if !defined($cmd_opts); 312 | 313 | $cmd_opts->{namespace} = $namespace; 314 | 315 | return run_raw_client_cmd($self, 'restore', $param, %$cmd_opts); 316 | } 317 | 318 | sub forget_snapshot { 319 | my ($self, $snapshot) = @_; 320 | 321 | die "snapshot not provided\n" if !defined($snapshot); 322 | 323 | (my $namespace, $snapshot) = split_namespaced_parameter($self, $snapshot); 324 | 325 | return run_client_cmd($self, 'forget', ["$snapshot"], 1, undef, $namespace); 326 | } 327 | 328 | sub prune_group { 329 | my ($self, $opts, $prune_opts, $group) = @_; 330 | 331 | die "group not provided\n" if !defined($group); 332 | 333 | (my $namespace, $group) = split_namespaced_parameter($self, $group); 334 | 335 | # do nothing if no keep options specified for remote 336 | return [] if scalar(keys %$prune_opts) == 0; 337 | 338 | my $param = []; 339 | 340 | push(@$param, "--quiet"); 341 | 342 | if (defined($opts->{'dry-run'}) && $opts->{'dry-run'}) { 343 | push(@$param, "--dry-run", $opts->{'dry-run'}); 344 | } 345 | 346 | for my $keep_opt (keys %$prune_opts) { 347 | push(@$param, "--$keep_opt", $prune_opts->{$keep_opt}); 348 | } 349 | push(@$param, "$group"); 350 | 351 | return run_client_cmd($self, 'prune', $param, undef, undef, $namespace); 352 | } 353 | 354 | sub status { 355 | my ($self) = @_; 356 | 357 | my $total = 0; 358 | my $free = 0; 359 | my $used = 0; 360 | my $active = 0; 361 | 362 | eval { 363 | my $res = run_client_cmd($self, "status"); 364 | 365 | $active = 1; 366 | $total = $res->{total}; 367 | $used = $res->{used}; 368 | $free = $res->{avail}; 369 | }; 370 | if (my $err = $@) { 371 | warn $err; 372 | } 373 | 374 | return ($total, $free, $used, $active); 375 | } 376 | 377 | sub file_restore_list { 378 | my ($self, $snapshot, $filepath, $base64, $extra_params) = @_; 379 | 380 | (my $namespace, $snapshot) = split_namespaced_parameter($self, $snapshot); 381 | my $cmd = [$snapshot, $filepath, "--base64", ($base64 ? 1 : 0)]; 382 | 383 | if (my $timeout = $extra_params->{timeout}) { 384 | push($cmd->@*, '--timeout', $timeout); 385 | } 386 | 387 | return run_client_cmd( 388 | $self, "list", $cmd, 0, "proxmox-file-restore", $namespace, 389 | ); 390 | } 391 | 392 | # call sync from API, returns a fifo path for streaming data to clients, 393 | # pass it to file_restore_extract to start transfering data 394 | sub file_restore_extract_prepare { 395 | my ($self) = @_; 396 | 397 | my $tmpdir = tempdir(); 398 | mkfifo("$tmpdir/fifo", 0600) 399 | or die "creating file download fifo '$tmpdir/fifo' failed: $!\n"; 400 | 401 | # allow reading data for proxy user 402 | my $wwwid = getpwnam('www-data') 403 | || die "getpwnam failed"; 404 | chown($wwwid, -1, "$tmpdir") 405 | or die "changing permission on fifo dir '$tmpdir' failed: $!\n"; 406 | chown($wwwid, -1, "$tmpdir/fifo") 407 | or die "changing permission on fifo '$tmpdir/fifo' failed: $!\n"; 408 | 409 | return "$tmpdir/fifo"; 410 | } 411 | 412 | # this blocks while data is transfered, call this from a background worker 413 | sub file_restore_extract { 414 | my ($self, $output_file, $snapshot, $filepath, $base64, $tar) = @_; 415 | 416 | (my $namespace, $snapshot) = split_namespaced_parameter($self, $snapshot); 417 | 418 | my $ret = eval { 419 | local $SIG{ALRM} = sub { die "got timeout\n" }; 420 | alarm(30); 421 | sysopen(my $fh, "$output_file", O_WRONLY) 422 | or die "open target '$output_file' for writing failed: $!\n"; 423 | alarm(0); 424 | 425 | my $fn = fileno($fh); 426 | my $errfunc = sub { print $_[0], "\n"; }; 427 | 428 | my $cmd = [$snapshot, $filepath, "-", "--base64", ($base64 ? 1 : 0)]; 429 | if ($tar) { 430 | push(@$cmd, '--format', 'tar', '--zstd', 1); 431 | } 432 | 433 | return run_raw_client_cmd( 434 | $self, 435 | "extract", 436 | $cmd, 437 | binary => "proxmox-file-restore", 438 | namespace => $namespace, 439 | errfunc => $errfunc, 440 | output => ">&$fn", 441 | ); 442 | }; 443 | my $err = $@; 444 | 445 | unlink($output_file); 446 | $output_file =~ s/fifo$//; 447 | rmdir($output_file) if -d $output_file; 448 | 449 | die "file restore task failed: $err" if $err; 450 | return $ret; 451 | } 452 | 453 | 1; 454 | -------------------------------------------------------------------------------- /test/section_config_property_isolation_test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib '../src'; 4 | 5 | package Conf; 6 | use strict; 7 | use warnings; 8 | 9 | use Test::More; 10 | 11 | use base qw(PVE::SectionConfig); 12 | 13 | my $defaultData = { 14 | propertyList => { 15 | type => { description => "Section type." }, 16 | id => { 17 | description => "ID", 18 | type => 'string', 19 | format => 'pve-configid', 20 | maxLength => 64, 21 | }, 22 | common => { 23 | type => 'string', 24 | description => 'common value', 25 | maxLength => 512, 26 | }, 27 | }, 28 | }; 29 | 30 | sub private { 31 | return $defaultData; 32 | } 33 | 34 | sub expect_success { 35 | my ($class, $filename, $expected, $raw, $allow_unknown) = @_; 36 | 37 | my $res = $class->parse_config($filename, $raw, $allow_unknown); 38 | delete $res->{digest}; 39 | 40 | is_deeply($res, $expected, $filename); 41 | 42 | my $written = $class->write_config($filename, $res, $allow_unknown); 43 | my $res2 = $class->parse_config($filename, $written, $allow_unknown); 44 | delete $res2->{digest}; 45 | 46 | is_deeply($res, $res2, "$filename - verify rewritten data"); 47 | } 48 | 49 | sub expect_fail { 50 | my ($class, $filename, $expected, $raw) = @_; 51 | 52 | eval { $class->parse_config($filename, $raw) }; 53 | die "test '$filename' succeeded unexpectedly\n" if !$@; 54 | ok(1, "$filename should fail to parse"); 55 | } 56 | 57 | package Conf::One; 58 | use strict; 59 | use warnings; 60 | 61 | use base 'Conf'; 62 | 63 | sub type { 64 | return 'one'; 65 | } 66 | 67 | sub properties { 68 | return { 69 | field1 => { 70 | description => 'Field One', 71 | type => 'integer', 72 | minimum => 3, 73 | maximum => 9, 74 | }, 75 | field2 => { 76 | description => 'Field Two', 77 | type => 'integer', 78 | minimum => 10, 79 | maximum => 19, 80 | }, 81 | another => { 82 | description => 'Another field', 83 | type => 'string', 84 | optional => 1, 85 | }, 86 | arrayfield => { 87 | description => "Array Field with property string", 88 | optional => 1, 89 | type => 'array', 90 | items => { 91 | type => 'string', 92 | description => 'a property string', 93 | format => { 94 | subfield1 => { 95 | type => 'string', 96 | description => 'first subfield', 97 | }, 98 | subfield2 => { 99 | type => 'integer', 100 | minimum => 0, 101 | optional => 1, 102 | }, 103 | }, 104 | }, 105 | }, 106 | }; 107 | } 108 | 109 | sub options { 110 | return { 111 | common => { optional => 1 }, 112 | }; 113 | } 114 | 115 | package Conf::Two; 116 | use strict; 117 | use warnings; 118 | 119 | use base 'Conf'; 120 | 121 | sub type { 122 | return 'two'; 123 | } 124 | 125 | sub properties { 126 | return { 127 | field2 => { 128 | description => 'Field Two but different', 129 | type => 'integer', 130 | minimum => 3, 131 | maximum => 9, 132 | }, 133 | another => { 134 | description => 'Another field', 135 | type => 'string', 136 | }, 137 | arrayfield => { 138 | optional => 1, 139 | description => "Array Field with property string", 140 | type => 'array', 141 | items => { 142 | type => 'string', 143 | description => 'a property string', 144 | format => { 145 | subfield1 => { 146 | type => 'string', 147 | description => 'first subfield', 148 | }, 149 | subfield2 => { 150 | type => 'integer', 151 | minimum => 0, 152 | optional => 1, 153 | }, 154 | }, 155 | }, 156 | }, 157 | }; 158 | } 159 | 160 | sub options { 161 | return { 162 | common => { optional => 1 }, 163 | }; 164 | } 165 | 166 | package main; 167 | 168 | use strict; 169 | use warnings; 170 | 171 | use Test::More; 172 | 173 | Conf::One->register(); 174 | Conf::Two->register(); 175 | Conf->init(property_isolation => 1); 176 | 177 | # FIXME: allow development debug warnings?! 178 | local $SIG{__WARN__} = sub { die @_; }; 179 | 180 | my sub enum { 181 | my $n = 1; 182 | return { map { $_ => $n++ } @_ }; 183 | } 184 | 185 | Conf->expect_success( 186 | 'property-isolation-test1', 187 | { 188 | ids => { 189 | t1 => { 190 | type => 'one', 191 | common => 'foo', 192 | field1 => 3, 193 | field2 => 10, 194 | arrayfield => ['subfield1=test'], 195 | }, 196 | t2 => { 197 | type => 'one', 198 | common => 'foo2', 199 | field1 => 4, 200 | field2 => 15, 201 | another => 'more-text', 202 | }, 203 | t3 => { 204 | type => 'two', 205 | field2 => 5, 206 | another => 'even more text', 207 | }, 208 | }, 209 | order => { t1 => 1, t2 => 2, t3 => 3 }, 210 | }, 211 | <<"EOF"); 212 | one: t1 213 | common foo 214 | field1 3 215 | field2 10 216 | arrayfield subfield1=test 217 | 218 | one: t2 219 | common foo2 220 | field1 4 221 | field2 15 222 | another more-text 223 | 224 | two: t3 225 | field2 5 226 | another even more text 227 | EOF 228 | 229 | my $with_unknown_data = { 230 | ids => { 231 | t1 => { 232 | type => 'one', 233 | common => 'foo', 234 | field1 => 3, 235 | field2 => 10, 236 | }, 237 | t2 => { 238 | type => 'one', 239 | common => 'foo2', 240 | field1 => 4, 241 | field2 => 15, 242 | another => 'more-text', 243 | }, 244 | t3 => { 245 | type => 'two', 246 | field2 => 5, 247 | another => 'even more text', 248 | arrayfield => [ 249 | 'subfield1=test,subfield2=2', 'subfield1=test2', 250 | ], 251 | }, 252 | invalid => { 253 | type => 'bad', 254 | common => 'omg', 255 | unknownfield => 'shouldnotbehere', 256 | unknownarray => ['entry1', 'entry2'], 257 | }, 258 | }, 259 | order => enum(qw(t1 t2 invalid t3)), 260 | }; 261 | my $with_unknown_text = <<"EOF"; 262 | one: t1 263 | common foo 264 | field1 3 265 | field2 10 266 | 267 | one: t2 268 | common foo2 269 | field1 4 270 | field2 15 271 | another more-text 272 | 273 | bad: invalid 274 | common omg 275 | unknownfield shouldnotbehere 276 | unknownarray entry1 277 | unknownarray entry2 278 | 279 | two: t3 280 | field2 5 281 | another even more text 282 | arrayfield subfield1=test,subfield2=2 283 | arrayfield subfield1=test2 284 | EOF 285 | 286 | my $wrong_field_schema_data = { 287 | ids => { 288 | t1 => { 289 | type => 'one', 290 | common => 'foo', 291 | field1 => 3, 292 | field2 => 5, # this should fail 293 | }, 294 | }, 295 | order => enum(qw(t1)), 296 | }; 297 | 298 | my $wrong_field_schema_text = <<"EOF"; 299 | one: t1 300 | common foo 301 | field1 3 302 | field2 5 303 | EOF 304 | 305 | Conf->expect_fail( 306 | 'property-isolation-wrong-field-schema', 307 | $wrong_field_schema_data, 308 | $wrong_field_schema_text, 309 | ); 310 | Conf->expect_fail('property-isolation-unknown-forbidden', $with_unknown_data, $with_unknown_text); 311 | Conf->expect_success( 312 | 'property-isolation-unknown-allowed', 313 | $with_unknown_data, 314 | $with_unknown_text, 315 | 1, 316 | ); 317 | 318 | # schema tests 319 | my $create_schema = Conf->createSchema(); 320 | my $expected_create_schema = { 321 | additionalProperties => 0, 322 | type => 'object', 323 | properties => { 324 | id => { 325 | description => "ID", 326 | type => 'string', 327 | format => 'pve-configid', 328 | maxLength => 64, 329 | }, 330 | type => { 331 | description => 'Section type.', 332 | enum => ['one', 'two'], 333 | type => 'string', 334 | }, 335 | common => { 336 | maxLength => 512, 337 | optional => 1, 338 | type => 'string', 339 | description => 'common value', 340 | }, 341 | field1 => { 342 | type => 'integer', 343 | 'type-property' => 'type', 344 | 'instance-types' => ['one'], 345 | maximum => 9, 346 | optional => 1, 347 | minimum => 3, 348 | description => 'Field One', 349 | }, 350 | field2 => { 351 | oneOf => [ 352 | { 353 | description => 'Field Two', 354 | optional => 1, 355 | minimum => 10, 356 | 'instance-types' => ['one'], 357 | type => 'integer', 358 | maximum => 19, 359 | }, 360 | { 361 | optional => 1, 362 | minimum => 3, 363 | description => 'Field Two but different', 364 | type => 'integer', 365 | 'instance-types' => ['two'], 366 | maximum => 9, 367 | }, 368 | ], 369 | 'type-property' => 'type', 370 | }, 371 | arrayfield => { 372 | items => { 373 | type => 'string', 374 | format => { 375 | subfield1 => { 376 | description => 'first subfield', 377 | type => 'string', 378 | }, 379 | subfield2 => { 380 | minimum => 0, 381 | type => 'integer', 382 | optional => 1, 383 | }, 384 | }, 385 | description => 'a property string', 386 | }, 387 | description => 'Array Field with property string', 388 | type => 'array', 389 | optional => 1, 390 | }, 391 | another => { 392 | optional => 1, 393 | type => 'string', 394 | description => 'Another field', 395 | }, 396 | }, 397 | }; 398 | 399 | is_deeply($create_schema, $expected_create_schema, "property-isolation create schema test"); 400 | 401 | my $update_schema = Conf->updateSchema(); 402 | my $expected_update_schema = { 403 | additionalProperties => 0, 404 | type => 'object', 405 | properties => { 406 | id => { 407 | description => "ID", 408 | type => 'string', 409 | format => 'pve-configid', 410 | maxLength => 64, 411 | }, 412 | type => { 413 | type => 'string', 414 | enum => ['one', 'two'], 415 | description => 'Section type.', 416 | }, 417 | digest => { 418 | optional => 1, 419 | type => 'string', 420 | description => 421 | 'Prevent changes if current configuration file has a different digest. This can be used to prevent concurrent modifications.', 422 | maxLength => 64, 423 | }, 424 | delete => { 425 | description => 'A list of settings you want to delete.', 426 | maxLength => 4096, 427 | format => 'pve-configid-list', 428 | optional => 1, 429 | type => 'string', 430 | }, 431 | common => { 432 | maxLength => 512, 433 | description => 'common value', 434 | type => 'string', 435 | optional => 1, 436 | }, 437 | field1 => { 438 | description => 'Field One', 439 | maximum => 9, 440 | 'instance-types' => ['one'], 441 | 'type-property' => 'type', 442 | minimum => 3, 443 | optional => 1, 444 | type => 'integer', 445 | }, 446 | field2 => { 447 | 'type-property' => 'type', 448 | oneOf => [ 449 | { 450 | type => 'integer', 451 | minimum => 10, 452 | optional => 1, 453 | maximum => 19, 454 | 'instance-types' => ['one'], 455 | description => 'Field Two', 456 | }, 457 | { 458 | description => 'Field Two but different', 459 | maximum => 9, 460 | 'instance-types' => ['two'], 461 | minimum => 3, 462 | optional => 1, 463 | type => 'integer', 464 | }, 465 | ], 466 | }, 467 | arrayfield => { 468 | type => 'array', 469 | optional => 1, 470 | items => { 471 | description => 'a property string', 472 | type => 'string', 473 | format => { 474 | subfield2 => { 475 | type => 'integer', 476 | minimum => 0, 477 | optional => 1, 478 | }, 479 | subfield1 => { 480 | description => 'first subfield', 481 | type => 'string', 482 | }, 483 | }, 484 | }, 485 | description => 'Array Field with property string', 486 | }, 487 | another => { 488 | description => 'Another field', 489 | optional => 1, 490 | type => 'string', 491 | }, 492 | }, 493 | }; 494 | is_deeply($update_schema, $expected_update_schema, "property-isolation update schema test"); 495 | 496 | done_testing(); 497 | 498 | 1; 499 | -------------------------------------------------------------------------------- /src/PVE/Certificate.pm: -------------------------------------------------------------------------------- 1 | package PVE::Certificate; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Date::Parse; 7 | use Encode qw(decode encode); 8 | use MIME::Base64 qw(decode_base64 encode_base64); 9 | use Net::SSLeay; 10 | 11 | use PVE::JSONSchema qw(get_standard_option); 12 | 13 | Net::SSLeay::load_error_strings(); 14 | Net::SSLeay::randomize(); 15 | 16 | PVE::JSONSchema::register_format( 17 | 'pem-certificate', 18 | sub { 19 | my ($content, $noerr) = @_; 20 | 21 | return check_pem($content, noerr => $noerr); 22 | }, 23 | ); 24 | 25 | PVE::JSONSchema::register_format( 26 | 'pem-certificate-chain', 27 | sub { 28 | my ($content, $noerr) = @_; 29 | 30 | return check_pem($content, noerr => $noerr, multiple => 1); 31 | }, 32 | ); 33 | 34 | PVE::JSONSchema::register_format( 35 | 'pem-string', 36 | sub { 37 | my ($content, $noerr) = @_; 38 | 39 | return check_pem($content, noerr => $noerr, label => qr/.*?/); 40 | }, 41 | ); 42 | 43 | PVE::JSONSchema::register_standard_option( 44 | 'pve-certificate-info', 45 | { 46 | type => 'object', 47 | properties => { 48 | filename => { 49 | type => 'string', 50 | optional => 1, 51 | }, 52 | fingerprint => get_standard_option('fingerprint-sha256', { 53 | optional => 1, 54 | }), 55 | subject => { 56 | type => 'string', 57 | description => 'Certificate subject name.', 58 | optional => 1, 59 | }, 60 | issuer => { 61 | type => 'string', 62 | description => 'Certificate issuer name.', 63 | optional => 1, 64 | }, 65 | notbefore => { 66 | type => 'integer', 67 | description => 'Certificate\'s notBefore timestamp (UNIX epoch).', 68 | renderer => 'timestamp', 69 | optional => 1, 70 | }, 71 | notafter => { 72 | type => 'integer', 73 | description => 'Certificate\'s notAfter timestamp (UNIX epoch).', 74 | renderer => 'timestamp', 75 | optional => 1, 76 | }, 77 | san => { 78 | type => 'array', 79 | description => 'List of Certificate\'s SubjectAlternativeName entries.', 80 | optional => 1, 81 | renderer => 'yaml', 82 | items => { 83 | type => 'string', 84 | }, 85 | }, 86 | pem => { 87 | type => 'string', 88 | description => 'Certificate in PEM format', 89 | format => 'pem-certificate', 90 | optional => 1, 91 | }, 92 | 'public-key-type' => { 93 | type => 'string', 94 | description => 'Certificate\'s public key algorithm', 95 | optional => 1, 96 | }, 97 | 'public-key-bits' => { 98 | type => 'integer', 99 | description => 'Certificate\'s public key size', 100 | optional => 1, 101 | }, 102 | }, 103 | }, 104 | ); 105 | 106 | my $header_re = sub { 107 | my ($label) = @_; 108 | return qr!-----BEGIN\ $label-----(?:\s|\n)*!; 109 | }; 110 | my $footer_re = sub { 111 | my ($label) = @_; 112 | return qr!-----END\ $label-----(?:\s|\n)*!; 113 | }; 114 | my $pem_re = sub { 115 | my ($label) = @_; 116 | 117 | my $b64_char_re = qr![0-9A-Za-z\+/]!; # see RFC 7468 118 | my $header = $header_re->($label); 119 | my $footer = $footer_re->($label); 120 | 121 | return qr{ 122 | $header 123 | (?:(?:$b64_char_re)+\s*\n)* 124 | (?:$b64_char_re)*(?:=\s*\n=|={0,2})?\s*\n 125 | $footer 126 | }x; 127 | }; 128 | 129 | sub strip_leading_text { 130 | my ($content) = @_; 131 | 132 | my $header = $header_re->(qr/.*?/); 133 | $content =~ s/^.*?(?=$header)//s; 134 | return $content; 135 | } 136 | 137 | sub split_pem { 138 | my ($content, %opts) = @_; 139 | my $label = $opts{label} // 'CERTIFICATE'; 140 | 141 | my $header = $header_re->($label); 142 | return split(/(?=$header)/, $content); 143 | } 144 | 145 | sub check_pem { 146 | my ($content, %opts) = @_; 147 | 148 | $content = strip_leading_text($content); 149 | 150 | my $re = $pem_re->($opts{label} // 'CERTIFICATE'); 151 | $re = qr/($re\n+)*$re/ if $opts{multiple}; 152 | 153 | return $content if $content =~ /^$re$/; # OK 154 | 155 | return undef if $opts{noerr}; 156 | die "not a valid PEM-formatted string.\n"; 157 | } 158 | 159 | sub pem_to_der { 160 | my ($content) = @_; 161 | 162 | my $header = $header_re->(qr/.*?/); 163 | my $footer = $footer_re->(qr/.*?/); 164 | 165 | $content = strip_leading_text($content); 166 | 167 | # only take first PEM entry 168 | $content =~ s/^$header$//mg; 169 | $content =~ s/$footer.*//sg; 170 | 171 | $content = decode_base64($content); 172 | 173 | return $content; 174 | } 175 | 176 | sub der_to_pem { 177 | my ($content, %opts) = @_; 178 | 179 | my $label = $opts{label} // 'CERTIFICATE'; 180 | 181 | my $b64 = encode_base64($content, ''); 182 | $b64 = join("\n", ($b64 =~ /.{1,64}/sg)); 183 | return "-----BEGIN $label-----\n$b64\n-----END $label-----\n"; 184 | } 185 | 186 | my sub ssl_die { 187 | my ($msg) = @_; 188 | warn Net::SSLeay::print_errs(); 189 | Net::SSLeay::die_now("$msg\n"); 190 | } 191 | 192 | my $read_certificate = sub { 193 | my ($cert_path) = @_; 194 | 195 | die "'$cert_path' does not exist!\n" if !-e $cert_path; 196 | 197 | my $bio = Net::SSLeay::BIO_new_file($cert_path, 'r') 198 | or ssl_die("unable to read '$cert_path' - $!"); 199 | 200 | my $cert = Net::SSLeay::PEM_read_bio_X509($bio); 201 | Net::SSLeay::BIO_free($bio); 202 | die "unable to read certificate from '$cert_path'\n" if !$cert; 203 | 204 | return $cert; 205 | }; 206 | 207 | sub convert_asn1_to_epoch { 208 | my ($asn1_time) = @_; 209 | 210 | ssl_die("invalid ASN1 time object") if !$asn1_time; 211 | my $iso_time = Net::SSLeay::P_ASN1_TIME_get_isotime($asn1_time); 212 | ssl_die("unable to parse ASN1 time") if $iso_time eq ''; 213 | return Date::Parse::str2time($iso_time); 214 | } 215 | 216 | sub get_certificate_fingerprint { 217 | my ($cert_path) = @_; 218 | 219 | my $cert = $read_certificate->($cert_path); 220 | 221 | my $fp = Net::SSLeay::X509_get_fingerprint($cert, 'sha256'); 222 | Net::SSLeay::X509_free($cert); 223 | 224 | die "unable to get fingerprint for '$cert_path' - got empty value\n" 225 | if !defined($fp) || $fp eq ''; 226 | 227 | return $fp; 228 | } 229 | 230 | sub assert_certificate_matches_key { 231 | my ($cert_path, $key_path) = @_; 232 | 233 | die "No certificate path given!\n" if !$cert_path; 234 | die "No certificate key path given!\n" if !$key_path; 235 | 236 | die "Certificate at '$cert_path' does not exist!\n" if !-e $cert_path; 237 | die "Certificate key '$key_path' does not exist!\n" if !-e $key_path; 238 | 239 | my $ctx = Net::SSLeay::CTX_new() 240 | or ssl_die("Failed to create SSL context in order to verify private key"); 241 | 242 | eval { 243 | my $filetype = &Net::SSLeay::FILETYPE_PEM; 244 | 245 | Net::SSLeay::CTX_use_PrivateKey_file($ctx, $key_path, $filetype) 246 | or ssl_die("Failed to load private key from '$key_path' into SSL context"); 247 | 248 | Net::SSLeay::CTX_use_certificate_file($ctx, $cert_path, $filetype) 249 | or ssl_die("Failed to load certificate from '$cert_path' into SSL context"); 250 | 251 | Net::SSLeay::CTX_check_private_key($ctx) 252 | or ssl_die("Failed to validate private key and certificate"); 253 | }; 254 | my $err = $@; 255 | 256 | Net::SSLeay::CTX_free($ctx); 257 | 258 | die $err if $err; 259 | 260 | return 1; 261 | } 262 | 263 | sub get_certificate_info { 264 | my ($cert_path) = @_; 265 | 266 | my $cert = $read_certificate->($cert_path); 267 | 268 | my $parse_san = sub { 269 | my $res = []; 270 | while (my ($type, $value) = splice(@_, 0, 2)) { 271 | if ($type != 2 && $type != 7) { 272 | warn "unexpected SAN type encountered: $type\n"; 273 | next; 274 | } 275 | 276 | if ($type == 7) { 277 | my $hex = unpack("H*", $value); 278 | if (length($hex) == 8) { 279 | # IPv4 280 | $value = join(".", unpack("C4C4C4C4", $value)); 281 | } elsif (length($hex) == 32) { 282 | # IPv6 283 | $value = join(":", unpack("H4H4H4H4H4H4H4H4", $value)); 284 | } else { 285 | warn "cannot parse SAN IP entry '0x${hex}'\n"; 286 | next; 287 | } 288 | } 289 | 290 | push @$res, $value; 291 | } 292 | return $res; 293 | }; 294 | 295 | my $info = {}; 296 | 297 | $info->{fingerprint} = Net::SSLeay::X509_get_fingerprint($cert, 'sha256'); 298 | 299 | if (my $subject = Net::SSLeay::X509_get_subject_name($cert)) { 300 | $info->{subject} = Net::SSLeay::X509_NAME_oneline($subject); 301 | } 302 | 303 | if (my $issuer = Net::SSLeay::X509_get_issuer_name($cert)) { 304 | $info->{issuer} = Net::SSLeay::X509_NAME_oneline($issuer); 305 | } 306 | 307 | eval { $info->{notbefore} = convert_asn1_to_epoch(Net::SSLeay::X509_get_notBefore($cert)) }; 308 | warn $@ if $@; 309 | eval { $info->{notafter} = convert_asn1_to_epoch(Net::SSLeay::X509_get_notAfter($cert)) }; 310 | warn $@ if $@; 311 | 312 | $info->{san} = $parse_san->(Net::SSLeay::X509_get_subjectAltNames($cert)); 313 | $info->{pem} = Net::SSLeay::PEM_get_string_X509($cert); 314 | 315 | my $pub_key = eval { Net::SSLeay::X509_get_pubkey($cert) }; 316 | warn $@ if $@; 317 | if ($pub_key) { 318 | $info->{'public-key-type'} = Net::SSLeay::OBJ_nid2sn(Net::SSLeay::EVP_PKEY_id($pub_key)); 319 | $info->{'public-key-bits'} = Net::SSLeay::EVP_PKEY_bits($pub_key); 320 | Net::SSLeay::EVP_PKEY_free($pub_key); 321 | } 322 | 323 | Net::SSLeay::X509_free($cert); 324 | 325 | $cert_path =~ s!^.*/!!g; 326 | $info->{filename} = $cert_path; 327 | 328 | return $info; 329 | } 330 | 331 | # Obtain the expiration timestamp of a X.509 certificate as a UNIX epoch. 332 | sub get_expiration_as_epoch { 333 | my ($cert_path) = @_; 334 | 335 | my $cert = $read_certificate->($cert_path); 336 | my $not_after = eval { convert_asn1_to_epoch(Net::SSLeay::X509_get_notAfter($cert)) }; 337 | my $err = $@; 338 | 339 | Net::SSLeay::X509_free($cert); 340 | 341 | die $err if $err; 342 | 343 | return $not_after; 344 | } 345 | 346 | # Checks whether certificate expires before $timestamp (UNIX epoch) 347 | sub check_expiry { 348 | my ($cert_path, $timestamp) = @_; 349 | 350 | $timestamp //= time(); 351 | 352 | my $not_after = get_expiration_as_epoch($cert_path); 353 | 354 | return ($not_after < $timestamp) ? 1 : 0; 355 | } 356 | 357 | # Create a CSR and certificate key for a given order 358 | # returns path to CSR file or path to CSR and key files 359 | sub generate_csr { 360 | my (%attr) = @_; 361 | 362 | # optional 363 | my $bits = delete($attr{bits}) // 4096; 364 | my $dig_alg = delete($attr{digest}) // 'sha256'; 365 | my $pem_key = delete($attr{private_key}); 366 | 367 | # required 368 | my $identifiers = delete($attr{identifiers}); 369 | 370 | die "Identifiers are required to generate a CSR.\n" 371 | if !defined($identifiers); 372 | 373 | my $san = [map { $_->{value} } grep { $_->{type} eq 'dns' } @$identifiers]; 374 | die "DNS identifiers are required to generate a CSR.\n" if !scalar @$san; 375 | 376 | # optional 377 | my $common_name = delete($attr{common_name}) // $san->[0]; 378 | 379 | my $md = eval { Net::SSLeay::EVP_get_digestbyname($dig_alg) }; 380 | die "Invalid digest algorithm '$dig_alg'\n" if !$md; 381 | 382 | my ($bio, $pk, $req); 383 | 384 | my $cleanup = sub { 385 | my ($die_msg, $no_warn) = @_; 386 | Net::SSLeay::print_errs() if !$no_warn; 387 | 388 | Net::SSLeay::X509_REQ_free($req) if $req; 389 | Net::SSLeay::EVP_PKEY_free($pk) if $pk; 390 | Net::SSLeay::BIO_free($bio) if $bio; 391 | 392 | die $die_msg if $die_msg; 393 | }; 394 | 395 | # this unfortunately causes a small memory leak, since there is no 396 | # X509_NAME_free() (yet) 397 | my $name = Net::SSLeay::X509_NAME_new(); 398 | ssl_die("Failed to allocate X509_NAME object") if !$name; 399 | my $add_name_entry = sub { 400 | my ($k, $v) = @_; 401 | 402 | my $res = Net::SSLeay::X509_NAME_add_entry_by_txt( 403 | $name, 404 | $k, 405 | &Net::SSLeay::MBSTRING_UTF8, 406 | encode('utf-8', $v), 407 | ); 408 | 409 | $cleanup->("Failed to add '$k'='$v' to DN\n") if !$res; 410 | }; 411 | 412 | $add_name_entry->('CN', $common_name); 413 | for (qw(C ST L O OU)) { 414 | if (defined(my $v = $attr{$_})) { 415 | $add_name_entry->($_, $v); 416 | } 417 | } 418 | 419 | if (defined($pem_key)) { 420 | my $bio_s_mem = Net::SSLeay::BIO_s_mem(); 421 | $cleanup->("Failed to allocate BIO_s_mem for private key\n") if !$bio_s_mem; 422 | 423 | $bio = Net::SSLeay::BIO_new($bio_s_mem); 424 | $cleanup->("Failed to allocate BIO for private key\n") if !$bio; 425 | 426 | $cleanup->("Failed to write PEM-encoded key to BIO\n") 427 | if Net::SSLeay::BIO_write($bio, $pem_key) <= 0; 428 | 429 | $pk = Net::SSLeay::PEM_read_bio_PrivateKey($bio); 430 | $cleanup->("Failed to read private key into EVP_PKEY\n") if !$pk; 431 | } else { 432 | $pk = Net::SSLeay::EVP_PKEY_new(); 433 | $cleanup->("Failed to allocate EVP_PKEY for private key\n") if !$pk; 434 | 435 | my $rsa = Net::SSLeay::RSA_generate_key($bits, 65537); 436 | $cleanup->("Failed to generate RSA key pair\n") if !$rsa; 437 | 438 | $cleanup->("Failed to assign RSA key to EVP_PKEY\n") 439 | if !Net::SSLeay::EVP_PKEY_assign_RSA($pk, $rsa); 440 | } 441 | 442 | $req = Net::SSLeay::X509_REQ_new(); 443 | $cleanup->("Failed to allocate X509_REQ\n") if !$req; 444 | 445 | $cleanup->("Failed to set subject name\n") 446 | if (!Net::SSLeay::X509_REQ_set_subject_name($req, $name)); 447 | 448 | Net::SSLeay::P_X509_REQ_add_extensions( 449 | $req, 450 | &Net::SSLeay::NID_key_usage => 'digitalSignature,keyEncipherment', 451 | &Net::SSLeay::NID_basic_constraints => 'CA:FALSE', 452 | &Net::SSLeay::NID_ext_key_usage => 'serverAuth,clientAuth', 453 | &Net::SSLeay::NID_subject_alt_name => join(',', map { "DNS:$_" } @$san), 454 | ) or $cleanup->("Failed to add extensions to CSR\n"); 455 | 456 | $cleanup->("Failed to set public key\n") if !Net::SSLeay::X509_REQ_set_pubkey($req, $pk); 457 | 458 | $cleanup->("Failed to set CSR version\n") if !Net::SSLeay::X509_REQ_set_version($req, 0); 459 | 460 | $cleanup->("Failed to sign CSR\n") if !Net::SSLeay::X509_REQ_sign($req, $pk, $md); 461 | 462 | my $pk_pem = Net::SSLeay::PEM_get_string_PrivateKey($pk); 463 | my $req_pem = Net::SSLeay::PEM_get_string_X509_REQ($req); 464 | 465 | $cleanup->(undef, 1); 466 | 467 | return wantarray ? ($req_pem, $pk_pem) : $req_pem; 468 | } 469 | 470 | 1; 471 | --------------------------------------------------------------------------------