From: Thomas Lamprecht Date: Tue, 23 Apr 2024 13:43:01 +0000 (+0200) Subject: bump version to 8.2.1 X-Git-Url: https://git.proxmox.com/?p=pve-common.git;a=commitdiff_plain;h=HEAD;hp=09d47f9d477b95382874de1233d1b012fbf4763f bump version to 8.2.1 Signed-off-by: Thomas Lamprecht --- diff --git a/Makefile b/Makefile index 7ea60be..637cd49 100644 --- a/Makefile +++ b/Makefile @@ -4,40 +4,43 @@ PACKAGE=libpve-common-perl ARCH=all -BUILDDIR ?= ${PACKAGE}-${DEB_VERSION_UPSTREAM} +BUILDDIR ?= $(PACKAGE)-$(DEB_VERSION_UPSTREAM) -DEB=${PACKAGE}_${DEB_VERSION_UPSTREAM_REVISION}_${ARCH}.deb -DSC=${PACKAGE}_${DEB_VERSION_UPSTREAM_REVISION}.dsc -TARGZ=${PACKAGE}_${DEB_VERSION_UPSTREAM_REVISION}.tar.gz +DEB=$(PACKAGE)_$(DEB_VERSION_UPSTREAM_REVISION)_$(ARCH).deb +DSC=$(PACKAGE)_$(DEB_VERSION_UPSTREAM_REVISION).dsc all: - ${MAKE} -C src + $(MAKE) -C src .PHONY: dinstall dinstall: deb - dpkg -i ${DEB} + dpkg -i $(DEB) -${BUILDDIR}: src debian - rm -rf ${BUILDDIR} - rsync -a * ${BUILDDIR} - echo "git clone git://git.proxmox.com/git/pve-common.git\\ngit checkout $(shell git rev-parse HEAD)" > ${BUILDDIR}/debian/SOURCE +$(BUILDDIR): src debian test + rm -rf $(BUILDDIR) $(BUILDDIR).tmp; mkdir $(BUILDDIR).tmp + cp -a -t $(BUILDDIR).tmp $^ Makefile + echo "git clone git://git.proxmox.com/git/pve-common.git\\ngit checkout $(shell git rev-parse HEAD)" > $(BUILDDIR).tmp/debian/SOURCE + mv $(BUILDDIR).tmp $(BUILDDIR) .PHONY: deb -deb: ${DEB} -${DEB}: ${BUILDDIR} - cd ${BUILDDIR}; dpkg-buildpackage -b -us -uc - lintian ${DEB} +deb: $(DEB) +$(DEB): $(BUILDDIR) + cd $(BUILDDIR); dpkg-buildpackage -b -us -uc + lintian $(DEB) .PHONY: dsc -dsc ${TARGZ}: ${DSC} -${DSC}: ${BUILDDIR} - cd ${BUILDDIR}; dpkg-buildpackage -S -us -uc -d -nc - lintian ${DSC} +dsc: $(DSC) +$(DSC): $(BUILDDIR) + cd $(BUILDDIR); dpkg-buildpackage -S -us -uc -d + lintian $(DSC) + +sbuild: $(DSC) + sbuild $(DSC) .PHONY: clean distclean distclean: clean clean: - rm -rf *~ *.deb *.changes ${BUILDDIR} *.buildinfo *.dsc *.tar.gz + rm -rf *~ *.deb *.changes $(PACKAGE)-[0-9]*/ *.buildinfo *.build *.dsc *.tar.?z .PHONY: check check: @@ -45,8 +48,9 @@ check: .PHONY: install install: - ${MAKE} -C src install + $(MAKE) -C src install .PHONY: upload -upload: ${DEB} - tar cf - ${DEB}|ssh -X repoman@repo.proxmox.com -- upload --product pve,pmg --dist buster +upload: UPLOAD_DIST ?= $(DEB_DISTRIBUTION) +upload: $(DEB) + tar cf - $(DEB)|ssh -X repoman@repo.proxmox.com -- upload --product pve,pmg --dist $(UPLOAD_DIST) diff --git a/README.dev b/README.dev index ea9bcf1..c5468f8 100644 --- a/README.dev +++ b/README.dev @@ -1,7 +1,7 @@ = Setup PVE Development Environment = 0. Read https://pve.proxmox.com/wiki/Developer_Documentation -1. Install Debian 9 'stretch' (you can also start from a PVE installation and +1. Install Debian 12 Bookworm (you can also start from a PVE installation and skip step 2 - 5, 7 - 11) 2. Configure the network interface(s) 3. Change the IP address of your hostname for proper name resolution @@ -19,11 +19,11 @@ 6. Configure 'pvetest' repository in /etc/apt/sources.list.d/: - run: echo "deb http://download.proxmox.com/debian stretch pvetest" > /etc/apt/sources.list.d/pve-development.list + run: echo "deb http://download.proxmox.com/debian bookworm pvetest" > /etc/apt/sources.list.d/pve-development.list -7. Add the repository key: +7. Add the repository key, run: - run: wget -O- "http://download.proxmox.com/debian/proxmox-ve-release-5.x.gpg" | apt-key add - + wget -O /etc/apt/trusted.gpg.d/proxmox-release-bookworm.gpg "https://enterprise.proxmox.com/debian/proxmox-release-bookworm.gpg" 8. run: apt-get update && apt-get dist-upgrade 9. run: apt-get install proxmox-ve diff --git a/debian/changelog b/debian/changelog index 2f15ea5..1b7ddcf 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,578 @@ +libpve-common-perl (8.2.1) bookworm; urgency=medium + + * interfaces: support stanzas without types/methods, like ifupdown2 supports + + -- Proxmox Support Team Tue, 23 Apr 2024 15:42:55 +0200 + +libpve-common-perl (8.2.0) bookworm; urgency=medium + + * fix #545: interfaces: allow arbitrary bridge names in network config + + -- Proxmox Support Team Sun, 21 Apr 2024 11:50:54 +0200 + +libpve-common-perl (8.1.2) bookworm; urgency=medium + + * remote format: improve documentation of expected API-token format + + * json schema: add format description for pve-storage-id standard option + + -- Proxmox Support Team Wed, 17 Apr 2024 21:10:32 +0200 + +libpve-common-perl (8.1.1) bookworm; urgency=medium + + * fix #5141: network parser: fix accidental RE result re-use and add tests + + * network tests: switch to ifupdown2 + + * network parser: iterate deterministically + + * schema: fixup description vs format_description in remote_format + + * add PVE::Systemd::is_unit_active + + * ticket: remove fallback for SHA1-base64 CSRF prevention tokens + + * expose SYS_prctl + + -- Proxmox Support Team Wed, 06 Mar 2024 12:03:00 +0100 + +libpve-common-perl (8.1.0) bookworm; urgency=medium + + * tools: Add mknod syscall + + * tools: Add mount flag constants + + * json schema: implement support for 'oneOf' schema + + * section config: allow (opt-in) full property-isolation for plugins + + -- Proxmox Support Team Tue, 21 Nov 2023 13:04:21 +0100 + +libpve-common-perl (8.0.10) bookworm; urgency=medium + + * pbs client: add 'tar' parameter to file_restore_extract + + * fix #4162: added `Auto-Submitted` header to email body + + -- Proxmox Support Team Tue, 07 Nov 2023 08:58:23 +0100 + +libpve-common-perl (8.0.9) bookworm; urgency=medium + + * section config: fix handling unknown sections with arrays which + broke the jobs configuration when running 'qm destroy ID --purge'. + + * tools: improve error handling for run with timeout helpers. + + * tools: allow forcing UTF-8 encoding in file set contents helper. + + -- Proxmox Support Team Mon, 11 Sep 2023 13:46:15 +0200 + +libpve-common-perl (8.0.8) bookworm; urgency=medium + + * fix #4849: download file from url: add opt parameter for a decompression + command + + * ldap: handle errors explicitly to improve user visible error messages + + * section config: allow base properties for 'createSchema' and + 'updateSchema' + + -- Proxmox Support Team Fri, 11 Aug 2023 13:25:04 +0200 + +libpve-common-perl (8.0.7) bookworm; urgency=medium + + * schema: increase pve-config-digest maxLength to 64 + + -- Proxmox Support Team Mon, 24 Jul 2023 11:55:39 +0200 + +libpve-common-perl (8.0.6) bookworm; urgency=medium + + * network: cope with non-existing interfaces config when getting local IPs + + * run with timeout: return if timeout happened in list context + + -- Proxmox Support Team Sat, 01 Jul 2023 19:24:06 +0200 + +libpve-common-perl (8.0.5) bookworm; urgency=medium + + * api dump: ignore proxyto_callback code refs + + -- Proxmox Support Team Sat, 17 Jun 2023 13:58:23 +0200 + +libpve-common-perl (8.0.4) bookworm; urgency=medium + + * read firstline helper: only map ENOENT to undef, raise error otherwise + + * ldap: fail authentication if DN is emptyu + + * syslog: map cut-off priority level 'warn' to 'warning' as convenience, we + use the former in quite some places already. + + * fix #4778: fix recent regression with boolean type check for JSON + parameters over the API + + * schema: explicitly set min/max for VMID option, which then propagates into + our API viewer tool, pointing our actual valid range out more prominently + to users and external developers. + + -- Proxmox Support Team Fri, 16 Jun 2023 10:29:19 +0200 + +libpve-common-perl (8.0.3) bookworm; urgency=medium + + * implement array support for section configs + + * drop support for the '-alist' format + + -- Proxmox Support Team Wed, 07 Jun 2023 13:51:34 +0200 + +libpve-common-perl (8.0.2) bookworm; urgency=medium + + * schema: add support for array parameter in api calls, cli and config + + * schema: improve description of bwlimit parameter + + * remove unused SysFSTools::pci_cleanup_mdev_device + + -- Proxmox Support Team Wed, 07 Jun 2023 13:12:18 +0200 + +libpve-common-perl (8.0.1) bookworm; urgency=medium + + * cli usage: remove extra newlines before descriptions + + * d/control: record dependency on libanyevent-perl + + -- Proxmox Support Team Fri, 19 May 2023 14:39:05 +0200 + +libpve-common-perl (8.0.0) bookworm; urgency=medium + + * re-build for Debian 12 Bookworm based release series + + -- Proxmox Support Team Mon, 08 May 2023 15:12:53 +0200 + +libpve-common-perl (7.4-1) bullseye; urgency=medium + + * REST & CLI handler: minimize scope of no-strict-refs exemption + + * cert: fix invalid CSR version + + * partially fix #1454: meminfo: also return arcsize + + * cgroup: allow one to set the memory.high CGv2 knob too + + -- Proxmox Support Team Wed, 26 Apr 2023 12:23:26 +0200 + +libpve-common-perl (7.3-4) bullseye; urgency=medium + + * fix #4615: REST environment: improve AnyEvent detectíon in child cleanup + + -- Proxmox Support Team Mon, 27 Mar 2023 10:36:41 +0200 + +libpve-common-perl (7.3-3) bullseye; urgency=medium + + * fix #4299: network: check the interface specific sysfs path to detect if + IPv6 is disabled, as the global one might be available either way + + * certificate: add helper to check if cert and key match + + * API REST environment: postpone worker process collection on SIGCHLD if + it's likely that the process runs in an AnyEvent loop to avoid a race + resulting in failure to update the active task list + + * section config: add helper for deleting keys from a entry + + * certificate: actually print openssl errors + + -- Proxmox Support Team Thu, 16 Mar 2023 16:35:39 +0100 + +libpve-common-perl (7.3-2) bullseye; urgency=medium + + * fix #4299: check full path to 'disable_ipv6' file in case ipv6 is disabled + but the directory for it exists + + * add callback based filtering for dump_logfile and add a stateful variant + usable for multiple files via handles + + -- Proxmox Support Team Fri, 27 Jan 2023 10:28:32 +0100 + +libpve-common-perl (7.3-1) bullseye; urgency=medium + + * network: fix learning-on check for adding and deleting FDB entries + + * dump logfile: return whole log file if `limit` parameter is `0` + + -- Proxmox Support Team Thu, 24 Nov 2022 17:12:56 +0100 + +libpve-common-perl (7.2-8) bullseye; urgency=medium + + * pbs client: use 25s timeout and add extra-params + + * network: support adding fdb directly in tap_plug + + -- Proxmox Support Team Sun, 20 Nov 2022 16:26:19 +0100 + +libpve-common-perl (7.2-7) bullseye; urgency=medium + + * job registry: avoid injecting the section id unconditionally in + configs + + * network: tap plug: auto-disable learning if `bridge-disable-mac- + learning` option is set on the underlying Linux bridge; modern VM/CT + management stack adds the MAC then manually to the forwarding DB (FDB) on + start or (migration-)resume. + + -- Proxmox Support Team Sun, 13 Nov 2022 15:53:53 +0100 + +libpve-common-perl (7.2-6) bullseye; urgency=medium + + * section config: optionally support unknown types so that a local plugin + can edit their own entries without needing to understand all possible + types in a configuration backed by the section config format. + + * move the scheduled job base config & registry over from pve-manager as + PVE::Job::Registry for better reuse + + -- Proxmox Support Team Sat, 12 Nov 2022 16:04:59 +0100 + +libpve-common-perl (7.2-5) bullseye; urgency=medium + + * schema: take over 'pve-targetstorage' option + + * cgroup: change cpu shares: drop ignored $cgroupv1_default parameter + + -- Proxmox Support Team Mon, 07 Nov 2022 16:05:10 +0100 + +libpve-common-perl (7.2-4) bullseye; urgency=medium + + * pbs client: drop namespace parameter in backup_fs_tree + + * pbs client: deprecate explicit namespace parameters in favor of requiring + it to be configured on instantiation + + * pbs client: use the configured namespace as default instead of the root + namespace where the namespace parameter is optional + + * pbs client: suppress meaningless "data: null" output when removing snapshots + + * pbs client: do not consider deleting a non-existent password an error + + * cgroup: move get_cpuunits helper from qemu-server as clamp_cpu_shares + + -- Proxmox Support Team Fri, 04 Nov 2022 14:06:28 +0100 + +libpve-common-perl (7.2-3) bullseye; urgency=medium + + * proc fs tools: handle proc/stat without guest values + + * sysfs: get name from mediated device types, if any + + * network: improve setting MTU of TAP devices if re-plugged on a different + bridge or if used with OVS + + * remove PVE::Subscription and friends, replaced by common rust + implementation + + * cgroup: get mode by checking /sys/fs/cgroup mount point + + -- Proxmox Support Team Mon, 19 Sep 2022 11:30:30 +0200 + +libpve-common-perl (7.2-2) bullseye; urgency=medium + + * tools: use int() on all integer syscall parameters to avoid that + stringification leads to using the address as argument, fixing among + other things CT restore with custom id mappings + + -- Proxmox Support Team Fri, 20 May 2022 14:01:17 +0200 + +libpve-common-perl (7.2-1) bullseye; urgency=medium + + * pbs-client: namespace support + + -- Proxmox Support Team Thu, 12 May 2022 14:42:37 +0200 + +libpve-common-perl (7.1-6) bullseye; urgency=medium + + * json schema: allow to export print_property_string + + * formatter: render duration: support autolimiting accurarcy + + * SysFSTools: factor out normalizing the PCI domain + + * REST handler: get property description: escape curly braces for asciidoc + + -- Proxmox Support Team Thu, 28 Apr 2022 16:40:34 +0200 + +libpve-common-perl (7.1-5) bullseye; urgency=medium + + * network: fix default of new bridge learning flag + + -- Proxmox Support Team Fri, 18 Mar 2022 10:13:48 +0100 + +libpve-common-perl (7.1-4) bullseye; urgency=medium + + * REST environment: allow export of log_warn + + * RESTenv: fork worker: fallback to root@pam for task log user-id + + * network: add support for disabling bridge learning on tap|veth|fwln + ports + + * inotify: add bridge-disable-mac-learning option to bridges. + + * sysfs tools: allow longer pci domains + + * switch to using Proxmox::RS::CalendarEvent + + -- Proxmox Support Team Thu, 17 Mar 2022 14:10:58 +0100 + +libpve-common-perl (7.1-3) bullseye; urgency=medium + + * add 'map_id' helper for ID maps + + -- Proxmox Support Team Wed, 09 Feb 2022 18:36:44 +0100 + +libpve-common-perl (7.1-2) bullseye; urgency=medium + + * calendar event: base on more capable rust implementation via perlmod + + * procfs statistics: + + initialize all fields to 0 + + subtract guest && guest_nice from user && nice time similar to other + metric tools like htop or telegraf + + add irq/softirq/steal to total used cpu + + use total of all non-idle fields to compute percentage + + -- Proxmox Support Team Thu, 13 Jan 2022 17:13:27 +0100 + +libpve-common-perl (7.0-14) bullseye; urgency=medium + + * schema: rename 'storagepair' format to 'storage-pair' + + * schema: add 'pve-bridge-id' option, format and pair + + * schema: add 'proxmox-remote' format and option + + -- Proxmox Support Team Thu, 11 Nov 2021 12:33:48 +0100 + +libpve-common-perl (7.0-13) bullseye; urgency=medium + + * getxattr: trim the returned buffer to the correct size + + * Ticket: uri-escape colons + + -- Proxmox Support Team Wed, 10 Nov 2021 11:50:51 +0100 + +libpve-common-perl (7.0-12) bullseye; urgency=medium + + * safe_read_from: bump default size limit to 1 MiB to match pmxcfs + + * cgroup: cpu quota: fix resetting period length for v1 + + * cgroup v2: io stats: fix parsing disk writes + + -- Proxmox Support Team Sun, 07 Nov 2021 21:36:08 +0100 + +libpve-common-perl (7.0-11) bullseye; urgency=medium + + * tempfile: improve base path selection, use user-specific rundir if + available, fallback to `/tmp` if that's not the case and the process + doesn't run under the root UID + + * tools: add set/get xattr methods to expose the syscalls with the same name + + -- Proxmox Support Team Tue, 19 Oct 2021 09:35:38 +0200 + +libpve-common-perl (7.0-10) bullseye; urgency=medium + + * net: get local ip: catch any error from get_reachable_networks + + * inotify: network: detect "allow-auto" as "auto" synonym + + * subscription: switch verification domain over to shop.proxmox.com + + * inotify: network: improve "allow-hotplug" & "auto" interaction by mapping + the former to the later (for now). + + -- Proxmox Support Team Wed, 29 Sep 2021 10:01:09 +0200 + +libpve-common-perl (7.0-9) bullseye; urgency=medium + + * fix #2368: network: extend infiniband recognition in regex + + * net: ip from host: avoid using an undefined variable in error message + + * net: add helpers to get all reachable networks + + -- Proxmox Support Team Sat, 18 Sep 2021 14:51:44 +0200 + +libpve-common-perl (7.0-6) bullseye; urgency=medium + + * fix #2831: never set bridge_fd to 0 with STP on + + * ProcFSTools: read_proc_stat: add more cpu stats from /proc/stat + + -- Proxmox Support Team Fri, 6 Aug 2021 13:52:37 +0200 + +libpve-common-perl (7.0-5) bullseye; urgency=medium + + * fix #3527: cgroup: drop file buffers from memory usage + + -- Proxmox Support Team Wed, 14 Jul 2021 11:50:46 +0200 + +libpve-common-perl (7.0-4) bullseye; urgency=medium + + * tools: add upid_normalize_status_type helper + + * JSON schema: add pve-task-status-type format + + * fix #3153: INotify: adding comment of interface to inet6 section when this + is the only section + + -- Proxmox Support Team Mon, 28 Jun 2021 14:57:20 +0200 + +libpve-common-perl (7.0-3) bullseye; urgency=medium + + * SysFSTools: add verbose flag to pci_device_info + + * systemd: allow setting SendSIGKILL and TimeoutStopUSec dbus properties + + -- Proxmox Support Team Wed, 23 Jun 2021 12:07:55 +0200 + +libpve-common-perl (7.0-2) bullseye; urgency=medium + + * inotify: read network interfaces: add vlan-id and vlan-raw-device on dot + notation vlan interfaces + + * network: is_ip_in_cidr: correctly handle the CIDR being a singleton range + (e.g. /32 for IPv4) + + * network: add canonical_ip abd unique_ips helper + + * tools: add download_file_from_url, upid_status_is_error and renameat2 helper + + -- Proxmox Support Team Thu, 17 Jun 2021 16:41:53 +0200 + +libpve-common-perl (7.0-1) bullseye; urgency=medium + + * re-build for Debian 11 Bullseye based releases + + -- Proxmox Support Team Sun, 09 May 2021 17:29:22 +0200 + +libpve-common-perl (6.4-3) pve pmg; urgency=medium + + * daemon: explicitly bind to the general wildcard address and fall back to + the IPv4 one if socket creation fails, as then IPv6 is highly probable + disabled for the setup + + -- Proxmox Support Team Fri, 07 May 2021 16:24:29 +0200 + +libpve-common-perl (6.4-2) pve pmg; urgency=medium + + * INotify: add support for a loopback like "dummy" interfaces type required + for bgp with multipath/ecmp to have a unique src ip + + * REST handler: make potentially resource intensive API return validation + opt-in, enable it only in the CLI handler by default. It was not really + useful anyway, and most of the time we had false positives due to the + schema missing some optional property. + + -- Proxmox Support Team Mon, 26 Apr 2021 19:34:21 +0200 + +libpve-common-perl (6.4-1) pve pmg; urgency=medium + + * cli: get options: don't set optional positional params to `undef` + + * JSONSchema: don't cycle-check 'download' responses + + * daemon: create_reusable_socket: listen on IPv6 and IPv4 + + * PBS client: add file-restore helper + + * allow workers to log and count warnings, providing the WARNING finish-state + for tasks which encounered some non-fatal problems + + -- Proxmox Support Team Fri, 23 Apr 2021 14:59:51 +0200 + +libpve-common-perl (6.3-5) pve pmg; urgency=medium + + * network: get_local_ip_from_cidr: filter to only return unique IPs + + * format: fix render_bytes with CLIFormatter + + -- Proxmox Support Team Tue, 09 Mar 2021 08:35:04 +0100 + +libpve-common-perl (6.3-4) pve pmg; urgency=medium + + * sendmail: use more complete email regex and shellquote + + * register email-or-username format + + * fix #3259: always free certificate file after reading it + + -- Proxmox Support Team Fri, 19 Feb 2021 15:50:16 +0100 + +libpve-common-perl (6.3-3) pve pmg; urgency=medium + + * SectionConfig: parse_config: add errors to result + + * extract PVE::Format from PVE::CLIFormatter for reuse + + * add CGroup CPU/IO/Memory pressure stats helpers + + -- Proxmox Support Team Mon, 08 Feb 2021 16:09:09 +0100 + +libpve-common-perl (6.3-2) pve pmg; urgency=medium + + * PBS client: add helper method to get a repository url easier + + * tools: add extract_sensitive_params + + -- Proxmox Support Team Thu, 03 Dec 2020 16:53:17 +0100 + +libpve-common-perl (6.3-1) pve pmg; urgency=medium + + * subscription: use more specific machine repo definition for Proxmox VE and + Proxmox Mail Gateway, to improve co-installability of all products. + + * network: ignore vlan-id if already specified by "iface.X" notation + + -- Proxmox Support Team Fri, 27 Nov 2020 15:30:18 +0100 + +libpve-common-perl (6.2-6) pve pmg; urgency=medium + + * rest: register method: allow minus in path template parameter names + + -- Proxmox Support Team Tue, 17 Nov 2020 16:07:53 +0100 + +libpve-common-perl (6.2-5) pve pmg; urgency=medium + + * move over CGroup handling code for reuse + + * move over Proxmox Backup Sercer client helper module for reuse + + -- Proxmox Support Team Tue, 17 Nov 2020 14:29:13 +0100 + +libpve-common-perl (6.2-4) pve pmg; urgency=medium + + * fix #3108: properly check IPv6 local address + + * systemd: add helpers for parsing unit files + + * network config parser: allow bond of bond + + * ProcFSTools: add helper methods to read CPU/Memory/IO pressure metrics + + -- Proxmox Support Team Thu, 05 Nov 2020 10:55:57 +0100 + +libpve-common-perl (6.2-3) pve pmg; urgency=medium + + * properly encode CLI tool's output when using YAML output-format via + YAML::XS + + * fix the behavior of the sync_mountpoint helper and improve its error + propagation + + -- Proxmox Support Team Fri, 18 Sep 2020 17:33:56 +0200 + libpve-common-perl (6.2-2) pve pmg; urgency=medium * sendmail helper: only send multipart if necessary diff --git a/debian/compat b/debian/compat deleted file mode 100644 index f599e28..0000000 --- a/debian/compat +++ /dev/null @@ -1 +0,0 @@ -10 diff --git a/debian/control b/debian/control index 4aa95ed..ac4cd66 100644 --- a/debian/control +++ b/debian/control @@ -2,7 +2,8 @@ Source: libpve-common-perl Section: perl Priority: optional Maintainer: Proxmox Support Team -Build-Depends: debhelper (>= 10~), +Build-Depends: debhelper-compat (= 13), + libanyevent-perl, libclone-perl, libdevel-cycle-perl, libfilesys-df-perl, @@ -10,13 +11,17 @@ Build-Depends: debhelper (>= 10~), libjson-perl, liblinux-inotify2-perl, libnet-ip-perl, + libnetaddr-ip-perl, + libproxmox-rs-perl, libstring-shellquote-perl, libtest-mockmodule-perl, -Standards-Version: 3.9.8 + libyaml-libyaml-perl, +Standards-Version: 4.6.2 Package: libpve-common-perl Architecture: all -Depends: libclone-perl, +Depends: libanyevent-perl, + libclone-perl, libcrypt-openssl-random-perl, libcrypt-openssl-rsa-perl, libdevel-cycle-perl, @@ -29,17 +34,21 @@ Depends: libclone-perl, libmime-base32-perl, libnet-dbus-perl, libnet-ip-perl, + libnetaddr-ip-perl, libproxmox-acme-perl, + libproxmox-rs-perl, libstring-shellquote-perl, libtimedate-perl, liburi-perl, libwww-perl, + libyaml-libyaml-perl, ${misc:Depends}, ${perl:Depends}, Breaks: ifupdown2 (<< 2.0.1-1+pve5), - pmg-api (<< 6.1-7), - pve-container (<< 3.0-9), - pve-manager (<< 5.2-5), - qemu-server (<< 5.0-49), + libpve-guest-common-perl (<< 5.0.1), + pmg-api (<< 7.1-5), + pve-container (<< 4.3-1), + pve-manager (<< 7.2-9), + qemu-server (<< 8.0.1), Description: Proxmox VE base library This package contains the base library used by other Proxmox VE components. diff --git a/debian/source/format b/debian/source/format index d3827e7..89ae9db 100644 --- a/debian/source/format +++ b/debian/source/format @@ -1 +1 @@ -1.0 +3.0 (native) diff --git a/src/Makefile b/src/Makefile index 1987d0e..2d8bdc4 100644 --- a/src/Makefile +++ b/src/Makefile @@ -8,36 +8,39 @@ PERLDIR=${PREFIX}/share/perl5 LIB_SOURCES = \ AtomicFile.pm \ - Certificate.pm \ + CGroup.pm \ CLIFormatter.pm \ CLIHandler.pm \ CalendarEvent.pm \ + Certificate.pm \ CpuSet.pm \ Daemon.pm \ Exception.pm \ + Format.pm \ INotify.pm \ JSONSchema.pm \ + Job/Registry.pm \ LDAP.pm \ Network.pm \ OTP.pm \ + PBSClient.pm \ PTY.pm \ ProcFSTools.pm \ RESTEnvironment.pm \ RESTHandler.pm \ SafeSyslog.pm \ SectionConfig.pm \ - Subscription.pm \ - Syscall.pm \ SysFSTools.pm \ + Syscall.pm \ Systemd.pm \ Ticket.pm \ Tools.pm all: -.PHONY: install -install: +install: $(addprefix PVE/,${LIB_SOURCES}) install -d -m 0755 ${DESTDIR}${PERLDIR}/PVE + install -d -m 0755 ${DESTDIR}${PERLDIR}/PVE/Job for i in ${LIB_SOURCES}; do install -D -m 0644 PVE/$$i ${DESTDIR}${PERLDIR}/PVE/$$i; done diff --git a/src/PVE/CGroup.pm b/src/PVE/CGroup.pm new file mode 100644 index 0000000..e2839cf --- /dev/null +++ b/src/PVE/CGroup.pm @@ -0,0 +1,615 @@ +# cgroup handler +# +# This package should deal with figuring out the right cgroup path for a +# container (via the command socket), reading and writing cgroup values, and +# handling cgroup v1 & v2 differences. +# +# Note that the long term plan is to have resource manage functions instead of +# dealing with cgroup files on the outside. + +package PVE::CGroup; + +use strict; +use warnings; + +use IO::File; +use IO::Select; +use POSIX qw(); + +use PVE::ProcFSTools; +use PVE::Tools qw( + file_get_contents + file_read_firstline +); + +# We don't want to do a command socket round trip for every cgroup read/write, +# so any cgroup function needs to have the container's path cached, so this +# package has to be instantiated. +# +# LXC keeps separate paths by controller (although they're normally all the +# same, in our # case anyway), so we cache them by controller as well. +sub new { + my ($class, $vmid) = @_; + + my $self = { vmid => $vmid }; + + return bless $self, $class; +} + +# Get the v1 controller list. +# +# Returns a set (hash mapping names to `1`) of cgroupv1 controllers, and an +# optional boolean whether a unified (cgroupv2) hierarchy exists. +my sub get_v1_controllers { + my $v1 = {}; + my $v2 = 0; + my $data = PVE::Tools::file_get_contents('/proc/self/cgroup'); + while ($data =~ /^\d+:([^:\n]*):.*$/gm) { + my $type = $1; + if (length($type)) { + $v1->{$_} = 1 foreach split(/,/, $type); + } else { + $v2 = 1; + } + } + return wantarray ? ($v1, $v2) : $v1; +} + +# Get the set v2 controller list from the `cgroup.controllers` file. +my sub get_v2_controllers { + my $v2 = eval { file_get_contents('/sys/fs/cgroup/cgroup.controllers') } + || eval { file_get_contents('/sys/fs/cgroup/unified/cgroup.controllers') }; + return undef if !defined $v2; + + # It's a simple space separated list: + return { map { $_ => 1 } split(/\s+/, $v2) }; +} + +my $CGROUP_CONTROLLERS = undef; +# Get a list of controllers enabled in each cgroup subsystem. +# +# This is a more complete version of `PVE::LXC::get_cgroup_subsystems`. +# +# Returns 2 sets (hashes mapping controller names to `1`), one for each cgroup +# version. +sub get_cgroup_controllers() { + if (!defined($CGROUP_CONTROLLERS)) { + my ($v1, undef) = get_v1_controllers(); + my $v2 = get_v2_controllers(); + + $CGROUP_CONTROLLERS = [$v1, $v2]; + } + + return $CGROUP_CONTROLLERS->@*; +} + +my $CGROUP_MODE = undef; +# Figure out which cgroup mode we're operating under: +# +# For this we check the file system type of `/sys/fs/cgroup` as it may well be possible that some +# additional cgroupv1 mount points have been created by tools such as `systemd-nspawn`, or +# manually. +# +# Returns 1 for what we consider the hybrid layout, 2 for what we consider the unified layout. +# +# NOTE: To fully support a hybrid layout it is better to use functions like +# `cpuset_controller_path` and not rely on this value for anything involving paths. +# +# This is a function, not a method! +sub cgroup_mode() { + if (!defined($CGROUP_MODE)) { + my $mounts = PVE::ProcFSTools::parse_proc_mounts(); + for my $entry (@$mounts) { + my ($what, $dir, $fstype, $opts) = @$entry; + if ($dir eq '/sys/fs/cgroup') { + if ($fstype eq 'cgroup2') { + $CGROUP_MODE = 2; + last; + } else { + $CGROUP_MODE = 1; + last; + } + } + } + } + + die "unknown cgroup mode\n" if !defined($CGROUP_MODE); + return $CGROUP_MODE; +} + +my $CGROUPV2_PATH = undef; +sub cgroupv2_base_path() { + if (!defined($CGROUPV2_PATH)) { + if (cgroup_mode() == 2) { + $CGROUPV2_PATH = '/sys/fs/cgroup'; + } else { + $CGROUPV2_PATH = '/sys/fs/cgroup/unified'; + } + } + return $CGROUPV2_PATH; +} + +# Find a cgroup controller and return its path and version. +# +# LXC initializes the unified hierarchy first, so if a controller is +# available via both we favor cgroupv2 here as well. +# +# Returns nothing if the controller is not available. + +sub find_cgroup_controller($) { + my ($controller) = @_; + + my ($v1, $v2) = get_cgroup_controllers(); + + if (!defined($controller) || $v2->{$controller}) { + my $path = cgroupv2_base_path(); + return wantarray ? ($path, 2) : $path; + } + + if (defined($controller) && $v1->{$controller}) { + my $path = "/sys/fs/cgroup/$controller"; + return wantarray ? ($path, 1) : $path; + } + + return; +} + +my $CG_PATH_CPUSET = undef; +my $CG_VER_CPUSET = undef; +# Find the cpuset cgroup controller. +# +# This is a function, not a method! +sub cpuset_controller_path() { + if (!defined($CG_PATH_CPUSET)) { + ($CG_PATH_CPUSET, $CG_VER_CPUSET) = find_cgroup_controller('cpuset') + or die "failed to find cpuset controller\n"; + } + + return wantarray ? ($CG_PATH_CPUSET, $CG_VER_CPUSET) : $CG_PATH_CPUSET; +} + +# Get a subdirectory (without the cgroup mount point) for a controller. +sub get_subdir { + my ($self, $controller, $limiting) = @_; + + die "implement in subclass"; +} + +# Get path and version for a controller. +# +# `$controller` may be `undef`, see get_subdir above for details. +# +# Returns either just the path, or the path and cgroup version as a tuple. +sub get_path { + my ($self, $controller, $limiting) = @_; + # Find the controller before querying the lxc monitor via a socket: + my ($cgpath, $ver) = find_cgroup_controller($controller) + or return undef; + + my $path = $self->get_subdir($controller, $limiting) + or return undef; + + $path = "$cgpath/$path"; + return wantarray ? ($path, $ver) : $path; +} + +# Convenience method to get the path info if the first existing controller. +# +# Returns the same as `get_path`. +sub get_any_path { + my ($self, $limiting, @controllers) = @_; + + my ($path, $ver); + for my $c (@controllers) { + ($path, $ver) = $self->get_path($c, $limiting); + last if defined $path; + } + return wantarray ? ($path, $ver) : $path; +} + +# Parse a 'Nested keyed' file: +# +# See kernel documentation `admin-guide/cgroup-v2.rst` 4.1. +my sub parse_nested_keyed_file($) { + my ($data) = @_; + my $res = {}; + foreach my $line (split(/\n/, $data)) { + my ($key, @values) = split(/\s+/, $line); + + my $d = ($res->{$key} = {}); + + foreach my $value (@values) { + if (my ($key, $value) = ($value =~ /^([^=]+)=(.*)$/)) { + $d->{$key} = $value; + } else { + warn "bad key=value pair in nested keyed file\n"; + } + } + } + return $res; +} + +# Parse a 'Flat keyed' file: +# +# See kernel documentation `admin-guide/cgroup-v2.rst` 4.1. +my sub parse_flat_keyed_file($) { + my ($data) = @_; + my $res = {}; + foreach my $line (split(/\n/, $data)) { + if (my ($key, $value) = ($line =~ /^(\S+)\s+(.*)$/)) { + $res->{$key} = $value; + } else { + warn "bad 'key value' pair in flat keyed file\n"; + } + } + return $res; +} + +# Parse out 'diskread' and 'diskwrite' values from I/O stats for this container. +sub get_io_stats { + my ($self) = @_; + + my $res = { + diskread => 0, + diskwrite => 0, + }; + + # With cgroupv1 we have a 'blkio' controller, with cgroupv2 it's just 'io': + my ($path, $ver) = $self->get_any_path(1, 'io', 'blkio'); + if (!defined($path)) { + # container not running + return undef; + } elsif ($ver == 2) { + # cgroupv2 environment, io controller enabled + my $io_stat = file_get_contents("$path/io.stat"); + + my $data = parse_nested_keyed_file($io_stat); + foreach my $dev (keys %$data) { + my $dev = $data->{$dev}; + if (my $b = $dev->{rbytes}) { + $res->{diskread} += $b; + } + if (my $b = $dev->{wbytes}) { + $res->{diskwrite} += $b; + } + } + + return $res; + } elsif ($ver == 1) { + # cgroupv1 environment: + my $io = file_get_contents("$path/blkio.throttle.io_service_bytes_recursive"); + foreach my $line (split(/\n/, $io)) { + if (my ($type, $bytes) = ($line =~ /^\d+:\d+\s+(Read|Write)\s+(\d+)$/)) { + $res->{diskread} += $bytes if $type eq 'Read'; + $res->{diskwrite} += $bytes if $type eq 'Write'; + } + } + + return $res; + } else { + die "bad cgroup version: $ver\n"; + } + + # container not running + return undef; +} + +# Read utime and stime for this container from the cpuacct cgroup. +# Values are in milliseconds! +sub get_cpu_stat { + my ($self) = @_; + + my $res = { + utime => 0, + stime => 0, + }; + + my ($path, $ver) = $self->get_any_path(1, 'cpuacct', 'cpu'); + if (!defined($path)) { + # container not running + return undef; + } elsif ($ver == 2) { + my $data = eval { file_get_contents("$path/cpu.stat") }; + + # or no io controller available: + return undef if !defined($data); + + $data = parse_flat_keyed_file($data); + $res->{utime} = int($data->{user_usec} / 1000); + $res->{stime} = int($data->{system_usec} / 1000); + } elsif ($ver == 1) { + # cgroupv1 environment: + my $clock_ticks = POSIX::sysconf(&POSIX::_SC_CLK_TCK); + my $clk_to_usec = 1000 / $clock_ticks; + + my $data = parse_flat_keyed_file(file_get_contents("$path/cpuacct.stat")); + $res->{utime} = int($data->{user} * $clk_to_usec); + $res->{stime} = int($data->{system} * $clk_to_usec); + } else { + die "bad cgroup version: $ver\n"; + } + + return $res; +} + +# Parse some memory data from `memory.stat` +sub get_memory_stat { + my ($self) = @_; + + my $res = { + mem => 0, + swap => 0, + }; + + my ($path, $ver) = $self->get_path('memory', 1); + if (!defined($path)) { + # container most likely isn't running + return undef; + } elsif ($ver == 2) { + my $mem = file_get_contents("$path/memory.current"); + my $swap = file_get_contents("$path/memory.swap.current"); + my $stat = parse_flat_keyed_file(file_get_contents("$path/memory.stat")); + + chomp ($mem, $swap); + + $res->{mem} = $mem - $stat->{file}; + $res->{swap} = $swap; + } elsif ($ver == 1) { + # cgroupv1 environment: + my $stat = parse_flat_keyed_file(file_get_contents("$path/memory.stat")); + my $mem = file_get_contents("$path/memory.usage_in_bytes"); + my $memsw = file_get_contents("$path/memory.memsw.usage_in_bytes"); + chomp ($mem, $memsw); + + $res->{mem} = $mem - $stat->{total_cache}; + $res->{swap} = $memsw - $mem; + } else { + die "bad cgroup version: $ver\n"; + } + + return $res; +} + +sub get_pressure_stat { + my ($self) = @_; + + my $res = { + cpu => { + some => { avg10 => 0, avg60 => 0, avg300 => 0 } + }, + memory => { + some => { avg10 => 0, avg60 => 0, avg300 => 0 }, + full => { avg10 => 0, avg60 => 0, avg300 => 0 } + }, + io => { + some => { avg10 => 0, avg60 => 0, avg300 => 0 }, + full => { avg10 => 0, avg60 => 0, avg300 => 0 } + }, + }; + + my ($path, $version) = $self->get_path(undef, 1); + if (!defined($path)) { + return $res; # container or VM most likely isn't running, retrun zero stats + } elsif ($version == 1) { + return undef; # v1 controller does not provides pressure stat + } elsif ($version == 2) { + for my $type (qw(cpu memory io)) { + my $stats = PVE::ProcFSTools::parse_pressure("$path/$type.pressure"); + $res->{$type} = $stats if $stats; + } + } else { + die "bad cgroup version: $version\n"; + } + + return $res; +} + +# Change the memory limit for this container. +# +# Dies on error (including a not-running or currently-shutting-down guest). +sub change_memory_limit { + my ($self, $mem_bytes, $swap_bytes, $mem_high_bytes) = @_; + + my ($path, $ver) = $self->get_path('memory', 1); + if (!defined($path)) { + die "trying to change memory cgroup values: container not running\n"; + } elsif ($ver == 2) { + PVE::ProcFSTools::write_proc_entry("$path/memory.swap.max", $swap_bytes) + if defined($swap_bytes); + if (defined($mem_bytes)) { + # 'max' is the hard-limit (triggers OOM), while 'high' throttles & adds reclaim pressure + PVE::ProcFSTools::write_proc_entry("$path/memory.high", $mem_high_bytes // 'max'); + PVE::ProcFSTools::write_proc_entry("$path/memory.max", $mem_bytes); + } + } elsif ($ver == 1) { + # With cgroupv1 we cannot control memory and swap limits separately. + # This also means that since the two values aren't independent, we need to handle + # growing and shrinking separately. + my $path_mem = "$path/memory.limit_in_bytes"; + my $path_memsw = "$path/memory.memsw.limit_in_bytes"; + + my $old_mem_bytes = file_get_contents($path_mem); + my $old_memsw_bytes = file_get_contents($path_memsw); + chomp($old_mem_bytes, $old_memsw_bytes); + + $mem_bytes //= $old_mem_bytes; + $swap_bytes //= $old_memsw_bytes - $old_mem_bytes; + my $memsw_bytes = $mem_bytes + $swap_bytes; + + if ($memsw_bytes > $old_memsw_bytes) { + # Growing the limit means growing the combined limit first, then pulling the + # memory limitup. + PVE::ProcFSTools::write_proc_entry($path_memsw, $memsw_bytes); + PVE::ProcFSTools::write_proc_entry($path_mem, $mem_bytes); + } else { + # Shrinking means we first need to shrink the mem-only memsw cannot be + # shrunk below it. + PVE::ProcFSTools::write_proc_entry($path_mem, $mem_bytes); + PVE::ProcFSTools::write_proc_entry($path_memsw, $memsw_bytes); + } + } else { + die "bad cgroup version: $ver\n"; + } + + # return a truth value + return 1; +} + +# Change the cpu quota for a container. +# +# Dies on error (including a not-running or currently-shutting-down guest). +sub change_cpu_quota { + my ($self, $quota, $period) = @_; + + die "quota without period not allowed\n" if !defined($period) && defined($quota); + + my ($path, $ver) = $self->get_path('cpu', 1); + if (!defined($path)) { + die "trying to change cpu quota cgroup values: container not running\n"; + } elsif ($ver == 2) { + # cgroupv2 environment, an undefined (unlimited) quota is defined as "max" + # in this interface: + $quota //= 'max'; # unlimited + if (defined($quota)) { + PVE::ProcFSTools::write_proc_entry("$path/cpu.max", "$quota $period"); + } else { + # we're allowed to only write the quota: + PVE::ProcFSTools::write_proc_entry("$path/cpu.max", 'max'); + } + } elsif ($ver == 1) { + $quota //= -1; # default (unlimited) + $period //= 100_000; # default (100 ms) + PVE::ProcFSTools::write_proc_entry("$path/cpu.cfs_period_us", $period); + PVE::ProcFSTools::write_proc_entry("$path/cpu.cfs_quota_us", $quota); + } else { + die "bad cgroup version: $ver\n"; + } + + # return a truth value + return 1; +} + +# Clamp an integer to the supported range of CPU shares from the booted CGroup version +# +# Returns the default if called with an undefined value. +sub clamp_cpu_shares { + my ($shares) = @_; + + my $is_cgroupv2 = cgroup_mode() == 2; + + return $is_cgroupv2 ? 100 : 1024 if !defined($shares); + + if ($is_cgroupv2) { + $shares = 10000 if $shares >= 10000; # v1 can be higher, so clamp v2 there + } else { + $shares = 2 if $shares < 2; # v2 can be lower, so clamp v1 there + } + return $shares; +} + +# Change the cpu "shares" for a container. +# +# In cgroupv1 we used a value in `[0..500000]` with a default of 1024. +# +# In cgroupv2 we do not have "shares", we have "weights" in the range +# of `[1..10000]` with a default of 100. +# +# Since the default values don't match when scaling linearly, we use the +# values we get as-is and simply error for values >10000 in cgroupv2. +# +# It is left to the user to figure this out for now. +# +# Dies on error (including a not-running or currently-shutting-down guest). +# +# NOTE: if you add a new param during 7.x you need to break older pve-container/qemu-server versions +# that previously passed a `$cgroupv1_default`, which got removed due to being ignored anyway. +# otherwise you risk that a old module bogusly passes some cgroup default as your new param. +sub change_cpu_shares { + my ($self, $shares) = @_; + + my ($path, $ver) = $self->get_path('cpu', 1); + if (!defined($path)) { + die "trying to change cpu shares/weight cgroup values: container not running\n"; + } elsif ($ver == 2) { + # the cgroupv2 documentation defines the default to 100 + $shares //= 100; + die "cpu weight (shares) must be in range [1, 10000]\n" if $shares < 1 || $shares > 10000; + PVE::ProcFSTools::write_proc_entry("$path/cpu.weight", $shares); + } elsif ($ver == 1) { + $shares //= 1024; + PVE::ProcFSTools::write_proc_entry("$path/cpu.shares", $shares); + } else { + die "bad cgroup version: $ver\n"; + } + + # return a truth value + return 1; +} + +my sub v1_freeze_thaw { + my ($self, $controller_path, $freeze) = @_; + my $path = $self->get_subdir('freezer', 1) + or die "trying to freeze container: container not running\n"; + $path = "$controller_path/$path/freezer.state"; + + my $data = $freeze ? 'FROZEN' : 'THAWED'; + PVE::ProcFSTools::write_proc_entry($path, $data); + + # Here we just poll the freezer.state once per second. + while (1) { + my $state = file_get_contents($path); + chomp $state; + last if $state eq $data; + } +} + +my sub v2_freeze_thaw { + my ($self, $controller_path, $freeze) = @_; + my $path = $self->get_subdir(undef, 1) + or die "trying to freeze container: container not running\n"; + $path = "$controller_path/$path"; + + my $desired_state = $freeze ? 1 : 0; + + # cgroupv2 supports poll events on cgroup.events which contains the frozen + # state. + my $fh = IO::File->new("$path/cgroup.events", 'r') + or die "failed to open $path/cgroup.events file: $!\n"; + my $select = IO::Select->new(); + $select->add($fh); + + PVE::ProcFSTools::write_proc_entry("$path/cgroup.freeze", $desired_state); + while (1) { + my $data = do { + local $/ = undef; + <$fh> + }; + $data = parse_flat_keyed_file($data); + last if $data->{frozen} == $desired_state; + my @handles = $select->has_exception(); + next if !@handles; + seek($fh, 0, 0) + or die "failed to rewind cgroup.events file: $!\n"; + } +} + +# Freeze or unfreeze a container. +# +# This will freeze the container at its outer (limiting) cgroup path. We use +# this instead of `lxc-freeze` as `lxc-freeze` from lxc4 will not be able to +# fetch the cgroup path from contaienrs still running on lxc3. +sub freeze_thaw { + my ($self, $freeze) = @_; + + my $controller_path = find_cgroup_controller('freezer'); + if (defined($controller_path)) { + return v1_freeze_thaw($self, $controller_path, $freeze); + } else { + # cgroupv2 always has a freezer, there can be both cgv1 and cgv2 + # freezers, but we'll prefer v1 when it's available as that's what lxc + # does as well... + return v2_freeze_thaw($self, cgroupv2_base_path(), $freeze); + } +} + +1; diff --git a/src/PVE/CLIFormatter.pm b/src/PVE/CLIFormatter.pm index 4f18fa9..6977fd9 100644 --- a/src/PVE/CLIFormatter.pm +++ b/src/PVE/CLIFormatter.pm @@ -4,90 +4,27 @@ use strict; use warnings; use I18N::Langinfo; -use POSIX qw(strftime); -use CPAN::Meta::YAML; # comes with perl-modules +use YAML::XS; # supports Dumping JSON::PP::Boolean +$YAML::XS::Boolean = "JSON::PP"; use PVE::JSONSchema; use PVE::PTY; +use PVE::Format; use JSON; use utf8; use Encode; -sub render_timestamp { - my ($epoch) = @_; - - # ISO 8601 date format - return strftime("%F %H:%M:%S", localtime($epoch)); -} - -PVE::JSONSchema::register_renderer('timestamp', \&render_timestamp); - -sub render_timestamp_gmt { - my ($epoch) = @_; - - # ISO 8601 date format, standard Greenwich time zone - return strftime("%F %H:%M:%S", gmtime($epoch)); -} - -PVE::JSONSchema::register_renderer('timestamp_gmt', \&render_timestamp_gmt); - -sub render_duration { - my ($duration_in_seconds) = @_; - - my $text = ''; - my $rest = $duration_in_seconds; - - my $step = sub { - my ($unit, $unitlength) = @_; - - if ((my $v = int($rest/$unitlength)) > 0) { - $text .= " " if length($text); - $text .= "${v}${unit}"; - $rest -= $v * $unitlength; - } - }; - - $step->('w', 7*24*3600); - $step->('d', 24*3600); - $step->('h', 3600); - $step->('m', 60); - $step->('s', 1); - - return $text; -} - -PVE::JSONSchema::register_renderer('duration', \&render_duration); - -sub render_fraction_as_percentage { - my ($fraction) = @_; - - return sprintf("%.2f%%", $fraction*100); -} - -PVE::JSONSchema::register_renderer( - 'fraction_as_percentage', \&render_fraction_as_percentage); - -sub render_bytes { - my ($value) = @_; - - my @units = qw(B KiB MiB GiB TiB PiB); - - my $max_unit = 0; - if ($value > 1023) { - $max_unit = int(log($value)/log(1024)); - $value /= 1024**($max_unit); - } - my $unit = $units[$max_unit]; - return sprintf "%.2f $unit", $value; -} - -PVE::JSONSchema::register_renderer('bytes', \&render_bytes); +PVE::JSONSchema::register_renderer('timestamp', \&PVE::Format::render_timestamp); +PVE::JSONSchema::register_renderer('timestamp_gmt', \&PVE::Format::render_timestamp_gmt); +PVE::JSONSchema::register_renderer('duration', \&PVE::Format::render_duration); +PVE::JSONSchema::register_renderer('fraction_as_percentage', \&PVE::Format::render_fraction_as_percentage); +PVE::JSONSchema::register_renderer('bytes', \&PVE::Format::render_bytes); sub render_yaml { my ($value) = @_; - my $data = CPAN::Meta::YAML::Dump($value); + my $data = YAML::XS::Dump($value); $data =~ s/^---[\n\s]//; # remove yaml marker return $data; @@ -162,8 +99,8 @@ sub print_text_table { $terminal_opts //= query_terminal_options({}); my $sort_key = $options->{sort_key}; - my $border = !$options->{noborder}; - my $header = !$options->{noheader}; + my $show_border = !$options->{noborder}; + my $show_header = !$options->{noheader}; my $columns = $terminal_opts->{columns}; my $utf8 = $terminal_opts->{utf8}; @@ -186,10 +123,7 @@ sub print_text_table { my $colopts = {}; - my $borderstring_m = ''; - my $borderstring_b = ''; - my $borderstring_t = ''; - my $borderstring_h = ''; + my $border = { m => '', b => '', t => '', h => '' }; my $formatstring = ''; my $column_count = scalar(@$props_to_print); @@ -254,54 +188,54 @@ sub print_text_table { cutoff => $cutoff, }; - if ($border) { + if ($show_border) { if ($i == 0 && ($column_count == 1)) { if ($utf8) { $formatstring .= "│ %$alignstr${cutoff}s │"; - $borderstring_t .= "┌─" . ('─' x $cutoff) . "─┐"; - $borderstring_h .= "╞═" . ('═' x $cutoff) . '═╡'; - $borderstring_m .= "├─" . ('─' x $cutoff) . "─┤"; - $borderstring_b .= "└─" . ('─' x $cutoff) . "─┘"; + $border->{t} .= "┌─" . ('─' x $cutoff) . "─┐"; + $border->{h} .= "╞═" . ('═' x $cutoff) . '═╡'; + $border->{m} .= "├─" . ('─' x $cutoff) . "─┤"; + $border->{b} .= "└─" . ('─' x $cutoff) . "─┘"; } else { $formatstring .= "| %$alignstr${cutoff}s |"; - $borderstring_m .= "+-" . ('-' x $cutoff) . "-+"; - $borderstring_h .= "+=" . ('=' x $cutoff) . '='; + $border->{m} .= "+-" . ('-' x $cutoff) . "-+"; + $border->{h} .= "+=" . ('=' x $cutoff) . '='; } } elsif ($i == 0) { if ($utf8) { $formatstring .= "│ %$alignstr${cutoff}s "; - $borderstring_t .= "┌─" . ('─' x $cutoff) . '─'; - $borderstring_h .= "╞═" . ('═' x $cutoff) . '═'; - $borderstring_m .= "├─" . ('─' x $cutoff) . '─'; - $borderstring_b .= "└─" . ('─' x $cutoff) . '─'; + $border->{t} .= "┌─" . ('─' x $cutoff) . '─'; + $border->{h} .= "╞═" . ('═' x $cutoff) . '═'; + $border->{m} .= "├─" . ('─' x $cutoff) . '─'; + $border->{b} .= "└─" . ('─' x $cutoff) . '─'; } else { $formatstring .= "| %$alignstr${cutoff}s "; - $borderstring_m .= "+-" . ('-' x $cutoff) . '-'; - $borderstring_h .= "+=" . ('=' x $cutoff) . '='; + $border->{m} .= "+-" . ('-' x $cutoff) . '-'; + $border->{h} .= "+=" . ('=' x $cutoff) . '='; } } elsif ($i == ($column_count - 1)) { if ($utf8) { $formatstring .= "│ %$alignstr${cutoff}s │"; - $borderstring_t .= "┬─" . ('─' x $cutoff) . "─┐"; - $borderstring_h .= "╪═" . ('═' x $cutoff) . '═╡'; - $borderstring_m .= "┼─" . ('─' x $cutoff) . "─┤"; - $borderstring_b .= "┴─" . ('─' x $cutoff) . "─┘"; + $border->{t} .= "┬─" . ('─' x $cutoff) . "─┐"; + $border->{h} .= "╪═" . ('═' x $cutoff) . '═╡'; + $border->{m} .= "┼─" . ('─' x $cutoff) . "─┤"; + $border->{b} .= "┴─" . ('─' x $cutoff) . "─┘"; } else { $formatstring .= "| %$alignstr${cutoff}s |"; - $borderstring_m .= "+-" . ('-' x $cutoff) . "-+"; - $borderstring_h .= "+=" . ('=' x $cutoff) . "=+"; + $border->{m} .= "+-" . ('-' x $cutoff) . "-+"; + $border->{h} .= "+=" . ('=' x $cutoff) . "=+"; } } else { if ($utf8) { $formatstring .= "│ %$alignstr${cutoff}s "; - $borderstring_t .= "┬─" . ('─' x $cutoff) . '─'; - $borderstring_h .= "╪═" . ('═' x $cutoff) . '═'; - $borderstring_m .= "┼─" . ('─' x $cutoff) . '─'; - $borderstring_b .= "┴─" . ('─' x $cutoff) . '─'; + $border->{t} .= "┬─" . ('─' x $cutoff) . '─'; + $border->{h} .= "╪═" . ('═' x $cutoff) . '═'; + $border->{m} .= "┼─" . ('─' x $cutoff) . '─'; + $border->{b} .= "┴─" . ('─' x $cutoff) . '─'; } else { $formatstring .= "| %$alignstr${cutoff}s "; - $borderstring_m .= "+-" . ('-' x $cutoff) . '-'; - $borderstring_h .= "+=" . ('=' x $cutoff) . '='; + $border->{m} .= "+-" . ('-' x $cutoff) . '-'; + $border->{h} .= "+=" . ('=' x $cutoff) . '='; } } } else { @@ -310,8 +244,8 @@ sub print_text_table { } } - $borderstring_t = $borderstring_m if !length($borderstring_t); - $borderstring_b = $borderstring_m if !length($borderstring_b); + $border->{t} = $border->{m} if !length($border->{t}); + $border->{b} = $border->{m} if !length($border->{b}); my $writeln = sub { my ($text) = @_; @@ -323,27 +257,25 @@ sub print_text_table { } }; - $writeln->($borderstring_t) if $border; + $writeln->($border->{t}) if $show_border; - my $borderstring_sep; - if ($header) { + if ($show_header) { my $text = sprintf $formatstring, map { $colopts->{$_}->{title} } @$props_to_print; $writeln->($text); - $borderstring_sep = $borderstring_h; + $border->{sep} = $border->{h}; } else { - $borderstring_sep = $borderstring_m; + $border->{sep} = $border->{m}; } for (my $i = 0; $i < scalar(@$tabledata); $i++) { my $coldata = $tabledata->[$i]; - if ($border && ($i != 0 || $header)) { - $writeln->($borderstring_sep); - $borderstring_sep = $borderstring_m; + if ($show_border && ($i != 0 || $show_header)) { + $writeln->($border->{sep}); + $border->{sep} = $border->{m}; } for (my $i = 0; $i < $coldata->{height}; $i++) { - my $text = sprintf $formatstring, map { substr($coldata->{rowdata}->{$_}->{lines}->[$i] // '', 0, $colopts->{$_}->{cutoff}); } @$props_to_print; @@ -352,7 +284,7 @@ sub print_text_table { } } - $writeln->($borderstring_b) if $border; + $writeln->($border->{b}) if $show_border; } sub extract_properties_to_print { @@ -440,7 +372,7 @@ sub print_api_result { } if ($format eq 'yaml') { - print encode('UTF-8', CPAN::Meta::YAML::Dump($data)); + print encode('UTF-8', YAML::XS::Dump($data)); } elsif ($format eq 'json') { # Note: we always use utf8 encoding for json format print to_json($data, {utf8 => 1, allow_nonref => 1, canonical => 1 }) . "\n"; @@ -462,7 +394,12 @@ sub print_api_result { my $schema = { type => 'array', items => { type => 'object' }}; print_api_list($kvstore, $schema, ['key', 'value'], $options, $terminal_opts); } elsif ($type eq 'array') { - return if !scalar(@$data); + if (ref($data) eq 'ARRAY') { + return if !scalar(@$data); + } elsif (ref($data) eq 'HASH') { + return if !scalar($data->%*); + die "got hash object, but result schema specified array!\n" + } my $item_type = $result_schema->{items}->{type}; if ($item_type eq 'object') { print_api_list($data, $result_schema, $props_to_print, $options, $terminal_opts); diff --git a/src/PVE/CLIHandler.pm b/src/PVE/CLIHandler.pm index 9955d77..bb97a7d 100644 --- a/src/PVE/CLIHandler.pm +++ b/src/PVE/CLIHandler.pm @@ -208,15 +208,16 @@ sub generate_usage_str { my $str = ''; if (ref($def) eq 'HASH') { my $oldclass = undef; - foreach my $cmd (&$sortfunc($def)) { + foreach my $cmd ($sortfunc->($def)) { if (ref($def->{$cmd}) eq 'ARRAY') { my ($class, $name, $arg_param, $fixed_param, undef, $formatter_properties) = @{$def->{$cmd}}; $str .= $separator if $oldclass && $oldclass ne $class; $str .= $indent; - $str .= $class->usage_str($name, "$prefix $cmd", $arg_param, - $fixed_param, $format, $param_cb, $formatter_properties); + $str .= $class->usage_str( + $name, "$prefix $cmd", $arg_param, $fixed_param, $format, $param_cb, $formatter_properties); + $oldclass = $class; } elsif (defined($def->{$cmd}->{alias}) && ($format eq 'asciidoc')) { @@ -350,7 +351,7 @@ sub print_usage_short { print {$fd} generate_usage_str('short', $cmd, ' ' x 7, $cmd ? '' : "\n", sub { my ($h) = @_; - return sort { + my @sorted_commands = sort { if (ref($h->{$a}) eq 'ARRAY' && ref($h->{$b}) eq 'ARRAY') { # $a and $b are both real commands order them by their class return $h->{$a}->[0] cmp $h->{$b}->[0] || $a cmp $b; @@ -362,6 +363,7 @@ sub print_usage_short { return $a cmp $b; } } keys %$h; + return @sorted_commands; }); } @@ -431,7 +433,7 @@ my $print_bash_completion = sub { my $res = $d->{completion}->($cmd, $pname, $cur, $args); &$print_result(@$res); } - } elsif ($d->{type} eq 'boolean') { + } elsif ($d->{type} && $d->{type} eq 'boolean') { &$print_result('0', '1'); } elsif ($d->{enum}) { &$print_result(@{$d->{enum}}); @@ -537,11 +539,12 @@ sub generate_asciidoc_synopsis { $exename = &$get_exe_name($class); - no strict 'refs'; - my $def = ${"${class}::cmddef"}; - $cmddef = $def; + { + no strict 'refs'; ## no critic (ProhibitNoStrict) + $cmddef = ${"${class}::cmddef"}; + } - if (ref($def) eq 'ARRAY') { + if (ref($cmddef) eq 'ARRAY') { print_simple_asciidoc_synopsis(); } else { $cmddef->{help} = [ __PACKAGE__, 'help', ['cmd'] ]; @@ -659,8 +662,10 @@ sub run_cli_handler { my $logid = $ENV{PVE_LOG_ID} || $exename; initlog($logid); - no strict 'refs'; - $cmddef = ${"${class}::cmddef"}; + { + no strict 'refs'; ## no critic (ProhibitNoStrict) + $cmddef = ${"${class}::cmddef"}; + } if (ref($cmddef) eq 'ARRAY') { $handle_simple_cmd->(\@ARGV, $preparefunc, $param_cb); diff --git a/src/PVE/CalendarEvent.pm b/src/PVE/CalendarEvent.pm index 56e9923..2ca5df1 100644 --- a/src/PVE/CalendarEvent.pm +++ b/src/PVE/CalendarEvent.pm @@ -6,6 +6,7 @@ use Data::Dumper; use Time::Local; use PVE::JSONSchema; use PVE::Tools qw(trim); +use Proxmox::RS::CalendarEvent; # Note: This class implements a parser/utils for systemd like calendar exents # Date specification is currently not implemented @@ -43,259 +44,13 @@ sub parse_calendar_event { die "unable to parse calendar event - event is empty\n"; } - my $parse_single_timespec = sub { - my ($p, $max, $matchall_ref, $res_hash) = @_; - - if ($p =~ m/^((?:\*|[0-9]+))(?:\/([1-9][0-9]*))?$/) { - my ($start, $repetition) = ($1, $2); - if (defined($repetition)) { - $repetition = int($repetition); - $start = $start eq '*' ? 0 : int($start); - die "value '$start' out of range\n" if $start >= $max; - die "repetition '$repetition' out of range\n" if $repetition >= $max; - while ($start < $max) { - $res_hash->{$start} = 1; - $start += $repetition; - } - } else { - if ($start eq '*') { - $$matchall_ref = 1; - } else { - $start = int($start); - die "value '$start' out of range\n" if $start >= $max; - $res_hash->{$start} = 1; - } - } - } elsif ($p =~ m/^([0-9]+)\.\.([1-9][0-9]*)$/) { - my ($start, $end) = (int($1), int($2)); - die "range start '$start' out of range\n" if $start >= $max; - die "range end '$end' out of range\n" if $end >= $max || $end < $start; - for (my $i = $start; $i <= $end; $i++) { - $res_hash->{$i} = 1; - } - } else { - die "unable to parse calendar event '$p'\n"; - } - }; - - my $h = undef; - my $m = undef; - - my $matchall_minutes = 0; - my $matchall_hours = 0; - my $minutes_hash = {}; - my $hours_hash = {}; - - my $dowsel = join('|', keys %$dow_names); - - my $dow_hash; - - my $parse_dowspec = sub { - my ($p) = @_; - - if ($p =~ m/^($dowsel)$/i) { - $dow_hash->{$dow_names->{lc($1)}} = 1; - } elsif ($p =~ m/^($dowsel)\.\.($dowsel)$/i) { - my $start = $dow_names->{lc($1)}; - my $end = $dow_names->{lc($2)} || 7; - die "wrong order in range '$p'\n" if $end < $start; - for (my $i = $start; $i <= $end; $i++) { - $dow_hash->{($i % 7)} = 1; - } - } else { - die "unable to parse weekday specification '$p'\n"; - } - }; - - my @parts = split(/\s+/, $event); - my $utc = (@parts && uc($parts[-1]) eq 'UTC'); - pop @parts if $utc; - - - if ($parts[0] =~ m/$dowsel/i) { - my $dow_spec = shift @parts; - foreach my $p (split(',', $dow_spec)) { - $parse_dowspec->($p); - } - } else { - $dow_hash = { 0 => 1, 1 => 1, 2 => 1, 3 => 1, 4 => 1, 5=> 1, 6 => 1 }; - } - - if (scalar(@parts) && $parts[0] =~ m/\-/) { - my $date_spec = shift @parts; - die "date specification not implemented"; - } - - my $time_spec = shift(@parts) // "00:00"; - my $chars = '[0-9*/.,]'; - - if ($time_spec =~ m/^($chars+):($chars+)$/) { - my ($p1, $p2) = ($1, $2); - foreach my $p (split(',', $p1)) { - $parse_single_timespec->($p, 24, \$matchall_hours, $hours_hash); - } - foreach my $p (split(',', $p2)) { - $parse_single_timespec->($p, 60, \$matchall_minutes, $minutes_hash); - } - } elsif ($time_spec =~ m/^($chars)+$/) { # minutes only - $matchall_hours = 1; - foreach my $p (split(',', $time_spec)) { - $parse_single_timespec->($p, 60, \$matchall_minutes, $minutes_hash); - } - - } else { - die "unable to parse calendar event\n"; - } - - die "unable to parse calendar event - unused parts\n" if scalar(@parts); - - if ($matchall_hours) { - $h = '*'; - } else { - $h = [ sort { $a <=> $b } keys %$hours_hash ]; - } - - if ($matchall_minutes) { - $m = '*'; - } else { - $m = [ sort { $a <=> $b } keys %$minutes_hash ]; - } - - return { h => $h, m => $m, dow => [ sort keys %$dow_hash ], utc => $utc }; -} - -sub is_leap_year($) { - return 0 if $_[0] % 4; - return 1 if $_[0] % 100; - return 0 if $_[0] % 400; - return 1; -} - -# mon = 0.. (Jan = 0) -sub days_in_month($$) { - my ($mon, $year) = @_; - return 28 + is_leap_year($year) if $mon == 1; - return (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[$mon]; -} - -# day = 1.. -# mon = 0.. (Jan = 0) -sub wrap_time($) { - my ($time) = @_; - my ($sec, $min, $hour, $day, $mon, $year, $wday) = @$time; - - use integer; - if ($sec >= 60) { - $min += $sec / 60; - $sec %= 60; - } - - if ($min >= 60) { - $hour += $min / 60; - $min %= 60; - } - - if ($hour >= 24) { - $day += $hour / 24; - $wday += $hour / 24; - $hour %= 24; - } - - # Translate to 0..($days_in_mon-1) - --$day; - while (1) { - my $days_in_mon = days_in_month($mon % 12, $year); - last if $day < $days_in_mon; - # Wrap one month - $day -= $days_in_mon; - ++$mon; - } - # Translate back to 1..$days_in_mon - ++$day; - - if ($mon >= 12) { - $year += $mon / 12; - $mon %= 12; - } - - $wday %= 7; - return [$sec, $min, $hour, $day, $mon, $year, $wday]; -} - -# helper as we need to keep weekdays in sync -sub time_add_days($$) { - my ($time, $inc) = @_; - my ($sec, $min, $hour, $day, $mon, $year, $wday) = @$time; - return wrap_time([$sec, $min, $hour, $day + $inc, $mon, $year, $wday + $inc]); + return Proxmox::RS::CalendarEvent->new($event); } sub compute_next_event { my ($calspec, $last) = @_; - my $hspec = $calspec->{h}; - my $mspec = $calspec->{m}; - my $dowspec = $calspec->{dow}; - my $utc = $calspec->{utc}; - - $last += 60; # at least one minute later - - my $t = [$utc ? gmtime($last) : localtime($last)]; - $t->[0] = 0; # we're not interested in seconds, actually - $t->[5] += 1900; # real years for clarity - - outer: for (my $i = 0; $i < 1000; ++$i) { - my $wday = $t->[6]; - foreach my $d (@$dowspec) { - goto this_wday if $d == $wday; - if ($d > $wday) { - $t->[0] = $t->[1] = $t->[2] = 0; # sec = min = hour = 0 - $t = time_add_days($t, $d - $wday); - next outer; - } - } - # Test next week: - $t->[0] = $t->[1] = $t->[2] = 0; # sec = min = hour = 0 - $t = time_add_days($t, 7 - $wday); - next outer; - this_wday: - - goto this_hour if $hspec eq '*'; - my $hour = $t->[2]; - foreach my $h (@$hspec) { - goto this_hour if $h == $hour; - if ($h > $hour) { - $t->[0] = $t->[1] = 0; # sec = min = 0 - $t->[2] = $h; # hour = $h - next outer; - } - } - # Test next day: - $t->[0] = $t->[1] = $t->[2] = 0; # sec = min = hour = 0 - $t = time_add_days($t, 1); - next outer; - this_hour: - - goto this_min if $mspec eq '*'; - my $min = $t->[1]; - foreach my $m (@$mspec) { - goto this_min if $m == $min; - if ($m > $min) { - $t->[0] = 0; # sec = 0 - $t->[1] = $m; # min = $m - next outer; - } - } - # Test next hour: - $t->[0] = $t->[1] = 0; # sec = min = hour = 0 - $t->[2]++; - $t = wrap_time($t); - next outer; - this_min: - - return $utc ? timegm(@$t) : timelocal(@$t); - } - - die "unable to compute next calendar event\n"; + return $calspec->compute_next_event($last); } 1; diff --git a/src/PVE/Certificate.pm b/src/PVE/Certificate.pm index 5bc9848..f67f6cd 100644 --- a/src/PVE/Certificate.pm +++ b/src/PVE/Certificate.pm @@ -91,8 +91,6 @@ PVE::JSONSchema::register_standard_option('pve-certificate-info', { }, }); -# see RFC 7468 -my $b64_char_re = qr![0-9A-Za-z\+/]!; my $header_re = sub { my ($label) = @_; return qr!-----BEGIN\ $label-----(?:\s|\n)*!; @@ -104,6 +102,7 @@ my $footer_re = sub { my $pem_re = sub { my ($label) = @_; + my $b64_char_re = qr![0-9A-Za-z\+/]!; # see RFC 7468 my $header = $header_re->($label); my $footer = $footer_re->($label); @@ -134,22 +133,15 @@ sub split_pem { sub check_pem { my ($content, %opts) = @_; - my $label = $opts{label} // 'CERTIFICATE'; - my $multiple = $opts{multiple}; - my $noerr = $opts{noerr}; - $content = strip_leading_text($content); - my $re = $pem_re->($label); + my $re = $pem_re->($opts{label} // 'CERTIFICATE'); + $re = qr/($re\n+)*$re/ if $opts{multiple}; - $re = qr/($re\n+)*$re/ if $multiple; + return $content if $content =~ /^$re$/; # OK - if ($content =~ /^$re$/) { - return $content; - } else { - return undef if $noerr; - die "not a valid PEM-formatted string.\n"; - } + return undef if $opts{noerr}; + die "not a valid PEM-formatted string.\n"; } sub pem_to_der { @@ -179,15 +171,10 @@ sub der_to_pem { return "-----BEGIN $label-----\n$b64\n-----END $label-----\n"; } -my $ssl_die = sub { - my ($msg) = @_; - Net::SSLeay::die_now($msg); -}; - -my $ssl_warn = sub { +my sub ssl_die { my ($msg) = @_; - Net::SSLeay::print_errs(); - warn $msg if $msg; + warn Net::SSLeay::print_errs(); + Net::SSLeay::die_now("$msg\n"); }; my $read_certificate = sub { @@ -196,13 +183,11 @@ my $read_certificate = sub { die "'$cert_path' does not exist!\n" if ! -e $cert_path; my $bio = Net::SSLeay::BIO_new_file($cert_path, 'r') - or $ssl_die->("unable to read '$cert_path' - $!\n"); + or ssl_die("unable to read '$cert_path' - $!"); my $cert = Net::SSLeay::PEM_read_bio_X509($bio); - if (!$cert) { - Net::SSLeay::BIO_free($bio); - die "unable to read certificate from '$cert_path'\n"; - } + Net::SSLeay::BIO_free($bio); + die "unable to read certificate from '$cert_path'\n" if !$cert; return $cert; }; @@ -210,9 +195,9 @@ my $read_certificate = sub { sub convert_asn1_to_epoch { my ($asn1_time) = @_; - $ssl_die->("invalid ASN1 time object\n") if !$asn1_time; + ssl_die("invalid ASN1 time object") if !$asn1_time; my $iso_time = Net::SSLeay::P_ASN1_TIME_get_isotime($asn1_time); - $ssl_die->("unable to parse ASN1 time\n") if $iso_time eq ''; + ssl_die("unable to parse ASN1 time") if $iso_time eq ''; return Date::Parse::str2time($iso_time); } @@ -230,6 +215,39 @@ sub get_certificate_fingerprint { return $fp; } +sub assert_certificate_matches_key { + my ($cert_path, $key_path) = @_; + + die "No certificate path given!\n" if !$cert_path; + die "No certificate key path given!\n" if !$key_path; + + die "Certificate at '$cert_path' does not exist!\n" if ! -e $cert_path; + die "Certificate key '$key_path' does not exist!\n" if ! -e $key_path; + + my $ctx = Net::SSLeay::CTX_new() + or ssl_die("Failed to create SSL context in order to verify private key"); + + eval { + my $filetype = &Net::SSLeay::FILETYPE_PEM; + + Net::SSLeay::CTX_use_PrivateKey_file($ctx, $key_path, $filetype) + or ssl_die("Failed to load private key from '$key_path' into SSL context"); + + Net::SSLeay::CTX_use_certificate_file($ctx, $cert_path, $filetype) + or ssl_die("Failed to load certificate from '$cert_path' into SSL context"); + + Net::SSLeay::CTX_check_private_key($ctx) + or ssl_die("Failed to validate private key and certificate"); + }; + my $err = $@; + + Net::SSLeay::CTX_free($ctx); + + die $err if $err; + + return 1; +} + sub get_certificate_info { my ($cert_path) = @_; @@ -266,13 +284,11 @@ sub get_certificate_info { $info->{fingerprint} = Net::SSLeay::X509_get_fingerprint($cert, 'sha256'); - my $subject = Net::SSLeay::X509_get_subject_name($cert); - if ($subject) { + if (my $subject = Net::SSLeay::X509_get_subject_name($cert)) { $info->{subject} = Net::SSLeay::X509_NAME_oneline($subject); } - my $issuer = Net::SSLeay::X509_get_issuer_name($cert); - if ($issuer) { + if (my $issuer = Net::SSLeay::X509_get_issuer_name($cert)) { $info->{issuer} = Net::SSLeay::X509_NAME_oneline($issuer); } @@ -345,8 +361,8 @@ sub generate_csr { my ($bio, $pk, $req); my $cleanup = sub { - my ($warn, $die_msg) = @_; - $ssl_warn->() if $warn; + my ($die_msg, $no_warn) = @_; + Net::SSLeay::print_errs() if !$no_warn; Net::SSLeay::X509_REQ_free($req) if $req; Net::SSLeay::EVP_PKEY_free($pk) if $pk; @@ -358,75 +374,70 @@ sub generate_csr { # this unfortunately causes a small memory leak, since there is no # X509_NAME_free() (yet) my $name = Net::SSLeay::X509_NAME_new(); - $ssl_die->("Failed to allocate X509_NAME object\n") if !$name; + ssl_die("Failed to allocate X509_NAME object") if !$name; my $add_name_entry = sub { my ($k, $v) = @_; - if (!Net::SSLeay::X509_NAME_add_entry_by_txt($name, - $k, - &Net::SSLeay::MBSTRING_UTF8, - encode('utf-8', $v))) { - $cleanup->(1, "Failed to add '$k'='$v' to DN\n"); - } + + my $res = Net::SSLeay::X509_NAME_add_entry_by_txt( + $name, $k, &Net::SSLeay::MBSTRING_UTF8, encode('utf-8', $v)); + + $cleanup->("Failed to add '$k'='$v' to DN\n") if !$res; }; $add_name_entry->('CN', $common_name); for (qw(C ST L O OU)) { - if (defined(my $v = $attr{$_})) { + if (defined(my $v = $attr{$_})) { $add_name_entry->($_, $v); - } + } } if (defined($pem_key)) { my $bio_s_mem = Net::SSLeay::BIO_s_mem(); - $cleanup->(1, "Failed to allocate BIO_s_mem for private key\n") - if !$bio_s_mem; + $cleanup->("Failed to allocate BIO_s_mem for private key\n") if !$bio_s_mem; $bio = Net::SSLeay::BIO_new($bio_s_mem); - $cleanup->(1, "Failed to allocate BIO for private key\n") if !$bio; + $cleanup->("Failed to allocate BIO for private key\n") if !$bio; - $cleanup->(1, "Failed to write PEM-encoded key to BIO\n") + $cleanup->("Failed to write PEM-encoded key to BIO\n") if Net::SSLeay::BIO_write($bio, $pem_key) <= 0; $pk = Net::SSLeay::PEM_read_bio_PrivateKey($bio); - $cleanup->(1, "Failed to read private key into EVP_PKEY\n") if !$pk; + $cleanup->("Failed to read private key into EVP_PKEY\n") if !$pk; } else { $pk = Net::SSLeay::EVP_PKEY_new(); - $cleanup->(1, "Failed to allocate EVP_PKEY for private key\n") if !$pk; + $cleanup->("Failed to allocate EVP_PKEY for private key\n") if !$pk; my $rsa = Net::SSLeay::RSA_generate_key($bits, 65537); - $cleanup->(1, "Failed to generate RSA key pair\n") if !$rsa; + $cleanup->("Failed to generate RSA key pair\n") if !$rsa; - $cleanup->(1, "Failed to assign RSA key to EVP_PKEY\n") + $cleanup->("Failed to assign RSA key to EVP_PKEY\n") if !Net::SSLeay::EVP_PKEY_assign_RSA($pk, $rsa); } $req = Net::SSLeay::X509_REQ_new(); - $cleanup->(1, "Failed to allocate X509_REQ\n") if !$req; + $cleanup->("Failed to allocate X509_REQ\n") if !$req; - $cleanup->(1, "Failed to set subject name\n") + $cleanup->("Failed to set subject name\n") if (!Net::SSLeay::X509_REQ_set_subject_name($req, $name)); - $cleanup->(1, "Failed to add extensions to CSR\n") - if !Net::SSLeay::P_X509_REQ_add_extensions($req, - &Net::SSLeay::NID_key_usage => 'digitalSignature,keyEncipherment', - &Net::SSLeay::NID_basic_constraints => 'CA:FALSE', - &Net::SSLeay::NID_ext_key_usage => 'serverAuth,clientAuth', - &Net::SSLeay::NID_subject_alt_name => join(',', map { "DNS:$_" } @$san), - ); + Net::SSLeay::P_X509_REQ_add_extensions( + $req, + &Net::SSLeay::NID_key_usage => 'digitalSignature,keyEncipherment', + &Net::SSLeay::NID_basic_constraints => 'CA:FALSE', + &Net::SSLeay::NID_ext_key_usage => 'serverAuth,clientAuth', + &Net::SSLeay::NID_subject_alt_name => join(',', map { "DNS:$_" } @$san), + ) or $cleanup->("Failed to add extensions to CSR\n"); - $cleanup->(1, "Failed to set public key\n") - if !Net::SSLeay::X509_REQ_set_pubkey($req, $pk); + $cleanup->("Failed to set public key\n") if !Net::SSLeay::X509_REQ_set_pubkey($req, $pk); - $cleanup->(1, "Failed to set CSR version\n") - if !Net::SSLeay::X509_REQ_set_version($req, 2); + $cleanup->("Failed to set CSR version\n") if !Net::SSLeay::X509_REQ_set_version($req, 0); - $cleanup->(1, "Failed to sign CSR\n") - if !Net::SSLeay::X509_REQ_sign($req, $pk, $md); + $cleanup->("Failed to sign CSR\n") if !Net::SSLeay::X509_REQ_sign($req, $pk, $md); my $pk_pem = Net::SSLeay::PEM_get_string_PrivateKey($pk); my $req_pem = Net::SSLeay::PEM_get_string_X509_REQ($req); - $cleanup->(); + $cleanup->(undef, 1); return wantarray ? ($req_pem, $pk_pem) : $req_pem; } diff --git a/src/PVE/CpuSet.pm b/src/PVE/CpuSet.pm index 12bda2c..1292558 100644 --- a/src/PVE/CpuSet.pm +++ b/src/PVE/CpuSet.pm @@ -131,7 +131,8 @@ sub has { sub members { my ($self) = @_; - return sort { $a <=> $b } keys %{$self->{members}}; + my @sorted_members = sort { $a <=> $b } keys %{$self->{members}}; + return @sorted_members; } sub size { diff --git a/src/PVE/Daemon.pm b/src/PVE/Daemon.pm index 64f8126..63fd5ee 100644 --- a/src/PVE/Daemon.pm +++ b/src/PVE/Daemon.pm @@ -114,10 +114,10 @@ my $writepidfile = sub { my $pidfile = $self->{pidfile}; - die "can't open pid file '$pidfile' - $!\n" if !open (PIDFH, ">$pidfile"); + open (my $PID_FH, '>', "$pidfile") or die "can't open pid file '$pidfile' - $!\n"; - print PIDFH "$$\n"; - close (PIDFH); + print $PID_FH "$$\n"; + close ($PID_FH); }; my $server_cleanup = sub { @@ -243,8 +243,7 @@ sub setup { initlog($self->{name}); - my $restart = $ENV{RESTART_PVE_DAEMON}; - delete $ENV{RESTART_PVE_DAEMON}; + my $restart = delete $ENV{RESTART_PVE_DAEMON}; $self->{env_restart_pve_daemon} = $restart; my $lockfd = $ENV{PVE_DAEMON_LOCK_FD}; @@ -311,8 +310,8 @@ my $server_run = sub { $self->init(); if (!$debug) { - open STDIN, '/dev/null' || die "can't write /dev/null"; + open STDIN, '<', '/dev/null' or die "can't read /dev/null - $!"; + open STDOUT, '>', '/dev/null' or die "can't write /dev/null - $!"; } if (!$self->{env_restart_pve_daemon} && !$debug) { @@ -573,7 +572,6 @@ my $read_pid = sub { # checks if the process was started by systemd my $init_ppid = sub { - if (getppid() == 1) { return 1; } else { @@ -799,7 +797,7 @@ sub register_status_command { # some useful helper sub create_reusable_socket { - my ($self, $port, $host, $family) = @_; + my ($self, $port, $host) = @_; die "no port specifed" if !$port; @@ -819,15 +817,23 @@ sub create_reusable_socket { $socket->fcntl(Fcntl::F_SETFD(), Fcntl::FD_CLOEXEC); } else { - $socket = IO::Socket::IP->new( - LocalAddr => $host, + my %sockargs = ( LocalPort => $port, Listen => SOMAXCONN, - Family => $family, Proto => 'tcp', GetAddrInfoFlags => 0, - ReuseAddr => 1) || - die "unable to create socket - $@\n"; + ReuseAddr => 1, + ); + if (defined($host)) { + $socket = IO::Socket::IP->new( LocalHost => $host, %sockargs) || + die "unable to create socket - $@\n"; + } else { + # disabling AF_INET6 (by adding ipv6.disable=1 to the kernel cmdline) + # causes bind on :: to fail, try 0.0.0.0 in that case + $socket = IO::Socket::IP->new( LocalHost => '::', %sockargs) // + IO::Socket::IP->new( LocalHost => '0.0.0.0', %sockargs); + die "unable to create socket - $@\n" if !$socket; + } # we often observe delays when using Nagle algorithm, # so we disable that to maximize performance diff --git a/src/PVE/Exception.pm b/src/PVE/Exception.pm index fe6ecbb..f40f13a 100644 --- a/src/PVE/Exception.pm +++ b/src/PVE/Exception.pm @@ -6,9 +6,9 @@ package PVE::Exception; use strict; use warnings; -use Storable qw(dclone); -use HTTP::Status qw(:constants); +use HTTP::Status qw(:constants); +use Storable qw(dclone); use overload '""' => sub {local $@; shift->stringify}; use overload 'cmp' => sub { @@ -35,7 +35,7 @@ sub new { $self->{$p} = ref($v) ? dclone($v) : $v; } - return bless $self; + return bless $self, $class; } sub raise { diff --git a/src/PVE/Format.pm b/src/PVE/Format.pm new file mode 100644 index 0000000..4c48f2f --- /dev/null +++ b/src/PVE/Format.pm @@ -0,0 +1,82 @@ +package PVE::Format; + +use strict; +use warnings; + +use POSIX qw(strftime round); + +use base 'Exporter'; +our @EXPORT_OK = qw( +render_timestamp +render_timestamp_gmt +render_duration +render_fraction_as_percentage +render_bytes +); + +sub render_timestamp { + my ($epoch) = @_; + + # ISO 8601 date format + return strftime("%F %H:%M:%S", localtime($epoch)); +} + +sub render_timestamp_gmt { + my ($epoch) = @_; + + # ISO 8601 date format, standard Greenwich time zone + return strftime("%F %H:%M:%S", gmtime($epoch)); +} + +sub render_duration { + my ($duration_in_seconds, $auto_limit_accuracy) = @_; + + my $text = ''; + my $rest = round($duration_in_seconds // 0); + + return "0s" if !$rest; + + my $step = sub { + my ($unit, $unitlength) = @_; + + if ((my $v = int($rest / $unitlength)) > 0) { + $text .= " " if length($text); + $text .= "${v}${unit}"; + $rest -= $v * $unitlength; + return 1; + } + return undef; + }; + + my $weeks = $step->('w', 7 * 24 * 3600); + my $days = $step->('d', 24 * 3600) || $weeks; + $step->('h', 3600); + $step->('m', 60) if !$auto_limit_accuracy || !$weeks; + $step->('s', 1) if !$auto_limit_accuracy || !$days; + + return $text; +} + +sub render_fraction_as_percentage { + my ($fraction) = @_; + + return sprintf("%.2f%%", $fraction*100); +} + +sub render_bytes { + my ($value, $precision) = @_; + + $precision = $precision->{precision} if ref($precision) eq 'HASH'; + + my @units = qw(B KiB MiB GiB TiB PiB); + + my $max_unit = 0; + if ($value > 1023) { + $max_unit = int(log($value)/log(1024)); + $value /= 1024**($max_unit); + } + my $unit = $units[$max_unit]; + return sprintf "%." . ($precision || 2) . "f $unit", $value; +} + +1; diff --git a/src/PVE/INotify.pm b/src/PVE/INotify.pm index f524672..8a4a810 100644 --- a/src/PVE/INotify.pm +++ b/src/PVE/INotify.pm @@ -22,10 +22,11 @@ use PVE::Network; use PVE::ProcFSTools; use PVE::SafeSyslog; use PVE::Tools; +use PVE::RESTEnvironment qw(log_warn); use base 'Exporter'; -our @EXPORT_OK = qw(read_file write_file register_file); +our @EXPORT_OK = qw(read_file write_file register_file nodename); my $ccache; my $ccachemap; @@ -500,13 +501,10 @@ sub inotify_init { } my $cached_nodename; - sub nodename { - return $cached_nodename if $cached_nodename; my ($sysname, $nodename) = POSIX::uname(); - $nodename =~ s/\..*$//; # strip domain part, if any die "unable to read node name\n" if !$nodename; @@ -723,14 +721,15 @@ register_file('active', "/var/log/pve/tasks/active", \&write_active_workers); -our $bond_modes = { 'balance-rr' => 0, - 'active-backup' => 1, - 'balance-xor' => 2, - 'broadcast' => 3, - '802.3ad' => 4, - 'balance-tlb' => 5, - 'balance-alb' => 6, - }; +our $bond_modes = { + 'balance-rr' => 0, + 'active-backup' => 1, + 'balance-xor' => 2, + 'broadcast' => 3, + '802.3ad' => 4, + 'balance-tlb' => 5, + 'balance-alb' => 6, +}; my $ovs_bond_modes = { 'active-backup' => 1, @@ -883,7 +882,7 @@ sub __read_etc_network_interfaces { 'bridge-fd' => 'bridge_fd', 'bridge-stp' => 'bridge_stp', 'bridge-ports' => 'bridge_ports', - 'bridge-vids' => 'bridge_vids' + 'bridge-vids' => 'bridge_vids', }; my $line; @@ -903,39 +902,40 @@ sub __read_etc_network_interfaces { SECTION: while (defined ($line = <$fh>)) { chomp ($line); next if $line =~ m/^\s*#/; - next if $line =~ m/^\s*(allow-hotplug)\s+(.*)$/; - if ($line =~ m/^\s*(auto|allow-ovs)\s+(.*)$/) { - my @aa = split (/\s+/, $2); + if ($line =~ m/^\s*(allow-auto|auto|allow-ovs)\s+(.*)$/) { - foreach my $a (@aa) { - $ifaces->{$a}->{autostart} = 1; - } + $ifaces->{$_}->{autostart} = 1 for split (/\s+/, $2); + + } elsif ($line =~ m/^\s*(allow-hotplug)\s+(.*)$/) { - } elsif ($line =~ m/^\s*iface\s+(\S+)\s+(inet6?)\s+(\S+)\s*$/) { + # FIXME: handle those differently? auto makes it required on-boot, vs. best-effort + $ifaces->{$_}->{autostart} = 1 for split (/\s+/, $2); + + } elsif ($line =~ m/^\s*iface\s+(\S+)(?:\s+(inet6?)\s+(\S+))?\s*$/) { my $i = $1; my $family = $2; my $f = { method => $3 }; # by family, merged to $d with a $suffix - (my $suffix = $family) =~ s/^inet//; + my $suffix = $family; + $suffix =~ s/^inet// if defined $suffix; my $d = $ifaces->{$i} ||= {}; $d->{priority} = $priority++ if !$d->{priority}; + + # $family may be undef, an undef family means we have a stanza + # without an `inet` or `inet6` section push @{$d->{families}}, $family; + while (defined ($line = <$fh>)) { $line =~ s/\s+$//; # drop trailing whitespaces if ($line =~ m/^\s*#(.*?)\s*$/) { - $f->{comments} = '' if !$f->{comments}; + my $pushto = defined($suffix) ? $f : $d; + $pushto->{comments} = '' if !$pushto->{comments}; my $comment = decode('UTF-8', $1); - $f->{comments} .= "$comment\n"; - } elsif ($line =~ m/^\s*(?:iface\s - |mapping\s - |auto\s - |allow- - |source\s - |source-directory\s - )/x) { + $pushto->{comments} .= "$comment\n"; + } elsif ($line =~ m/^\s*(?:(?:iface|mapping|auto|source|source-directory)\s|allow-)/) { last; } elsif ($line =~ m/^\s*((\S+)\s+(.+))$/) { my $option = $1; @@ -957,9 +957,11 @@ sub __read_etc_network_interfaces { 'bridge-arp-nd-suppress' => 1, 'bridge-unicast-flood' => 1, 'bridge-multicast-flood' => 1, + 'bridge-disable-mac-learning' => 1, 'bond_miimon' => 1, 'bond_xmit_hash_policy' => 1, 'bond-primary' => 1, + 'link-type' => 1, 'uplink-id' => 1, 'vlan-protocol' => 1, 'vlan-raw-device' => 1, @@ -967,10 +969,21 @@ sub __read_etc_network_interfaces { 'vxlan-id' => 1, 'vxlan-svcnodeip' => 1, 'vxlan-physdev' => 1, - 'vxlan-local-tunnelip' => 1 }; + 'vxlan-local-tunnelip' => 1, + }; - if (($id eq 'address') || ($id eq 'netmask') || ($id eq 'broadcast') || ($id eq 'gateway')) { - $f->{$id} = $value; + if ($id eq 'address' || $id eq 'netmask' || $id eq 'broadcast' || $id eq 'gateway') { + if (defined($suffix)) { + $d->{$id.$suffix} = $value; + } elsif ($id ne 'netmask') { + if ($value =~ /:/) { + $d->{$id.'6'} = $value; + } else { + $d->{$id} = $value; + } + } else { + $d->{$id} = $value; + } } elsif ($simple_options->{$id}) { $d->{$id} = $value; } elsif ($id eq 'slaves' || $id eq 'bridge_ports') { @@ -996,8 +1009,7 @@ sub __read_etc_network_interfaces { } elsif ($id eq 'bond_mode') { # always use names foreach my $bm (keys %$bond_modes) { - my $id = $bond_modes->{$bm}; - if ($id eq $value) { + if ($bond_modes->{$bm} eq $value) { $value = $bm; last; } @@ -1006,13 +1018,16 @@ sub __read_etc_network_interfaces { } elsif ($id eq 'vxlan-remoteip') { push @{$d->{$id}}, $value; } else { - push @{$f->{options}}, $option; + my $pushto = defined($suffix) ? $f : $d; + push @{$pushto->{options}}, $option; } } else { last; } } - $d->{"$_$suffix"} = $f->{$_} foreach (keys %$f); + if (defined($suffix)) { + $d->{"$_$suffix"} = $f->{$_} for keys $f->%*; + } last SECTION if !defined($line); redo SECTION; } elsif ($line =~ /\w/) { @@ -1027,16 +1042,28 @@ sub __read_etc_network_interfaces { } if (!$ifaces->{lo}) { - $ifaces->{lo}->{priority} = 1; - $ifaces->{lo}->{method} = 'loopback'; - $ifaces->{lo}->{type} = 'loopback'; - $ifaces->{lo}->{autostart} = 1; + $ifaces->{lo} = { + priority => 1, + method => 'loopback', + type => 'loopback', + autostart => 1, + }; } - foreach my $iface (keys %$ifaces) { + foreach my $iface (sort keys %$ifaces) { my $d = $ifaces->{$iface}; $d->{type} = 'unknown'; - if ($iface =~ m/^bond\d+$/) { + if (defined $d->{'bridge_ports'}) { + $d->{type} = 'bridge'; + if (!defined ($d->{bridge_stp})) { + $d->{bridge_stp} = 'off'; + } + if (!defined($d->{bridge_fd}) && $d->{bridge_stp} eq 'off') { + $d->{bridge_fd} = 0; + } + } elsif ($d->{ovs_type} && $d->{ovs_type} eq 'OVSBridge') { + $d->{type} = $d->{ovs_type}; + } elsif ($iface =~ m/^bond\d+$/) { if (!$d->{ovs_type}) { $d->{type} = 'bond'; } elsif ($d->{ovs_type} eq 'OVSBond') { @@ -1056,19 +1083,6 @@ sub __read_etc_network_interfaces { my $tag = &$extract_ovs_option($d, 'tag'); $d->{ovs_tag} = $tag if defined($tag); } - } elsif ($iface =~ m/^vmbr\d+$/) { - if (!$d->{ovs_type}) { - $d->{type} = 'bridge'; - - if (!defined ($d->{bridge_fd})) { - $d->{bridge_fd} = 0; - } - if (!defined ($d->{bridge_stp})) { - $d->{bridge_stp} = 'off'; - } - } elsif ($d->{ovs_type} eq 'OVSBridge') { - $d->{type} = $d->{ovs_type}; - } } elsif ($iface =~ m/^(\S+):\d+$/) { $d->{type} = 'alias'; if (defined ($ifaces->{$1})) { @@ -1077,10 +1091,30 @@ sub __read_etc_network_interfaces { $ifaces->{$1}->{exists} = 0; $d->{exists} = 0; } - } elsif ($iface =~ m/^(\S+)\.\d+$/ || $d->{'vlan-raw-device'}) { + } elsif ($iface =~ m/^(\S+)\.(\d+)$/) { + $d->{type} = 'vlan'; + + my ($dev, $id) = ($1, $2); + $d->{'vlan-raw-device'} = $dev if defined($dev) && !$d->{'vlan-raw-device'}; + $d->{'vlan-id'} = $id if $id; # VLAN id 0 is not valid, so truthy check it is + + my $raw_iface = $d->{'vlan-raw-device'}; + + if (defined ($ifaces->{$raw_iface})) { + $d->{exists} = $ifaces->{$raw_iface}->{exists}; + } else { + $ifaces->{$raw_iface}->{exists} = 0; + $d->{exists} = 0; + } + } elsif ($d->{'vlan-raw-device'}) { $d->{type} = 'vlan'; - my $raw_iface = $d->{'vlan-raw-device'} ? $d->{'vlan-raw-device'} : $1; + if ($iface =~ m/^vlan(\d+)$/) { + $d->{'vlan-id'} = $1 if $1; # VLAN id 0 is not valid, so truthy check it is + } + + my $raw_iface = $d->{'vlan-raw-device'}; + if (defined ($ifaces->{$raw_iface})) { $d->{exists} = $ifaces->{$raw_iface}->{exists}; } else { @@ -1106,9 +1140,14 @@ sub __read_etc_network_interfaces { my $tag = &$extract_ovs_option($d, 'tag'); $d->{ovs_tag} = $tag if defined($tag); } + } elsif (defined($d->{'link-type'})) { + $d->{type} = $d->{'link-type'} if $d->{'link-type'} eq 'dummy'; } } + log_warn("detected a interface $iface that is not a bridge!") + if !($d->{type} eq 'OVSBridge' || $d->{type} eq 'bridge') && $iface =~ m/^vmbr\d+$/; + # map address and netmask to cidr if (my $addr = $d->{address}) { if (_address_is_cidr($addr)) { @@ -1143,6 +1182,10 @@ sub __read_etc_network_interfaces { $d->{method} = 'manual' if !$d->{method}; $d->{method6} = 'manual' if !$d->{method6}; + if (my $comments6 = delete $d->{comments6}) { + $d->{comments} = ($d->{comments} // '') . $comments6; + } + $d->{families} ||= ['inet']; } @@ -1203,34 +1246,44 @@ sub _get_cidr { sub __interface_to_string { my ($iface, $d, $family, $first_block, $ifupdown2) = @_; - (my $suffix = $family) =~ s/^inet//; + my $suffix = $family; + $suffix =~ s/^inet// if defined($suffix); - return '' if !($d && $d->{"method$suffix"}); + return '' if $family && !($d && $d->{"method$suffix"}); - my $raw = ''; - - $raw .= "iface $iface $family " . $d->{"method$suffix"} . "\n"; - - if (my $addr = $d->{"address$suffix"}) { + my $raw = "iface $iface"; + $raw .= " $family " . $d->{"method$suffix"} if defined $family; + $raw .= "\n"; - if ($addr !~ /\/\d+$/ && $d->{"netmask$suffix"}) { - if ($d->{"netmask$suffix"} =~ m/^\d+$/) { - $addr .= "/" . $d->{"netmask$suffix"}; - } elsif (my $mask = PVE::JSONSchema::get_netmask_bits($d->{"netmask$suffix"})) { - $addr .= "/" . $mask; + my $add_addr = sub { + my ($suffix) = @_; + if (my $addr = $d->{"address$suffix"}) { + if ($addr !~ /\/\d+$/ && $d->{"netmask$suffix"}) { + if ($d->{"netmask$suffix"} =~ m/^\d+$/) { + $addr .= "/" . $d->{"netmask$suffix"}; + } elsif (my $mask = PVE::JSONSchema::get_netmask_bits($d->{"netmask$suffix"})) { + $addr .= "/" . $mask; + } } + $raw .= "\taddress ${addr}\n"; } - $raw .= "\taddress " . $addr . "\n"; - } + $raw .= "\tgateway " . $d->{"gateway$suffix"} . "\n" if $d->{"gateway$suffix"}; + }; - $raw .= "\tgateway " . $d->{"gateway$suffix"} . "\n" if $d->{"gateway$suffix"}; + if ($family) { + $add_addr->($suffix); + } else { + $add_addr->(''); + $add_addr->('6'); + } - my $done = { type => 1, priority => 1, method => 1, active => 1, exists => 1, - comments => 1, autostart => 1, options => 1, - address => 1, netmask => 1, gateway => 1, broadcast => 1, - method6 => 1, families => 1, options6 => 1, - address6 => 1, netmask6 => 1, gateway6 => 1, broadcast6 => 1, 'uplink-id' => 1 }; + my $done = { + type => 1, priority => 1, method => 1, active => 1, exists => 1, comments => 1, + autostart => 1, options => 1, address => 1, netmask => 1, gateway => 1, broadcast => 1, + method6 => 1, families => 1, options6 => 1, comments6 => 1, address6 => 1, + netmask6 => 1, gateway6 => 1, broadcast6 => 1, 'uplink-id' => 1, + }; if (!$first_block) { # not printing out options @@ -1241,24 +1294,36 @@ sub __interface_to_string { $raw .= "\tbridge-ports $ports\n"; $done->{bridge_ports} = 1; - my $v = defined($d->{bridge_stp}) ? $d->{bridge_stp} : 'off'; - $raw .= "\tbridge-stp $v\n"; + my $br_stp = defined($d->{bridge_stp}) ? $d->{bridge_stp} : 'off'; + my $no_stp = $br_stp eq 'off'; + + $raw .= "\tbridge-stp $br_stp\n"; $done->{bridge_stp} = 1; - $v = defined($d->{bridge_fd}) ? $d->{bridge_fd} : 0; - $raw .= "\tbridge-fd $v\n"; + # NOTE: forwarding delay must be 2 <= FD <= 30 if STP is enabled + if (defined(my $br_fd = $d->{bridge_fd})) { + if ($no_stp || ($br_fd >= 2 && $br_fd <= 30)) { + $raw .= "\tbridge-fd $br_fd\n"; + } else { + # only complain if the user actually set a value, but not for default fallback below + warn "'$iface': ignoring 'bridge_fd' value '$br_fd', outside of allowed range 2-30\n"; + } + } elsif ($no_stp) { + $raw .= "\tbridge-fd 0\n"; + } $done->{bridge_fd} = 1; - if( defined($d->{bridge_vlan_aware})) { + if (defined($d->{bridge_vlan_aware})) { $raw .= "\tbridge-vlan-aware yes\n"; - $v = defined($d->{bridge_vids}) ? $d->{bridge_vids} : "2-4094"; - $raw .= "\tbridge-vids $v\n"; + my $vlans = defined($d->{bridge_vids}) ? $d->{bridge_vids} : "2-4094"; + $raw .= "\tbridge-vids $vlans\n"; } $done->{bridge_vlan_aware} = 1; $done->{bridge_vids} = 1; $raw .= "\tmtu $d->{mtu}\n" if $d->{mtu}; $done->{mtu} = 1; + $done->{'bridge-disable-mac-learning'} = 1; } elsif ($d->{type} eq 'bond') { @@ -1321,8 +1386,7 @@ sub __interface_to_string { $raw .= "\tovs_mtu $d->{mtu}\n" if $d->{mtu}; $done->{mtu} = 1; - } elsif ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' || - $d->{type} eq 'OVSBond') { + } elsif ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' || $d->{type} eq 'OVSBond') { $d->{autostart} = 0; # started by the bridge @@ -1381,14 +1445,25 @@ sub __interface_to_string { } } - foreach my $option (@{$d->{"options$suffix"}}) { - $raw .= "\t$option\n"; - } + my $add_options_comments = sub { + my ($suffix) = @_; - # add comments - my $comments = $d->{"comments$suffix"} || ''; - foreach my $cl (split(/\n/, $comments)) { - $raw .= "#$cl\n"; + foreach my $option (@{$d->{"options$suffix"}}) { + $raw .= "\t$option\n"; + } + + # add comments + my $comments = $d->{"comments$suffix"} || ''; + foreach my $cl (split(/\n/, $comments)) { + $raw .= "#$cl\n"; + } + }; + + if ($family) { + $add_options_comments->($suffix); + } else { + $add_options_comments->(''); + $add_options_comments->('6'); } $raw .= "\n"; @@ -1433,8 +1508,7 @@ sub __write_etc_network_interfaces { # delete unused OVS ports foreach my $iface (keys %$ifaces) { my $d = $ifaces->{$iface}; - if ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' || - $d->{type} eq 'OVSBond') { + if ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' || $d->{type} eq 'OVSBond') { my $brname = $used_ports->{$iface}; if (!$brname || !$ifaces->{$brname}) { if ($iface =~ /^$PVE::Network::PHYSICAL_NIC_RE/) { @@ -1463,8 +1537,7 @@ sub __write_etc_network_interfaces { if ($d->{type} eq 'OVSBridge' && $d->{ovs_ports}) { foreach my $p (split (/\s+/, $d->{ovs_ports})) { my $n = $ifaces->{$p}; - die "OVS bridge '$iface' - unable to find port '$p'\n" - if !$n; + die "OVS bridge '$iface' - unable to find port '$p'\n" if !$n; $n->{autostart} = 0; if ($n->{type} eq 'eth') { $n->{type} = 'OVSPort'; @@ -1488,10 +1561,9 @@ sub __write_etc_network_interfaces { foreach my $p (split (/\s+/, $d->{ovs_bonds})) { my $n = $ifaces->{$p}; $n->{autostart} = 1; - die "OVS bond '$iface' - unable to find slave '$p'\n" - if !$n; - die "OVS bond '$iface' - wrong interface type on slave '$p' " . - "('$n->{type}' != 'eth')\n" if $n->{type} ne 'eth'; + die "OVS bond '$iface' - unable to find slave '$p'\n" if !$n; + die "OVS bond '$iface' - wrong interface type on slave '$p' ('$n->{type}' != 'eth')\n" + if $n->{type} ne 'eth'; &$check_mtu($ifaces, $iface, $p); } } @@ -1500,21 +1572,21 @@ sub __write_etc_network_interfaces { # check bond foreach my $iface (keys %$ifaces) { my $d = $ifaces->{$iface}; - if ($d->{type} eq 'bond' && $d->{slaves}) { - my $bond_primary_is_slave = undef; - foreach my $p (split (/\s+/, $d->{slaves})) { - my $n = $ifaces->{$p}; - $n->{autostart} = 1; + next if !($d->{type} eq 'bond' && $d->{slaves}); - die "bond '$iface' - unable to find slave '$p'\n" - if !$n; - die "bond '$iface' - wrong interface type on slave '$p' " . - "('$n->{type}' != 'eth')\n" if $n->{type} ne 'eth'; - &$check_mtu($ifaces, $iface, $p); - $bond_primary_is_slave = 1 if $d->{'bond-primary'} && $d->{'bond-primary'} eq $p; - } - die "bond '$iface' - bond-primary interface is not a slave" if $d->{'bond-primary'} && !$bond_primary_is_slave; + my $bond_primary_is_slave = undef; + foreach my $p (split (/\s+/, $d->{slaves})) { + my $n = $ifaces->{$p}; + $n->{autostart} = 1; + + die "bond '$iface' - unable to find slave '$p'\n" if !$n; + die "bond '$iface' - wrong interface type on slave '$p' ('$n->{type}' != 'eth or bond')\n" + if ($n->{type} ne 'eth' && $n->{type} ne 'bond'); + + $check_mtu->($ifaces, $iface, $p); + $bond_primary_is_slave = 1 if $d->{'bond-primary'} && $d->{'bond-primary'} eq $p; } + die "bond '$iface' - bond-primary interface is not a slave" if $d->{'bond-primary'} && !$bond_primary_is_slave; } # check vxlan @@ -1554,6 +1626,8 @@ sub __write_etc_network_interfaces { $p = $1; $vlanid = $2; delete $d->{'vlan-raw-device'} if $d->{'vlan-raw-device'}; + delete $d->{'vlan-id'} if $d->{'vlan-id'}; + } else { die "missing vlan-raw-device option" if !$d->{'vlan-raw-device'}; $p = $d->{'vlan-raw-device'}; @@ -1619,7 +1693,7 @@ sub __write_etc_network_interfaces { die "bridge '$iface' - unable to find bridge port '$p'\n" if !$n; die "iface $p - ip address can't be set on interface if bridged in $iface\n" if ($n->{method} && $n->{method} eq 'static' && $n->{address} ne '0.0.0.0') || - ($n->{method6} && $n->{method6} eq 'static' && $n->{address} ne '::'); + ($n->{method6} && $n->{method6} eq 'static' && $n->{address6} ne '::'); &$check_mtu($ifaces_copy, $p, $iface); $bridgeports->{$p} = $iface; } @@ -1658,6 +1732,7 @@ NETWORKDOC my $if_type_hash = { loopback => 100000, + dummy => 100000, eth => 200000, OVSPort => 200000, OVSIntPort => 300000, @@ -1674,12 +1749,10 @@ NETWORKDOC my ($rootiface, @rest) = split(/[.:]/, $iface); my $childlevel = scalar(@rest); - my $n = $ifaces->{$rootiface}; + my $type = $ifaces->{$rootiface}->{type}; + return if !$type || $type eq 'unknown'; - my $pri = $if_type_hash->{$n->{type}} + $childlevel - if $n->{type} && $n->{type} ne 'unknown'; - - return $pri; + return $if_type_hash->{$type} + $childlevel }; foreach my $iface (sort { @@ -1719,6 +1792,11 @@ NETWORKDOC } } + # if 'inet6' is the only family + if (scalar($d->{families}->@*) == 1 && defined($d->{families}->[0]) && $d->{families}->[0] eq 'inet6') { + $d->{comments6} = delete $d->{comments}; + } + my $i = 0; # some options should be printed only once $raw .= __interface_to_string($iface, $d, $_, !$i++, $ifupdown2) foreach @{$d->{families}}; } @@ -1747,74 +1825,4 @@ sub read_iscsi_initiatorname { register_file('initiatorname', "/etc/iscsi/initiatorname.iscsi", \&read_iscsi_initiatorname); -sub read_apt_auth { - my ($filename, $fd) = @_; - - local $/; - - my $raw = defined($fd) ? <$fd> : ''; - - $raw =~ s/^\s+//; - - - my @tokens = split(/\s+/, $raw); - - my $data = {}; - - my $machine; - while (defined(my $tok = shift @tokens)) { - - $machine = shift @tokens if $tok eq 'machine'; - next if !$machine; - $data->{$machine} = {} if !$data->{$machine}; - - $data->{$machine}->{login} = shift @tokens if $tok eq 'login'; - $data->{$machine}->{password} = shift @tokens if $tok eq 'password'; - }; - - return $data; -} - -my $format_apt_auth_data = sub { - my $data = shift; - - my $raw = ''; - - foreach my $machine (sort keys %$data) { - my $d = $data->{$machine}; - $raw .= "machine $machine\n"; - $raw .= " login $d->{login}\n" if $d->{login}; - $raw .= " password $d->{password}\n" if $d->{password}; - $raw .= "\n"; - } - - return $raw; -}; - -sub write_apt_auth { - my ($filename, $fh, $data) = @_; - - my $raw = &$format_apt_auth_data($data); - - die "write failed: $!" unless print $fh "$raw\n"; - - return $data; -} - -sub update_apt_auth { - my ($filename, $fh, $data) = @_; - - my $orig = read_apt_auth($filename, $fh); - - foreach my $machine (keys %$data) { - $orig->{$machine} = $data->{$machine}; - } - - return &$format_apt_auth_data($orig); -} - -register_file('apt-auth', "/etc/apt/auth.conf", - \&read_apt_auth, \&write_apt_auth, - \&update_apt_auth, perm => 0640); - 1; diff --git a/src/PVE/JSONSchema.pm b/src/PVE/JSONSchema.pm index e8d7395..115f811 100644 --- a/src/PVE/JSONSchema.pm +++ b/src/PVE/JSONSchema.pm @@ -10,17 +10,21 @@ use Devel::Cycle -quiet; # todo: remove? use PVE::Tools qw(split_list $IPV6RE $IPV4RE); use PVE::Exception qw(raise); use HTTP::Status qw(:constants); +use JSON; use Net::IP qw(:PROC); use Data::Dumper; use base 'Exporter'; our @EXPORT_OK = qw( +register_standard_option get_standard_option parse_property_string -register_standard_option +print_property_string ); +our $CONFIGID_RE = qr/[a-z][a-z0-9_-]+/i; + # Note: This class implements something similar to JSON schema, but it is not 100% complete. # see: http://tools.ietf.org/html/draft-zyp-json-schema-02 # see: http://json-schema.org/ @@ -55,8 +59,10 @@ sub get_standard_option { register_standard_option('pve-vmid', { description => "The (unique) ID of the VM.", - type => 'integer', format => 'pve-vmid', - minimum => 1 + type => 'integer', + format => 'pve-vmid', + minimum => 100, + maximum => 999_999_999, }); register_standard_option('pve-node', { @@ -78,13 +84,23 @@ register_standard_option('pve-iface', { register_standard_option('pve-storage-id', { description => "The storage identifier.", type => 'string', format => 'pve-storage-id', + format_description => 'storage ID', +}); + +register_standard_option('pve-bridge-id', { + description => "Bridge to attach guest network devices to.", + type => 'string', format => 'pve-bridge-id', + format_description => 'bridge', }); register_standard_option('pve-config-digest', { - description => 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.', + description => 'Prevent changes if current configuration file has a different digest. ' + . 'This can be used to prevent concurrent modifications.', type => 'string', optional => 1, - maxLength => 40, # sha1 hex digest length is 40 + # sha1 hex digests are 40 characters long + # sha256 hex digests are 64 characters long (sha256 is used in our Rust code) + maxLength => 64, }); register_standard_option('skiplock', { @@ -177,7 +193,7 @@ register_format('pve-configid', \&pve_verify_configid); sub pve_verify_configid { my ($id, $noerr) = @_; - if ($id !~ m/^[a-z][a-z0-9_-]+$/i) { + if ($id !~ m/^$CONFIGID_RE$/) { return undef if $noerr; die "invalid configuration ID '$id'\n"; } @@ -191,6 +207,17 @@ sub parse_storage_id { return parse_id($storeid, 'storage', $noerr); } +PVE::JSONSchema::register_format('pve-bridge-id', \&parse_bridge_id); +sub parse_bridge_id { + my ($id, $noerr) = @_; + + if ($id !~ m/^[-_.\w\d]+$/) { + return undef if $noerr; + die "invalid bridge ID '$id'\n"; + } + return $id; +} + PVE::JSONSchema::register_format('acme-plugin-id', \&parse_acme_plugin_id); sub parse_acme_plugin_id { my ($pluginid, $noerr) = @_; @@ -230,6 +257,21 @@ sub pve_verify_node_name { return $node; } +# maps source to target ID using an ID map +sub map_id { + my ($map, $source) = @_; + + return $source if !defined($map); + + return $map->{entries}->{$source} + if $map->{entries} && defined($map->{entries}->{$source}); + + return $map->{default} if $map->{default}; + + # identity (fallback) + return $source; +} + sub parse_idmap { my ($idmap, $idformat) = @_; @@ -271,20 +313,41 @@ sub parse_idmap { return $map; } -register_format('storagepair', \&verify_storagepair); -sub verify_storagepair { - my ($storagepair, $noerr) = @_; +my $verify_idpair = sub { + my ($input, $noerr, $format) = @_; - # note: this only checks a single list entry - # when using a storagepair-list map, you need to pass the full - # parameter to parse_idmap - eval { parse_idmap($storagepair, 'pve-storage-id') }; + eval { parse_idmap($input, $format) }; if ($@) { return undef if $noerr; die "$@\n"; } - return $storagepair; + return $input; +}; + +PVE::JSONSchema::register_standard_option('pve-targetstorage', { + description => "Mapping from source to target storages. Providing only a single storage ID maps all source storages to that storage. Providing the special value '1' will map each source storage to itself.", + type => 'string', + format => 'storage-pair-list', + optional => 1, +}); + +# note: this only checks a single list entry +# when using a storage-pair-list map, you need to pass the full parameter to +# parse_idmap +register_format('storage-pair', \&verify_storagepair); +sub verify_storagepair { + my ($storagepair, $noerr) = @_; + return $verify_idpair->($storagepair, $noerr, 'pve-storage-id'); +} + +# note: this only checks a single list entry +# when using a bridge-pair-list map, you need to pass the full parameter to +# parse_idmap +register_format('bridge-pair', \&verify_bridgepair); +sub verify_bridgepair { + my ($bridgepair, $noerr) = @_; + return $verify_idpair->($bridgepair, $noerr, 'pve-bridge-id'); } register_format('mac-addr', \&pve_verify_mac_addr); @@ -469,13 +532,25 @@ register_format('email', \&pve_verify_email); sub pve_verify_email { my ($email, $noerr) = @_; - if ($email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/) { + if ($email !~ /^$PVE::Tools::EMAIL_RE$/) { return undef if $noerr; die "value does not look like a valid email address\n"; } return $email; } +register_format('email-or-username', \&pve_verify_email_or_username); +sub pve_verify_email_or_username { + my ($email, $noerr) = @_; + + if ($email !~ /^$PVE::Tools::EMAIL_RE$/ && + $email !~ /^$PVE::Tools::EMAIL_USER_RE$/) { + return undef if $noerr; + die "value does not look like a valid email address or user name\n"; + } + return $email; +} + register_format('dns-name', \&pve_verify_dns_name); sub pve_verify_dns_name { my ($name, $noerr) = @_; @@ -602,18 +677,52 @@ my $bwlimit_format = { }; register_format('bwlimit', $bwlimit_format); register_standard_option('bwlimit', { - description => "Set bandwidth/io limits various operations.", + description => "Set I/O bandwidth limit for various operations (in KiB/s).", optional => 1, type => 'string', format => $bwlimit_format, }); +my $remote_format = { + host => { + type => 'string', + description => 'Remote Proxmox hostname or IP', + format_description => 'ADDRESS', + }, + port => { + type => 'integer', + optional => 1, + description => 'Port to connect to', + format_description => 'PORT', + }, + apitoken => { + type => 'string', + description => 'A full Proxmox API token including the secret value.', + format_description => 'PVEAPIToken=user@realm!token=SECRET', + }, + fingerprint => get_standard_option( + 'fingerprint-sha256', + { + optional => 1, + description => 'Remote host\'s certificate fingerprint, if not trusted by system store.', + format_description => 'FINGERPRINT', + } + ), +}; +register_format('proxmox-remote', $remote_format); +register_standard_option('proxmox-remote', { + description => "Specification of a remote endpoint.", + type => 'string', format => 'proxmox-remote', +}); + +our $PVE_TAG_RE = qr/[a-z0-9_][a-z0-9_\-\+\.]*/i; + # used for pve-tag-list in e.g., guest configs register_format('pve-tag', \&pve_verify_tag); sub pve_verify_tag { my ($value, $noerr) = @_; - return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i; + return $value if $value =~ m/^${PVE_TAG_RE}$/i; return undef if $noerr; @@ -670,6 +779,18 @@ sub pve_verify_tfa_secret { die "unable to decode TFA secret\n"; } + +PVE::JSONSchema::register_format('pve-task-status-type', \&verify_task_status_type); +sub verify_task_status_type { + my ($value, $noerr) = @_; + + return $value if $value =~ m/^(ok|error|warning|unknown)$/i; + + return undef if $noerr; + + die "invalid status '$value'\n"; +} + sub check_format { my ($format, $value, $path) = @_; @@ -686,7 +807,7 @@ sub check_format { return if $format eq 'regex'; my $parsed; - $format =~ m/^(.*?)(?:-a?(list|opt))?$/; + $format =~ m/^(.*?)(?:-(list|opt))?$/; my ($format_name, $format_type) = ($1, $2 // 'none'); my $registered = get_format($format_name); die "undefined format '$format'\n" if !$registered; @@ -695,13 +816,14 @@ sub check_format { if $format_type ne 'none' && ref($registered) ne 'CODE'; if ($format_type eq 'list') { + $parsed = []; # Note: we allow empty lists foreach my $v (split_list($value)) { - $parsed = $registered->($v); + push @{$parsed}, $registered->($v); } } elsif ($format_type eq 'opt') { $parsed = $registered->($value) if $value; - } else { + } else { if (ref($registered) eq 'HASH') { # Note: this is the only case where a validator function could be # attached, hence it's safe to handle that in parse_property_string. @@ -930,6 +1052,9 @@ sub check_type { return 1; } else { if ($vt) { + if ($type eq 'boolean' && JSON::is_bool($value)) { + return 1; + } add_error($errors, $path, "type check ('$type') failed - got $vt"); return undef; } else { @@ -968,6 +1093,16 @@ sub check_type { return undef; } +my sub get_instance_type { + my ($schema, $key, $value) = @_; + + if (my $type_property = $schema->{$key}->{'type-property'}) { + return $value->{$type_property}; + } + + return undef; +} + sub check_object { my ($path, $schema, $value, $additional_properties, $errors) = @_; @@ -986,7 +1121,8 @@ sub check_object { } foreach my $k (keys %$schema) { - check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors); + my $instance_type = get_instance_type($schema, $k, $value); + check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors, $instance_type); } foreach my $k (keys %$value) { @@ -1004,7 +1140,23 @@ sub check_object { } } - next; # value is already checked above + # if it's a oneOf, check if there is a matching type + my $matched_type = 1; + if ($subschema->{oneOf}) { + my $instance_type = get_instance_type($schema, $k, $value); + $matched_type = 0; + for my $alternative ($subschema->{oneOf}->@*) { + if (my $instance_types = $alternative->{'instance-types'}) { + if (!grep { $instance_type eq $_ } $instance_types->@*) { + next; + } + } + $matched_type = 1; + last; + } + } + + next if $matched_type; # value is already checked above } if (defined ($additional_properties) && !$additional_properties) { @@ -1031,7 +1183,7 @@ sub check_object_warn { } sub check_prop { - my ($value, $schema, $path, $errors) = @_; + my ($value, $schema, $path, $errors, $instance_type) = @_; die "internal error - no schema" if !$schema; die "internal error" if !$errors; @@ -1044,6 +1196,58 @@ sub check_prop { return; } + # must pass any of the given schemas + my $optional_for_type = 0; + if ($schema->{oneOf}) { + # in case we have an instance_type given, just check for that variant + if ($schema->{'type-property'}) { + $optional_for_type = 1; + for (my $i = 0; $i < scalar($schema->{oneOf}->@*); $i++) { + last if !$instance_type; # treat as optional if we don't have a type + my $inner_schema = $schema->{oneOf}->[$i]; + + if (!defined($inner_schema->{'instance-types'})) { + add_error($errors, $path, "missing 'instance-types' in oneOf alternative"); + return; + } + + next if !grep { $_ eq $instance_type } $inner_schema->{'instance-types'}->@*; + $optional_for_type = $inner_schema->{optional} // 0; + check_prop($value, $inner_schema, $path, $errors); + } + } else { + my $is_valid = 0; + my $collected_errors = {}; + for (my $i = 0; $i < scalar($schema->{oneOf}->@*); $i++) { + my $inner_schema = $schema->{oneOf}->[$i]; + my $inner_errors = {}; + check_prop($value, $inner_schema, "$path.oneOf[$i]", $inner_errors); + if (!$inner_errors->%*) { + $is_valid = 1; + last; + } + + for my $inner_path (keys $inner_errors->%*) { + add_error($collected_errors, $inner_path, $inner_errors->{$path}); + } + } + + if (!$is_valid) { + for my $inner_path (keys $collected_errors->%*) { + add_error($errors, $inner_path, $collected_errors->{$path}); + } + } + } + } elsif ($instance_type) { + if (!defined($schema->{'instance-types'})) { + add_error($errors, $path, "missing 'instance-types'"); + return; + } + if (grep { $_ eq $instance_type} $schema->{'instance_types'}->@*) { + $optional_for_type = 1; + } + } + # if it extends another schema, it must pass that schema as well if($schema->{extends}) { check_prop($value, $schema->{extends}, $path, $errors); @@ -1051,7 +1255,7 @@ sub check_prop { if (!defined ($value)) { return if $schema->{type} && $schema->{type} eq 'null'; - if (!$schema->{optional} && !$schema->{alias} && !$schema->{group}) { + if (!$schema->{optional} && !$schema->{alias} && !$schema->{group} && !$optional_for_type) { add_error($errors, $path, "property is missing and it is not optional"); } return; @@ -1164,7 +1368,10 @@ sub validate { # we can disable that in the final release # todo: is there a better/faster way to detect cycles? my $cycles = 0; - find_cycle($instance, sub { $cycles = 1 }); + # 'download' responses can contain a filehandle, don't cycle-check that as + # it produces a warning + my $is_download = ref($instance) eq 'HASH' && exists($instance->{download}); + find_cycle($instance, sub { $cycles = 1 }) if !$is_download; if ($cycles) { add_error($errors, undef, "data structure contains recursive cycles"); } elsif ($schema) { @@ -1195,6 +1402,28 @@ my $default_schema_noref = { }, enum => $schema_valid_types, }, + oneOf => { + type => 'array', + description => "This represents the alternative options for this Schema instance.", + optional => 1, + items => { + type => 'object', + description => "A valid option of the properties", + }, + }, + 'instance-types' => { + type => 'array', + description => "Indicate to which type the parameter (or variant if inside a oneOf) belongs.", + optional => 1, + items => { + type => 'string', + }, + }, + 'type-property' => { + type => 'string', + description => "The property to check for instance types.", + optional => 1, + }, optional => { type => "boolean", description => "This indicates that the instance property in the instance object is not required.", @@ -1369,6 +1598,7 @@ my $default_schema = Storable::dclone($default_schema_noref); $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema; $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties}; +$default_schema->{properties}->{oneOf}->{items}->{properties} = $default_schema->{properties}; $default_schema->{properties}->{items}->{properties} = $default_schema->{properties}; $default_schema->{properties}->{items}->{additionalProperties} = 0; @@ -1591,10 +1821,12 @@ sub get_options { # optional and call the mapping function afterwards. push @getopt, "$prop:s"; push @interactive, [$prop, $mapping->{func}]; - } elsif ($pd->{type} eq 'boolean') { + } elsif ($pd->{type} && $pd->{type} eq 'boolean') { push @getopt, "$prop:s"; } else { - if ($pd->{format} && $pd->{format} =~ m/-a?list/) { + if ($pd->{format} && $pd->{format} =~ m/-list/) { + push @getopt, "$prop=s@"; + } elsif ($pd->{type} && $pd->{type} eq 'array') { push @getopt, "$prop=s@"; } else { push @getopt, "$prop=s"; @@ -1626,11 +1858,15 @@ sub get_options { if (!@$args) { # check if all left-over arg_param are optional, else we # must die as the mapping is then ambigious - for (my $j = $i; $j < scalar(@$arg_param); $j++) { - my $prop = $arg_param->[$j]; + for (; $i < scalar(@$arg_param); $i++) { + my $prop = $arg_param->[$i]; raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !$schema->{properties}->{$prop}->{optional}; } + if ($arg_param->[-1] eq 'extra-args') { + $opts->{'extra-args'} = []; + } + last; } $opts->{$arg_name} = shift @$args; } @@ -1679,7 +1915,7 @@ sub get_options { foreach my $p (keys %$opts) { if (my $pd = $schema->{properties}->{$p}) { - if ($pd->{type} eq 'boolean') { + if ($pd->{type} && $pd->{type} eq 'boolean') { if ($opts->{$p} eq '') { $opts->{$p} = 1; } elsif (defined(my $bool = parse_boolean($opts->{$p}))) { @@ -1693,16 +1929,6 @@ sub get_options { # allow --vmid 100 --vmid 101 and --vmid 100,101 # allow --dow mon --dow fri and --dow mon,fri $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY'; - } elsif ($pd->{format} =~ m/-alist/) { - # we encode array as \0 separated strings - # Note: CGI.pm also use this encoding - if (scalar(@{$opts->{$p}}) != 1) { - $opts->{$p} = join("\0", @{$opts->{$p}}); - } else { - # st that split_list knows it is \0 terminated - my $v = $opts->{$p}->[0]; - $opts->{$p} = "$v\0"; - } } } } @@ -1716,8 +1942,8 @@ sub get_options { } # A way to parse configuration data by giving a json schema -sub parse_config { - my ($schema, $filename, $raw) = @_; +sub parse_config : prototype($$$;$) { + my ($schema, $filename, $raw, $comment_key) = @_; # do fast check (avoid validate_schema($schema)) die "got strange schema" if !$schema->{type} || @@ -1725,10 +1951,24 @@ sub parse_config { my $cfg = {}; + my $comment_data; + my $handle_comment = sub { $_[0] =~ /^#/ }; + if (defined($comment_key)) { + $comment_data = ''; + my $comment_re = qr/^\Q$comment_key\E:\s*(.*\S)\s*$/; + $handle_comment = sub { + if ($_[0] =~ /^\#(.*)\s*$/ || $_[0] =~ $comment_re) { + $comment_data .= PVE::Tools::decode_text($1) . "\n"; + return 1; + } + return undef; + }; + } + while ($raw =~ /^\s*(.+?)\s*$/gm) { my $line = $1; - next if $line =~ /^#/; + next if $handle_comment->($line); if ($line =~ m/^(\S+?):\s*(.*)$/) { my $key = $1; @@ -1738,12 +1978,25 @@ sub parse_config { $value = parse_boolean($value) // $value; } + if ( + $schema->{properties}->{$key} + && $schema->{properties}->{$key}->{type} eq 'array' + ) { + + $cfg->{$key} //= []; + push $cfg->{$key}->@*, $value; + next; + } $cfg->{$key} = $value; } else { warn "ignore config line: $line\n" } } + if (defined($comment_data)) { + $cfg->{$comment_key} = $comment_data; + } + my $errors = {}; check_prop($cfg, $schema, '', $errors); diff --git a/src/PVE/Job/Registry.pm b/src/PVE/Job/Registry.pm new file mode 100644 index 0000000..32e0272 --- /dev/null +++ b/src/PVE/Job/Registry.pm @@ -0,0 +1,113 @@ +package PVE::Job::Registry; + +use strict; +use warnings; + +# The job (config) base class, normally you would use this in one of two variants: +# +# 1) base of directly in manager and handle everything there; great for stuff that isn't residing +# outside of the manager, so that there is no cyclic dependency (forbidden!) required +# +# 2) use two (or even more) classes, one in the library (e.g., guest-common, access-control, ...) +# basing off this module, providing the basic config implementation. Then one in pve-manager +# (where every dependency is available) basing off the intermediate config one, that then holds +# the implementation of the 'run` method and is used in the job manager + +use base qw(PVE::SectionConfig); + +my $defaultData = { + propertyList => { + type => { description => "Section type." }, + # FIXME: remove below? this is the section ID, schema would only be checked if a plugin + # declares this as explicit option, which isn't really required as its available anyway.. + id => { + description => "The ID of the job.", + type => 'string', + format => 'pve-configid', + maxLength => 64, + }, + enabled => { + description => "Determines if the job is enabled.", + type => 'boolean', + default => 1, + optional => 1, + }, + schedule => { + description => "Backup schedule. The format is a subset of `systemd` calendar events.", + type => 'string', format => 'pve-calendar-event', + maxLength => 128, + }, + comment => { + optional => 1, + type => 'string', + description => "Description for the Job.", + maxLength => 512, + }, + 'repeat-missed' => { + optional => 1, + type => 'boolean', + description => "If true, the job will be run as soon as possible if it was missed". + " while the scheduler was not running.", + default => 0, + }, + }, +}; + +sub private { + return $defaultData; +} + +sub parse_config { + my ($class, $filename, $raw, $allow_unknown) = @_; + + my $cfg = $class->SUPER::parse_config($filename, $raw, $allow_unknown); + + for my $id (keys %{$cfg->{ids}}) { + my $data = $cfg->{ids}->{$id}; + my $type = $data->{type}; + + # FIXME: below id injection is gross, guard to avoid breaking plugins that don't declare id + # as option; *iff* we want this it should be handled by section config directly. + if ($defaultData->{options}->{$type} && exists $defaultData->{options}->{$type}->{id}) { + $data->{id} = $id; + } + $data->{enabled} //= 1; + + $data->{comment} = PVE::Tools::decode_text($data->{comment}) if defined($data->{comment}); + } + + return $cfg; +} + +# call the plugin specific decode/encode code +sub decode_value { + my ($class, $type, $key, $value) = @_; + + my $plugin = __PACKAGE__->lookup($type); + return $plugin->decode_value($type, $key, $value); +} + +sub encode_value { + my ($class, $type, $key, $value) = @_; + + my $plugin = __PACKAGE__->lookup($type); + return $plugin->encode_value($type, $key, $value); +} + +sub write_config { + my ($class, $filename, $cfg, $allow_unknown) = @_; + + for my $job (values $cfg->{ids}->%*) { + $job->{comment} = PVE::Tools::encode_text($job->{comment}) if defined($job->{comment}); + } + + $class->SUPER::write_config($filename, $cfg, $allow_unknown); +} + +sub run { + my ($class, $cfg) = @_; + + die "not implemented"; # implement in subclass +} + +1; diff --git a/src/PVE/LDAP.pm b/src/PVE/LDAP.pm index ff98e36..16a0a8e 100644 --- a/src/PVE/LDAP.pm +++ b/src/PVE/LDAP.pm @@ -22,7 +22,6 @@ sub ldap_connect { scheme => $scheme, port => $port, timeout => 10, - onerror => 'die', ); my $hosts = []; @@ -41,7 +40,8 @@ sub ldap_connect { my $ldap = Net::LDAP->new($hosts, %ldap_opts) || die "$@\n"; if ($start_tls) { - $ldap->start_tls(%$opts); + my $res = $ldap->start_tls(%$opts); + die $res->error . "\n" if $res->code; } return $ldap; @@ -73,6 +73,7 @@ sub get_user_dn { filter => "$attr=$name", attrs => ['dn'] ); + die $result->error . "\n" if $result->code; return undef if !$result->entries; my @entries = $result->entries; return $entries[0]->dn; @@ -80,6 +81,12 @@ sub get_user_dn { sub auth_user_dn { my ($ldap, $dn, $pw, $noerr) = @_; + + if (!$dn) { + return undef if $noerr; + die "user dn is empty\n"; + } + my $res = $ldap->bind($dn, password => $pw); my $code = $res->code; @@ -87,7 +94,7 @@ sub auth_user_dn { if ($code) { return undef if $noerr; - die $err; + die "$err\n"; } return 1; @@ -178,7 +185,7 @@ sub query_users { $err = "LDAP user query unsuccessful" if !$err; } - die $err if $err; + die "$err\n" if $err; return $users; } @@ -259,7 +266,7 @@ sub query_groups { $err = "LDAP group query unsuccessful" if !$err; } - die $err if $err; + die "$err\n" if $err; return $groups; } diff --git a/src/PVE/Network.pm b/src/PVE/Network.pm index 12536c7..a4f5ba9 100644 --- a/src/PVE/Network.pm +++ b/src/PVE/Network.pm @@ -9,13 +9,15 @@ use PVE::Tools qw(run_command lock_file); use File::Basename; use IO::Socket::IP; +use JSON; use Net::IP; +use NetAddr::IP qw(:lower); use POSIX qw(ECONNREFUSED); use Socket qw(NI_NUMERICHOST NI_NUMERICSERV); # host network related utility functions -our $PHYSICAL_NIC_RE = qr/(?:eth\d+|en[^:.]+|ib\d+)/; +our $PHYSICAL_NIC_RE = qr/(?:eth\d+|en[^:.]+|ib[^:.]+)/; our $ipv4_reverse_mask = [ '0.0.0.0', @@ -100,10 +102,10 @@ sub setup_tc_rate_limit { "htb rate ${rate}bps burst ${burst}b"); run_command("/sbin/tc qdisc add dev $iface handle ffff: ingress"); - run_command("/sbin/tc filter add dev $iface parent ffff: " . - "prio 50 basic " . - "police rate ${rate}bps burst ${burst}b mtu 64kb " . - "drop"); + run_command( + "/sbin/tc filter add dev $iface parent ffff: prio 50 basic police rate ${rate}bps burst ${burst}b mtu 64kb drop"); + + return; } sub tap_rate_limit { @@ -113,6 +115,8 @@ sub tap_rate_limit { my $burst = 1024*1024; setup_tc_rate_limit($iface, $rate, $burst); + + return; } sub read_bridge_mtu { @@ -120,12 +124,15 @@ sub read_bridge_mtu { my $mtu = PVE::Tools::file_read_firstline("/sys/class/net/$bridge/mtu"); die "bridge '$bridge' does not exist\n" if !$mtu; - # avoid insecure dependency; - die "unable to parse mtu value" if $mtu !~ /^(\d+)$/; - $mtu = int($1); + + if ($mtu =~ /^(\d+)$/) { # avoid insecure dependency (untaint) + $mtu = int($1); + } else { + die "unexpeted error: unable to parse mtu value '$mtu' as integer\n"; + } return $mtu; -}; +} my $parse_tap_device_name = sub { my ($iface, $noerr) = @_; @@ -139,7 +146,7 @@ my $parse_tap_device_name = sub { $vmid = $1; $devid = $2; } else { - return undef if $noerr; + return if $noerr; die "can't create firewall bridge for random interface name '$iface'\n"; } @@ -158,26 +165,29 @@ my $compute_fwbr_names = sub { return ($fwbr, $vethfw, $vethfwpeer, $ovsintport); }; -sub iface_delete($) { +sub iface_delete :prototype($) { my ($iface) = @_; run_command(['/sbin/ip', 'link', 'delete', 'dev', $iface], noerr => 1) == 0 or die "failed to delete interface '$iface'\n"; + return; } -sub iface_create($$@) { +sub iface_create :prototype($$@) { my ($iface, $type, @args) = @_; run_command(['/sbin/ip', 'link', 'add', $iface, 'type', $type, @args], noerr => 1) == 0 or die "failed to create interface '$iface'\n"; + return; } -sub iface_set($@) { +sub iface_set :prototype($@) { my ($iface, @opts) = @_; run_command(['/sbin/ip', 'link', 'set', $iface, @opts], noerr => 1) == 0 or die "failed to set interface options for '$iface' (".join(' ', @opts).")\n"; + return; } # helper for nicer error messages: -sub iface_set_master($$) { +sub iface_set_master :prototype($$) { my ($iface, $master) = @_; if (defined($master)) { eval { iface_set($iface, 'master', $master) }; @@ -186,6 +196,7 @@ sub iface_set_master($$) { eval { iface_set($iface, 'nomaster') }; die "can't unenslave '$iface'\n" if $@; } + return; } my $cond_create_bridge = sub { @@ -199,16 +210,28 @@ my $cond_create_bridge = sub { sub disable_ipv6 { my ($iface) = @_; - return if !-d '/proc/sys/net/ipv6'; # ipv6 might be completely disabled my $file = "/proc/sys/net/ipv6/conf/$iface/disable_ipv6"; + return if !-e $file; # ipv6 might be completely disabled open(my $fh, '>', $file) or die "failed to open $file for writing: $!\n"; print {$fh} "1\n" or die "failed to disable link-local ipv6 for $iface\n"; close($fh); + return; } +my $bridge_disable_interface_learning = sub { + my ($iface) = @_; + + PVE::ProcFSTools::write_proc_entry("/sys/class/net/$iface/brport/unicast_flood", "0"); + PVE::ProcFSTools::write_proc_entry("/sys/class/net/$iface/brport/learning", "0"); + +}; + my $bridge_add_interface = sub { my ($bridge, $iface, $tag, $trunks) = @_; + my $bridgemtu = read_bridge_mtu($bridge); + eval { run_command(['/sbin/ip', 'link', 'set', $iface, 'mtu', $bridgemtu]) }; + # drop link local address (it can't be used when on a bridge anyway) disable_ipv6($iface); iface_set_master($iface, $bridge); @@ -249,6 +272,9 @@ my $ovs_bridge_add_port = sub { push @$cmd, "trunks=". join(',', $trunks) if $trunks; push @$cmd, "vlan_mode=native-untagged" if $tag && $trunks; + my $bridgemtu = read_bridge_mtu($bridge); + push @$cmd, '--', 'set', 'Interface', $iface, "mtu_request=$bridgemtu"; + if ($internal) { # second command push @$cmd, '--', 'set', 'Interface', $iface, 'type=internal'; @@ -261,12 +287,55 @@ my $ovs_bridge_add_port = sub { }; my $activate_interface = sub { - my ($iface) = @_; + my ($iface, $mtu) = @_; - eval { run_command(['/sbin/ip', 'link', 'set', $iface, 'up']) }; + my $cmd = ['/sbin/ip', 'link', 'set', $iface, 'up']; + push @$cmd, ('mtu', $mtu) if $mtu; + + eval { run_command($cmd) }; die "can't activate interface '$iface' - $@\n" if $@; }; +sub add_bridge_fdb { + my ($iface, $mac) = @_; + + my $learning = PVE::Tools::file_read_firstline("/sys/class/net/$iface/brport/learning"); + return if !defined($learning) || $learning == 1; + + my ($vmid, $devid) = &$parse_tap_device_name($iface, 1); + return if !defined($vmid); + + run_command(['/sbin/bridge', 'fdb', 'append', $mac, 'dev', $iface, 'master', 'static']); + + my ($fwbr, $vethfw, $vethfwpeer, $ovsintport) = &$compute_fwbr_names($vmid, $devid); + + if (-d "/sys/class/net/$vethfwpeer") { + run_command(['/sbin/bridge', 'fdb', 'append', $mac, 'dev', $vethfwpeer, 'master', 'static']); + } + + return; +} + +sub del_bridge_fdb { + my ($iface, $mac) = @_; + + my $learning = PVE::Tools::file_read_firstline("/sys/class/net/$iface/brport/learning"); + return if !defined($learning) || $learning == 1; + + my ($vmid, $devid) = &$parse_tap_device_name($iface, 1); + return if !defined($vmid); + + run_command(['/sbin/bridge', 'fdb', 'del', $mac, 'dev', $iface, 'master', 'static']); + + my ($fwbr, $vethfw, $vethfwpeer, $ovsintport) = &$compute_fwbr_names($vmid, $devid); + + if (-d "/sys/class/net/$vethfwpeer") { + run_command(['/sbin/bridge', 'fdb', 'del', $mac, 'dev', $vethfwpeer, 'master', 'static']); + } + + return; +} + sub tap_create { my ($iface, $bridge) = @_; @@ -276,9 +345,10 @@ sub tap_create { eval { disable_ipv6($iface); - PVE::Tools::run_command(['/sbin/ip', 'link', 'set', $iface, 'up', 'promisc', 'on', 'mtu', $bridgemtu]); + run_command(['/sbin/ip', 'link', 'set', $iface, 'up', 'promisc', 'on', 'mtu', $bridgemtu]); }; die "interface activation failed\n" if $@; + return; } sub veth_create { @@ -307,8 +377,10 @@ sub veth_create { # up vethpair disable_ipv6($veth); disable_ipv6($vethpeer); - &$activate_interface($veth); - &$activate_interface($vethpeer); + &$activate_interface($veth, $bridgemtu); + &$activate_interface($vethpeer, $bridgemtu); + + return; } sub veth_delete { @@ -318,28 +390,32 @@ sub veth_delete { iface_delete($veth); } eval { tap_unplug($veth) }; + return; } my $create_firewall_bridge_linux = sub { - my ($iface, $bridge, $tag, $trunks) = @_; + my ($iface, $bridge, $tag, $trunks, $no_learning) = @_; my ($vmid, $devid) = &$parse_tap_device_name($iface); my ($fwbr, $vethfw, $vethfwpeer) = &$compute_fwbr_names($vmid, $devid); + my $bridgemtu = read_bridge_mtu($bridge); + &$cond_create_bridge($fwbr); - &$activate_interface($fwbr); + &$activate_interface($fwbr, $bridgemtu); copy_bridge_config($bridge, $fwbr); veth_create($vethfw, $vethfwpeer, $bridge); - &$bridge_add_interface($fwbr, $vethfw); &$bridge_add_interface($bridge, $vethfwpeer, $tag, $trunks); + &$bridge_disable_interface_learning($vethfwpeer) if $no_learning; + &$bridge_add_interface($fwbr, $vethfw); &$bridge_add_interface($fwbr, $iface); }; my $create_firewall_bridge_ovs = sub { - my ($iface, $bridge, $tag, $trunks) = @_; + my ($iface, $bridge, $tag, $trunks, $no_learning) = @_; my ($vmid, $devid) = &$parse_tap_device_name($iface); my ($fwbr, undef, undef, $ovsintport) = &$compute_fwbr_names($vmid, $devid); @@ -347,17 +423,15 @@ my $create_firewall_bridge_ovs = sub { my $bridgemtu = read_bridge_mtu($bridge); &$cond_create_bridge($fwbr); - &$activate_interface($fwbr); + &$activate_interface($fwbr, $bridgemtu); &$bridge_add_interface($fwbr, $iface); &$ovs_bridge_add_port($bridge, $ovsintport, $tag, 1, $trunks); - &$activate_interface($ovsintport); - - # set the same mtu for ovs int port - PVE::Tools::run_command(['/sbin/ip', 'link', 'set', $ovsintport, 'mtu', $bridgemtu]); + &$activate_interface($ovsintport, $bridgemtu); &$bridge_add_interface($fwbr, $ovsintport); + &$bridge_disable_interface_learning($ovsintport) if $no_learning; }; my $cleanup_firewall_bridge = sub { @@ -382,10 +456,23 @@ my $cleanup_firewall_bridge = sub { }; sub tap_plug { - my ($iface, $bridge, $tag, $firewall, $trunks, $rate) = @_; + my ($iface, $bridge, $tag, $firewall, $trunks, $rate, $opts) = @_; - #cleanup old port config from any openvswitch bridge - eval {run_command("/usr/bin/ovs-vsctl del-port $iface", outfunc => sub {}, errfunc => sub {}) }; + $opts = {} if !defined($opts); + $opts = { learning => $opts } if !ref($opts); # FIXME: backward compat, drop with PVE 8.0 + + if (!defined($opts->{learning})) { # auto-detect + $opts = {} if !defined($opts); + my $interfaces_config = PVE::INotify::read_file('interfaces'); + my $bridge = $interfaces_config->{ifaces}->{$bridge}; + $opts->{learning} = !($bridge && $bridge->{'bridge-disable-mac-learning'}); # default learning to on + } + my $no_learning = !$opts->{learning}; + + # cleanup old port config from any openvswitch bridge + eval { + run_command("/usr/bin/ovs-vsctl del-port $iface", outfunc => sub {}, errfunc => sub {}); + }; if (-d "/sys/class/net/$bridge/bridge") { &$cleanup_firewall_bridge($iface); # remove stale devices @@ -401,28 +488,34 @@ sub tap_plug { } if ($firewall) { - &$create_firewall_bridge_linux($iface, $bridge, $tag, $trunks); + &$create_firewall_bridge_linux($iface, $bridge, $tag, $trunks, $no_learning); } else { &$bridge_add_interface($bridge, $iface, $tag, $trunks); } + if ($no_learning) { + $bridge_disable_interface_learning->($iface); + add_bridge_fdb($iface, $opts->{mac}) if defined($opts->{mac}); + } } else { &$cleanup_firewall_bridge($iface); # remove stale devices if ($firewall) { - &$create_firewall_bridge_ovs($iface, $bridge, $tag, $trunks); + &$create_firewall_bridge_ovs($iface, $bridge, $tag, $trunks, $no_learning); } else { &$ovs_bridge_add_port($bridge, $iface, $tag, undef, $trunks); } } tap_rate_limit($iface, $rate); + + return; } sub tap_unplug { my ($iface) = @_; - my $path= "/sys/class/net/$iface/brport/bridge"; + my $path = "/sys/class/net/$iface/brport/bridge"; if (-l $path) { my $bridge = basename(readlink($path)); #avoid insecure dependency; @@ -433,7 +526,9 @@ sub tap_unplug { &$cleanup_firewall_bridge($iface); #cleanup old port config from any openvswitch bridge - eval {run_command("/usr/bin/ovs-vsctl del-port $iface", outfunc => sub {}, errfunc => sub {}) }; + eval { run_command("/usr/bin/ovs-vsctl del-port $iface", outfunc => sub {}, errfunc => sub {}) }; + + return; } sub copy_bridge_config { @@ -441,8 +536,10 @@ sub copy_bridge_config { return if $br0 eq $br1; - my $br_configs = [ 'ageing_time', 'stp_state', 'priority', 'forward_delay', - 'hello_time', 'max_age', 'multicast_snooping', 'multicast_querier']; + my $br_configs = [ + 'ageing_time', 'stp_state', 'priority', 'forward_delay', + 'hello_time', 'max_age', 'multicast_snooping', 'multicast_querier', + ]; foreach my $sysname (@$br_configs) { eval { @@ -454,6 +551,7 @@ sub copy_bridge_config { }; warn $@ if $@; } + return; } sub activate_bridge_vlan_slave { @@ -492,6 +590,7 @@ sub activate_bridge_vlan_slave { # add $ifacevlan to the bridge &$bridge_add_interface($bridgevlan, $ifacevlan); + return; } sub activate_bridge_vlan { @@ -521,6 +620,9 @@ sub activate_bridge_vlan { iface_create($bridgevlan, 'bridge'); } + my $bridgemtu = read_bridge_mtu($bridge); + eval { run_command(['/sbin/ip', 'link', 'set', $bridgevlan, 'mtu', $bridgemtu]) }; + # for each physical interface (eth or bridge) bind them to bridge vlan foreach my $iface (@ifaces) { activate_bridge_vlan_slave($bridgevlan, $iface, $tag); @@ -567,8 +669,7 @@ sub tcp_ping { sub IP_from_cidr { my ($cidr, $version) = @_; - return if $cidr !~ m!^(\S+?)/(\S+)$!; - my ($ip, $prefix) = ($1, $2); + my ($ip, $prefix) = $cidr =~ m!^(\S+?)/(\S+)$! or return; my $ipobj = Net::IP->new($ip, $version); return if !$ipobj; @@ -587,26 +688,108 @@ sub is_ip_in_cidr { my ($ip, $cidr, $version) = @_; my $cidr_obj = IP_from_cidr($cidr, $version); - return undef if !$cidr_obj; + return if !$cidr_obj; my $ip_obj = Net::IP->new($ip, $version); - return undef if !$ip_obj; + return if !$ip_obj; + + my $overlap = $cidr_obj->overlaps($ip_obj); + return if !defined($overlap); + + return $overlap == $Net::IP::IP_B_IN_A_OVERLAP || $overlap == $Net::IP::IP_IDENTICAL; +} + +# get all currently configured addresses that have a global scope, i.e., are reachable from the +# outside of the host and thus are neither loopback nor link-local ones +# returns an array ref of: { addr => "IP", cidr => "IP/PREFIXLEN", family => "inet|inet6" } +sub get_reachable_networks { + my $raw = ''; + run_command([qw(ip -j addr show up scope global)], outfunc => sub { $raw .= shift }); + my $decoded = decode_json($raw); + + my $addrs = []; # filter/transform first so that we can sort correctly more easily below + for my $e ($decoded->@*) { + next if !$e->{addr_info} || grep { $_ eq 'LOOPBACK' } $e->{flags}->@*; + push $addrs->@*, grep { scalar(keys $_->%*) } $e->{addr_info}->@* + } + my $res = []; + for my $info (sort { $a->{family} cmp $b->{family} || $a->{local} cmp $b->{local} } $addrs->@*) { + push $res->@*, { + addr => $info->{local}, + cidr => "$info->{local}/$info->{prefixlen}", + family => $info->{family}, + }; + } - return $cidr_obj->overlaps($ip_obj) == $Net::IP::IP_B_IN_A_OVERLAP; + return $res; } +# get one or all local IPs that are not loopback ones, able to pick up the following ones (in order) +# - the hostname primary resolves too, follows gai.conf (admin controlled) and will be prioritised +# - all configured in the interfaces configuration +# - all currently networks known to the kernel in the current (root) namespace +# returns a single address if no parameter is passed, and all found, grouped by type, if `all => 1` +# is passed. +sub get_local_ip { + my (%param) = @_; + + my $nodename = PVE::INotify::nodename(); + my $resolved_host = eval { get_ip_from_hostname($nodename) }; + + return $resolved_host if defined($resolved_host) && !$param{all}; + + my $all = { v4 => {}, v6 => {} }; # hash to avoid duplicates and group by type + + my $interaces_cfg = PVE::INotify::read_file('interfaces', 1) || {}; + for my $if (values $interaces_cfg->{data}->{ifaces}->%*) { + next if $if->{type} eq 'loopback' || (!defined($if->{address}) && !defined($if->{address6})); + my ($v4, $v6) = ($if->{address}, $if->{address6}); + + return ($v4 // $v6) if !$param{all}; # prefer v4, admin can override $resolved_host via hosts/gai.conf + + $all->{v4}->{$v4} = 1 if defined($v4); + $all->{v6}->{$v6} = 1 if defined($v6); + } + + my $live = eval { get_reachable_networks() } // []; + for my $info ($live->@*) { + my $addr = $info->{addr}; + + return $addr if !$param{all}; + + if ($info->{family} eq 'inet') { + $all->{v4}->{$addr} = 1; + } else { + $all->{v6}->{$addr} = 1; + } + } + + return if !$param{all}; # getting here means no early return above triggered -> no IPs + + my $res = []; # order gai.conf controlled first, then group v4 and v6, simply lexically sorted + if ($resolved_host) { + push $res->@*, $resolved_host; + delete $all->{v4}->{$resolved_host}; + delete $all->{v6}->{$resolved_host}; + } + push $res->@*, sort { $a cmp $b } keys $all->{v4}->%*; + push $res->@*, sort { $a cmp $b } keys $all->{v6}->%*; + + return $res; +} sub get_local_ip_from_cidr { my ($cidr) = @_; - my $IPs = []; + my $IPs = {}; + my $i = 1; run_command(['/sbin/ip', 'address', 'show', 'to', $cidr, 'up'], outfunc => sub { if ($_[0] =~ m!^\s*inet(?:6)?\s+($PVE::Tools::IPRE)(?:/\d+|\s+peer\s+)!) { - push @$IPs, $1; + $IPs->{$1} = $i++ if !exists($IPs->{$1}); } }); - return $IPs; + return [ sort { $IPs->{$a} <=> $IPs->{$b} } keys %{$IPs} ]; } sub addr_to_ip { @@ -623,24 +806,18 @@ sub get_ip_from_hostname { my @res = eval { PVE::Tools::getaddrinfo_all($hostname) }; if ($@) { die "hostname lookup '$hostname' failed - $@" if !$noerr; - return undef; + return; } - my ($ip, $family); for my $ai (@res) { - $family = $ai->{family}; - my $tmpip = addr_to_ip($ai->{addr}); - if ($tmpip !~ m/^127\.|^::1$/) { - $ip = $tmpip; - last; + my $ip = addr_to_ip($ai->{addr}); + if ($ip !~ m/^127\.|^::1$/) { + return wantarray ? ($ip, $ai->{family}) : $ip; } } - if (!defined($ip) ) { - die "hostname lookup '$hostname' failed - got local IP address '$ip'\n" if !$noerr; - return undef; - } - - return wantarray ? ($ip, $family) : $ip; + # NOTE: we only get here if no WAN/LAN IP was found, so this is now the error path! + die "address lookup for '$hostname' did not find any IP address\n" if !$noerr; + return; } sub lock_network { @@ -650,4 +827,33 @@ sub lock_network { return $res; } +# the canonical form of the given IP, i.e. dotted quad for IPv4 and RFC 5952 for IPv6 +sub canonical_ip { + my ($ip) = @_; + + my $ip_obj = NetAddr::IP->new($ip) or die "invalid IP string '$ip'\n"; + + return $ip_obj->canon(); +} + +# List of unique, canonical IPs in the provided list. +# Keeps the original order, filtering later duplicates. +sub unique_ips { + my ($ips) = @_; + + my $res = []; + my $seen = {}; + + for my $ip (@{$ips}) { + $ip = canonical_ip($ip); + + next if $seen->{$ip}; + + $seen->{$ip} = 1; + push @{$res}, $ip; + } + + return $res; +} + 1; diff --git a/src/PVE/PBSClient.pm b/src/PVE/PBSClient.pm new file mode 100644 index 0000000..e63af03 --- /dev/null +++ b/src/PVE/PBSClient.pm @@ -0,0 +1,458 @@ +package PVE::PBSClient; +# utility functions for interaction with Proxmox Backup client CLI executable + +use strict; +use warnings; + +use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC); +use File::Temp qw(tempdir); +use IO::File; +use JSON; +use POSIX qw(mkfifo strftime ENOENT); + +use PVE::JSONSchema qw(get_standard_option); +use PVE::Tools qw(run_command file_set_contents file_get_contents file_read_firstline $IPV6RE); + +# returns a repository string suitable for proxmox-backup-client, pbs-restore, etc. +# $scfg must have the following structure: +# { +# datastore +# server +# port (optional defaults to 8007) +# username (optional defaults to 'root@pam') +# } +sub get_repository { + my ($scfg) = @_; + + my $server = $scfg->{server}; + die "no server given\n" if !defined($server); + + $server = "[$server]" if $server =~ /^$IPV6RE$/; + + if (my $port = $scfg->{port}) { + $server .= ":$port" if $port != 8007; + } + + my $datastore = $scfg->{datastore}; + die "no datastore given\n" if !defined($datastore); + + my $username = $scfg->{username} // 'root@pam'; + + return "$username\@$server:$datastore"; +} + +sub new { + my ($class, $scfg, $storeid, $sdir) = @_; + + die "no section config provided\n" if ref($scfg) eq ''; + die "undefined store id\n" if !defined($storeid); + + my $secret_dir = $sdir // '/etc/pve/priv/storage'; + + my $self = bless { + scfg => $scfg, + storeid => $storeid, + secret_dir => $secret_dir + }, $class; + return $self; +} + +my sub password_file_name { + my ($self) = @_; + + return "$self->{secret_dir}/$self->{storeid}.pw"; +} + +sub set_password { + my ($self, $password) = @_; + + my $pwfile = password_file_name($self); + mkdir $self->{secret_dir}; + + PVE::Tools::file_set_contents($pwfile, "$password\n", 0600); +}; + +sub delete_password { + my ($self) = @_; + + my $pwfile = password_file_name($self); + + unlink $pwfile or $! == ENOENT or die "deleting password file failed - $!\n"; +}; + +sub get_password { + my ($self) = @_; + + my $pwfile = password_file_name($self); + + return PVE::Tools::file_read_firstline($pwfile); +} + +sub encryption_key_file_name { + my ($self) = @_; + + return "$self->{secret_dir}/$self->{storeid}.enc"; +}; + +sub set_encryption_key { + my ($self, $key) = @_; + + my $encfile = $self->encryption_key_file_name(); + mkdir $self->{secret_dir}; + + PVE::Tools::file_set_contents($encfile, "$key\n", 0600); +}; + +sub delete_encryption_key { + my ($self) = @_; + + my $encfile = $self->encryption_key_file_name(); + + if (!unlink $encfile) { + return if $! == ENOENT; + die "failed to delete encryption key! $!\n"; + } +}; + +# Returns a file handle if there is an encryption key, or `undef` if there is not. Dies on error. +my sub open_encryption_key { + my ($self) = @_; + + my $encryption_key_file = $self->encryption_key_file_name(); + + my $keyfd; + if (!open($keyfd, '<', $encryption_key_file)) { + return undef if $! == ENOENT; + die "failed to open encryption key: $encryption_key_file: $!\n"; + } + + return $keyfd; +} + +my $USE_CRYPT_PARAMS = { + 'proxmox-backup-client' => { + backup => 1, + restore => 1, + 'upload-log' => 1, + }, + 'proxmox-file-restore' => { + list => 1, + extract => 1, + }, +}; + +my sub do_raw_client_cmd { + my ($self, $client_cmd, $param, %opts) = @_; + + my $client_bin = (delete $opts{binary}) || 'proxmox-backup-client'; + my $use_crypto = $USE_CRYPT_PARAMS->{$client_bin}->{$client_cmd} // 0; + + my $client_exe = "/usr/bin/$client_bin"; + die "executable not found '$client_exe'! $client_bin not installed?\n" if ! -x $client_exe; + + my $scfg = $self->{scfg}; + my $repo = get_repository($scfg); + + my $userns_cmd = delete $opts{userns_cmd}; + + my $cmd = []; + + push @$cmd, @$userns_cmd if defined($userns_cmd); + + push @$cmd, $client_exe, $client_cmd; + + # This must live in the top scope to not get closed before the `run_command` + my $keyfd; + if ($use_crypto) { + if (defined($keyfd = open_encryption_key($self))) { + my $flags = fcntl($keyfd, F_GETFD, 0) + // die "failed to get file descriptor flags: $!\n"; + fcntl($keyfd, F_SETFD, $flags & ~FD_CLOEXEC) + or die "failed to remove FD_CLOEXEC from encryption key file descriptor\n"; + push @$cmd, '--crypt-mode=encrypt', '--keyfd='.fileno($keyfd); + } else { + push @$cmd, '--crypt-mode=none'; + } + } + + push @$cmd, @$param if defined($param); + + push @$cmd, "--repository", $repo; + if (defined(my $ns = delete($opts{namespace}))) { + push @$cmd, '--ns', $ns; + } + + local $ENV{PBS_PASSWORD} = $self->get_password(); + + local $ENV{PBS_FINGERPRINT} = $scfg->{fingerprint}; + + # no ascii-art on task logs + local $ENV{PROXMOX_OUTPUT_NO_BORDER} = 1; + local $ENV{PROXMOX_OUTPUT_NO_HEADER} = 1; + + if (my $logfunc = $opts{logfunc}) { + $logfunc->("run: " . join(' ', @$cmd)); + } + + run_command($cmd, %opts); +} + +my sub run_raw_client_cmd : prototype($$$%) { + my ($self, $client_cmd, $param, %opts) = @_; + return do_raw_client_cmd($self, $client_cmd, $param, %opts); +} + +my sub run_client_cmd : prototype($$;$$$$) { + my ($self, $client_cmd, $param, $no_output, $binary, $namespace) = @_; + + my $json_str = ''; + my $outfunc = sub { $json_str .= "$_[0]\n" }; + + $binary //= 'proxmox-backup-client'; + + $param = [] if !defined($param); + $param = [ $param ] if !ref($param); + + $param = [@$param, '--output-format=json'] if !$no_output; + + do_raw_client_cmd( + $self, + $client_cmd, + $param, + outfunc => $outfunc, + errmsg => "$binary failed", + binary => $binary, + namespace => $namespace, + ); + + return undef if $no_output; + + my $res = decode_json($json_str); + + return $res; +} + +sub autogen_encryption_key { + my ($self) = @_; + my $encfile = $self->encryption_key_file_name(); + run_command( + ['proxmox-backup-client', 'key', 'create', '--kdf', 'none', $encfile], + errmsg => 'failed to create encryption key' + ); + return file_get_contents($encfile); +}; + +# TODO remove support for namespaced parameters. Needs Breaks for pmg-api and libpve-storage-perl. +# Deprecated! The namespace should be passed in as part of the config in new(). +# Snapshot or group parameters can be either just a string and will then default to the namespace +# that's part of the initial configuration in new(), or a tuple of `[namespace, snapshot]`. +my sub split_namespaced_parameter : prototype($$) { + my ($self, $snapshot) = @_; + return ($self->{scfg}->{namespace}, $snapshot) if !ref($snapshot); + + (my $namespace, $snapshot) = @$snapshot; + return ($namespace, $snapshot); +} + +# lists all snapshots, optionally limited to a specific group +sub get_snapshots { + my ($self, $group) = @_; + + my $namespace; + if (defined($group)) { + ($namespace, $group) = split_namespaced_parameter($self, $group); + } else { + $namespace = $self->{scfg}->{namespace}; + } + + my $param = []; + push @$param, $group if defined($group); + + return run_client_cmd($self, "snapshots", $param, undef, undef, $namespace); +}; + +# create a new PXAR backup of a FS directory tree - doesn't cross FS boundary +# by default. +sub backup_fs_tree { + my ($self, $root, $id, $pxarname, $cmd_opts) = @_; + + die "backup-id not provided\n" if !defined($id); + die "backup root dir not provided\n" if !defined($root); + die "archive name not provided\n" if !defined($pxarname); + + my $param = [ + "$pxarname.pxar:$root", + '--backup-type', 'host', + '--backup-id', $id, + ]; + + $cmd_opts //= {}; + + $cmd_opts->{namespace} = $self->{scfg}->{namespace} if defined($self->{scfg}->{namespace}); + + return run_raw_client_cmd($self, 'backup', $param, %$cmd_opts); +}; + +sub restore_pxar { + my ($self, $snapshot, $pxarname, $target, $cmd_opts) = @_; + + die "snapshot not provided\n" if !defined($snapshot); + die "archive name not provided\n" if !defined($pxarname); + die "restore-target not provided\n" if !defined($target); + + (my $namespace, $snapshot) = split_namespaced_parameter($self, $snapshot); + + my $param = [ + "$snapshot", + "$pxarname.pxar", + "$target", + "--allow-existing-dirs", 0, + ]; + $cmd_opts //= {}; + + $cmd_opts->{namespace} = $namespace; + + return run_raw_client_cmd($self, 'restore', $param, %$cmd_opts); +}; + +sub forget_snapshot { + my ($self, $snapshot) = @_; + + die "snapshot not provided\n" if !defined($snapshot); + + (my $namespace, $snapshot) = split_namespaced_parameter($self, $snapshot); + + return run_client_cmd($self, 'forget', ["$snapshot"], 1, undef, $namespace) +}; + +sub prune_group { + my ($self, $opts, $prune_opts, $group) = @_; + + die "group not provided\n" if !defined($group); + + (my $namespace, $group) = split_namespaced_parameter($self, $group); + + # do nothing if no keep options specified for remote + return [] if scalar(keys %$prune_opts) == 0; + + my $param = []; + + push @$param, "--quiet"; + + if (defined($opts->{'dry-run'}) && $opts->{'dry-run'}) { + push @$param, "--dry-run", $opts->{'dry-run'}; + } + + foreach my $keep_opt (keys %$prune_opts) { + push @$param, "--$keep_opt", $prune_opts->{$keep_opt}; + } + push @$param, "$group"; + + return run_client_cmd($self, 'prune', $param, undef, undef, $namespace); +}; + +sub status { + my ($self) = @_; + + my $total = 0; + my $free = 0; + my $used = 0; + my $active = 0; + + eval { + my $res = run_client_cmd($self, "status"); + + $active = 1; + $total = $res->{total}; + $used = $res->{used}; + $free = $res->{avail}; + }; + if (my $err = $@) { + warn $err; + } + + return ($total, $free, $used, $active); +}; + +sub file_restore_list { + my ($self, $snapshot, $filepath, $base64, $extra_params) = @_; + + (my $namespace, $snapshot) = split_namespaced_parameter($self, $snapshot); + my $cmd = [ $snapshot, $filepath, "--base64", $base64 ? 1 : 0]; + + if (my $timeout = $extra_params->{timeout}) { + push $cmd->@*, '--timeout', $timeout; + } + + return run_client_cmd( + $self, + "list", + $cmd, + 0, + "proxmox-file-restore", + $namespace, + ); +} + +# call sync from API, returns a fifo path for streaming data to clients, +# pass it to file_restore_extract to start transfering data +sub file_restore_extract_prepare { + my ($self) = @_; + + my $tmpdir = tempdir(); + mkfifo("$tmpdir/fifo", 0600) + or die "creating file download fifo '$tmpdir/fifo' failed: $!\n"; + + # allow reading data for proxy user + my $wwwid = getpwnam('www-data') || + die "getpwnam failed"; + chown $wwwid, -1, "$tmpdir" + or die "changing permission on fifo dir '$tmpdir' failed: $!\n"; + chown $wwwid, -1, "$tmpdir/fifo" + or die "changing permission on fifo '$tmpdir/fifo' failed: $!\n"; + + return "$tmpdir/fifo"; +} + +# this blocks while data is transfered, call this from a background worker +sub file_restore_extract { + my ($self, $output_file, $snapshot, $filepath, $base64, $tar) = @_; + + (my $namespace, $snapshot) = split_namespaced_parameter($self, $snapshot); + + my $ret = eval { + local $SIG{ALRM} = sub { die "got timeout\n" }; + alarm(30); + sysopen(my $fh, "$output_file", O_WRONLY) + or die "open target '$output_file' for writing failed: $!\n"; + alarm(0); + + my $fn = fileno($fh); + my $errfunc = sub { print $_[0], "\n"; }; + + my $cmd = [ $snapshot, $filepath, "-", "--base64", $base64 ? 1 : 0]; + if ($tar) { + push @$cmd, '--format', 'tar', '--zstd', 1; + } + + return run_raw_client_cmd( + $self, + "extract", + $cmd, + binary => "proxmox-file-restore", + namespace => $namespace, + errfunc => $errfunc, + output => ">&$fn", + ); + }; + my $err = $@; + + unlink($output_file); + $output_file =~ s/fifo$//; + rmdir($output_file) if -d $output_file; + + die "file restore task failed: $err" if $err; + return $ret; +} + +1; diff --git a/src/PVE/ProcFSTools.pm b/src/PVE/ProcFSTools.pm index 7cf1472..3826fcc 100644 --- a/src/PVE/ProcFSTools.pm +++ b/src/PVE/ProcFSTools.pm @@ -2,14 +2,15 @@ package PVE::ProcFSTools; use strict; use warnings; -use POSIX; -use Time::HiRes qw (gettimeofday); + +use Cwd qw(); use IO::File; use List::Util qw(sum); -use PVE::Tools; -use Cwd qw(); - +use POSIX; use Socket qw(PF_INET PF_INET6 SOCK_DGRAM IPPROTO_IP); +use Time::HiRes qw (gettimeofday); + +use PVE::Tools; use constant IFF_UP => 1; use constant IFNAMSIZ => 16; @@ -132,22 +133,54 @@ sub read_loadavg { return wantarray ? (0, 0, 0) : 0; } +sub parse_pressure { + my ($path) = @_; + + my $res = {}; + my $v = qr/\d+\.\d+/; + my $fh = IO::File->new($path, "r") or return undef; + while (defined (my $line = <$fh>)) { + if ($line =~ /^(some|full)\s+avg10\=($v)\s+avg60\=($v)\s+avg300\=($v)\s+total\=(\d+)/) { + $res->{$1}->{avg10} = $2; + $res->{$1}->{avg60} = $3; + $res->{$1}->{avg300} = $4; + $res->{$1}->{total} = $4; + } + } + $fh->close; + return $res; +} + +sub read_pressure { + my $res = {}; + foreach my $type (qw(cpu memory io)) { + my $stats = parse_pressure("/proc/pressure/$type"); + $res->{$type} = $stats if $stats; + } + return $res; +} + my $last_proc_stat; sub read_proc_stat { - my $res = { user => 0, nice => 0, system => 0, idle => 0 , sum => 0}; + my $res = { user => 0, nice => 0, system => 0, idle => 0 , iowait => 0, irq => 0, softirq => 0, steal => 0, guest => 0, guest_nice => 0, sum => 0}; my $cpucount = 0; if (my $fh = IO::File->new ("/proc/stat", "r")) { while (defined (my $line = <$fh>)) { - if ($line =~ m|^cpu\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s|) { - $res->{user} = $1; - $res->{nice} = $2; + if ($line =~ m|^cpu\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)(?:\s+(\d+)\s+(\d+))?|) { + $res->{user} = $1 - ($9 // 0); + $res->{nice} = $2 - ($10 // 0); $res->{system} = $3; $res->{idle} = $4; - $res->{used} = $1+$2+$3; + $res->{used} = $1+$2+$3+$6+$7+$8; $res->{iowait} = $5; + $res->{irq} = $6; + $res->{softirq} = $7; + $res->{steal} = $8; + $res->{guest} = $9 // 0; + $res->{guest_nice} = $10 // 0; } elsif ($line =~ m|^cpu\d+\s|) { $cpucount++; } @@ -159,6 +192,18 @@ sub read_proc_stat { my $ctime = gettimeofday; # floating point time in seconds + # the sum of all fields + $res->{total} = $res->{user} + + $res->{nice} + + $res->{system} + + $res->{iowait} + + $res->{irq} + + $res->{softirq} + + $res->{steal} + + $res->{idle} + + $res->{guest} + + $res->{guest_nice}; + $res->{ctime} = $ctime; $res->{cpu} = 0; $res->{wait} = 0; @@ -170,11 +215,15 @@ sub read_proc_stat { if ($diff > 1000) { # don't update too often my $useddiff = $res->{used} - $last_proc_stat->{used}; $useddiff = $diff if $useddiff > $diff; - $res->{cpu} = $useddiff/$diff; + + my $totaldiff = $res->{total} - $last_proc_stat->{total}; + $totaldiff = $diff if $totaldiff > $diff; + + $res->{cpu} = $useddiff/$totaldiff; my $waitdiff = $res->{iowait} - $last_proc_stat->{iowait}; $waitdiff = $diff if $waitdiff > $diff; - $res->{wait} = $waitdiff/$diff; + $res->{wait} = $waitdiff/$totaldiff; $last_proc_stat = $res; } else { @@ -235,6 +284,7 @@ sub read_meminfo { swaptotal => 0, swapfree => 0, swapused => 0, + arcsize => 0, }; my $fh = IO::File->new ("/proc/meminfo", "r"); @@ -259,6 +309,11 @@ sub read_meminfo { my $spages = PVE::Tools::file_read_firstline("/sys/kernel/mm/ksm/pages_sharing") // 0 ; $res->{memshared} = int($spages) * 4096; + my $arc_stats = eval { PVE::Tools::file_get_contents("/proc/spl/kstat/zfs/arcstats") }; + if ($arc_stats && $arc_stats =~ m/^size\s+\d+\s+(\d+)$/m) { + $res->{arcsize} = int($1); + } + return $res; } @@ -304,10 +359,10 @@ sub read_proc_net_dev { sub write_proc_entry { my ($filename, $data) = @_;# - my $fh = IO::File->new($filename, O_WRONLY); + my $fh = IO::File->new($filename, O_WRONLY); die "unable to open file '$filename' - $!\n" if !$fh; - die "unable to write '$filename' - $!\n" unless print $fh $data; - die "closing file '$filename' failed - $!\n" unless close $fh; + print $fh $data or die "unable to write '$filename' - $!\n"; + close $fh or die "closing file '$filename' failed - $!\n"; $fh->close(); } @@ -351,6 +406,7 @@ sub decode_mount { sub parse_mounts { my ($mounts) = @_; + my $mntent = []; while ($mounts =~ /^\s*([^#].*)$/gm) { # lines from the file are encoded so we can just split at spaces @@ -359,11 +415,14 @@ sub parse_mounts { # in glibc's parser frequency and pass seem to be optional $freq = $1 if $opts =~ s/\s+(\d+)$//; $passno = $1 if $opts =~ s/\s+(\d+)$//; - push @$mntent, [decode_mount($what), - decode_mount($dir), - decode_mount($fstype), - decode_mount($opts), - $freq, $passno]; + push @$mntent, [ + decode_mount($what), + decode_mount($dir), + decode_mount($fstype), + decode_mount($opts), + $freq, + $passno, + ]; } return $mntent; } diff --git a/src/PVE/RESTEnvironment.pm b/src/PVE/RESTEnvironment.pm index d5b84d0..191c6eb 100644 --- a/src/PVE/RESTEnvironment.pm +++ b/src/PVE/RESTEnvironment.pm @@ -7,17 +7,22 @@ package PVE::RESTEnvironment; use strict; use warnings; -use POSIX qw(:sys_wait_h EINTR); -use IO::Handle; + +use Exporter qw(import); +use Fcntl qw(:flock); use IO::File; +use IO::Handle; use IO::Select; -use Fcntl qw(:flock); +use POSIX qw(:sys_wait_h EINTR); +use AnyEvent; + use PVE::Exception qw(raise raise_perm_exc); -use PVE::SafeSyslog; -use PVE::Tools; use PVE::INotify; use PVE::ProcFSTools; +use PVE::SafeSyslog; +use PVE::Tools; +our @EXPORT_OK = qw(log_warn); my $rest_env; @@ -107,7 +112,15 @@ sub init { die "unknown environment type" if !$type || $type !~ m/^(cli|pub|priv|ha)$/; - $SIG{CHLD} = $worker_reaper; + $SIG{CHLD} = sub { + # when we're using AnyEvent, we have to postpone the call to worker_reaper, otherwise it + # might interfere with running api calls + if (defined($AnyEvent::MODEL)) { + AnyEvent::postpone { $worker_reaper->() }; + } else { + $worker_reaper->(); + } + }; # environment types # cli ... command started fron command line @@ -115,7 +128,10 @@ sub init { # priv ... access from private server (pvedaemon) # ha ... access from HA resource manager agent (pve-ha-manager) - my $self = { type => $type }; + my $self = { + type => $type, + warning_count => 0, + }; bless $self, $class; @@ -251,20 +267,17 @@ sub is_worker { return $WORKER_FLAG; } -# read/update list of active workers -# we move all finished tasks to the archive index, -# but keep aktive and most recent task in the active file. -# $nocheck ... consider $new_upid still running (avoid that -# we try to read the reult to early. -sub active_workers { +# read/update list of active workers. +# +# we move all finished tasks to the archive index, but keep active, and most recent tasks in the +# active file. +# $nocheck ... consider $new_upid still running (avoid that we try to read the result to early). +sub active_workers { my ($self, $new_upid, $nocheck) = @_; - my $lkfn = "/var/log/pve/tasks/.active.lock"; - my $timeout = 10; - my $code = sub { - + my $res = PVE::Tools::lock_file("/var/log/pve/tasks/.active.lock", $timeout, sub { my $tasklist = PVE::INotify::read_file('active'); my @ta; @@ -290,8 +303,8 @@ sub active_workers { &$check_task($task); } - if ($new_upid && !(my $task = $thash->{$new_upid})) { - $task = PVE::Tools::upid_decode($new_upid); + if ($new_upid && !$thash->{$new_upid}) { + my $task = PVE::Tools::upid_decode($new_upid); $task->{upid} = $new_upid; $thash->{$new_upid} = $task; &$check_task($task, $nocheck); @@ -344,10 +357,9 @@ sub active_workers { } } - # we try to reduce the amount of data - # list all running tasks and task and a few others - # try to limit to 25 tasks - my $max = 25 - scalar(@$tlist); + # we try to reduce the amount of data list all running tasks and task and a few others + my $MAX_FINISHED = 25; + my $max = $MAX_FINISHED - scalar(@$tlist); foreach my $task (@ta) { last if $max <= 0; push @$tlist, $task; @@ -357,9 +369,7 @@ sub active_workers { PVE::INotify::write_file('active', $tlist) if $save; return $tlist; - }; - - my $res = PVE::Tools::lock_file($lkfn, $timeout, $code); + }); die $@ if $@; return $res; @@ -421,7 +431,7 @@ my $tee_worker = sub { }; local $SIG{PIPE} = sub { die "broken pipe\n"; }; - my $select = new IO::Select; + my $select = IO::Select->new(); my $fh = IO::Handle->new_from_fd($childfd, 'r'); $select->add($fh); @@ -448,7 +458,6 @@ my $tee_worker = sub { } } - # get status (error or OK) POSIX::read($ctrlfd, $readbuf, 4096); if ($readbuf =~ m/^TASK OK\n?$/) { # skip printing to stdout @@ -456,6 +465,9 @@ my $tee_worker = sub { } elsif ($readbuf =~ m/^TASK ERROR: (.*)\n?$/) { print STDERR "$1\n"; print $taskfh "\n$readbuf"; # ensure start on new line for webUI + } elsif ($readbuf =~ m/^TASK WARNINGS: (\d+)\n?$/) { + print STDERR "Task finished with $1 warning(s)!\n"; + print $taskfh "\n$readbuf"; # ensure start on new line for webUI } else { die "got unexpected control message: $readbuf\n"; } @@ -483,7 +495,8 @@ sub fork_worker { $dtype = 'unknown' if !defined ($dtype); $id = '' if !defined ($id); - $user = 'root@pve' if !defined ($user); + # note: below is only used for the task log entry + $user = $self->get_user(1) // 'root@pam' if !defined($user); my $sync = ($self->{type} eq 'cli' && !$background) ? 1 : 0; @@ -496,7 +509,7 @@ sub fork_worker { my @psync = POSIX::pipe(); my @csync = POSIX::pipe(); - my @ctrlfd = POSIX::pipe() if $sync; + my @ctrlfd = $sync ? POSIX::pipe() : (); my $node = $self->{nodename}; @@ -558,8 +571,7 @@ sub fork_worker { close STDIN; POSIX::close(0) if $fd != 0; - die "unable to redirect STDIN - $!" - if !open(STDIN, "&", $outfh); + open(STDOUT, ">&", $outfh) or die "unable to redirect STDOUT - $!"; STDOUT->autoflush (1); @@ -581,8 +592,7 @@ sub fork_worker { close STDERR; POSIX::close(2) if $fd != 2; - die "unable to redirect STDERR - $!" - if !open(STDERR, ">&1"); + open(STDERR, '>&', '1') or die "unable to redirect STDERR - $!"; STDERR->autoflush(1); }; @@ -617,6 +627,9 @@ sub fork_worker { syslog('err', $err); $msg = "TASK ERROR: $err\n"; $exitcode = -1; + } elsif (my $warnings = $self->{warning_count}) { + $msg = "TASK WARNINGS: $warnings\n"; + $exitcode = 0; } else { $msg = "TASK OK\n"; $exitcode = 0; @@ -703,6 +716,27 @@ sub fork_worker { return wantarray ? ($upid, $res) : $upid; } +sub log_warn { + my ($message) = @_; + + if ($rest_env) { + $rest_env->warn($message); + } else { + chomp($message); + print STDERR "WARN: $message\n"; + } +} + +sub warn { + my ($self, $message) = @_; + + chomp($message); + + print STDERR "WARN: $message\n"; + + $self->{warning_count}++; +} + # Abstract function sub log_cluster_msg { diff --git a/src/PVE/RESTHandler.pm b/src/PVE/RESTHandler.pm index 60731ac..7bf6b74 100644 --- a/src/PVE/RESTHandler.pm +++ b/src/PVE/RESTHandler.pm @@ -1,15 +1,16 @@ package PVE::RESTHandler; use strict; -no strict 'refs'; # our autoload requires this use warnings; -use PVE::SafeSyslog; + +use Clone qw(clone); +use HTTP::Status qw(:constants :is status_message); +use Text::Wrap; + use PVE::Exception qw(raise raise_param_exc); use PVE::JSONSchema; +use PVE::SafeSyslog; use PVE::Tools; -use HTTP::Status qw(:constants :is status_message); -use Text::Wrap; -use Clone qw(clone); my $method_registry = {}; my $method_by_name = {}; @@ -69,8 +70,7 @@ sub api_clone_schema { } } my $tmp = ref($pd) ? clone($pd) : $pd; - # NOTE: add typetext property for more complex types, to - # make the web api viewer code simpler + # NOTE: add typetext property for complexer types, to make the web api-viewer code simpler if (!$no_typetext && !(defined($tmp->{enum}) || defined($tmp->{pattern}))) { my $typetext = PVE::JSONSchema::schema_get_type_text($tmp); if ($tmp->{type} && ($tmp->{type} ne $typetext)) { @@ -189,7 +189,7 @@ sub api_dump_remove_refs { foreach my $k (keys %$tree) { if (my $itemclass = ref($tree->{$k})) { if ($itemclass eq 'CODE') { - next if $k eq 'completion'; + next if $k eq 'completion' || $k eq 'proxyto_callback'; } $res->{$k} = api_dump_remove_refs($tree->{$k}); } else { @@ -255,9 +255,9 @@ sub register_method { foreach my $comp (split(/\/+/, $info->{path})) { die "$errprefix path compoment has zero length\n" if $comp eq ''; my ($name, $regex); - if ($comp =~ m/^\{(\w+)(:(.*))?\}$/) { + if ($comp =~ m/^\{([\w-]+)(?::(.*))?\}$/) { $name = $1; - $regex = $3 ? $3 : '\S+'; + $regex = $2 ? $2 : '\S+'; push @$match_re, $regex; push @$match_name, $name; } else { @@ -330,10 +330,13 @@ sub AUTOLOAD { my $info = $this->map_method_by_name($method); - *{$sub} = sub { - my $self = shift; - return $self->handle($info, @_); - }; + { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$sub} = sub { + my $self = shift; + return $self->handle($info, @_); + }; + } goto &$AUTOLOAD; } @@ -425,38 +428,81 @@ sub find_handler { return ($handler_class, $method_info); } +my sub untaint_recursive : prototype($) { + use feature 'current_sub'; + + my ($param) = @_; + + my $ref = ref($param); + if ($ref eq 'HASH') { + $param->{$_} = __SUB__->($param->{$_}) for keys $param->%*; + } elsif ($ref eq 'ARRAY') { + for (my $i = 0; $i < scalar($param->@*); $i++) { + $param->[$i] = __SUB__->($param->[$i]); + } + } else { + if (defined($param)) { + my ($newval) = $param =~ /^(.*)$/s; + $param = $newval; + } + } + + return $param; +}; + +# convert arrays to strings where we expect a '-list' format and convert scalar +# values to arrays when we expect an array (because of www-form-urlencoded) +# +# only on the top level, since www-form-urlencoded cannot be nested anyway +# +# FIXME: change gui/api calls to not rely on this during 8.x, mark the +# behaviour deprecated with 9.x, and remove it with 10.x +my $normalize_legacy_param_formats = sub { + my ($param, $schema) = @_; + + return $param if !$schema->{properties}; + return $param if (ref($param) // '') ne 'HASH'; + + for my $key (keys $schema->{properties}->%*) { + if (my $value = $param->{$key}) { + my $type = $schema->{properties}->{$key}->{type} // ''; + my $format = $schema->{properties}->{$key}->{format} // ''; + my $ref = ref($value); + if ($ref && $ref eq 'ARRAY' && $type eq 'string' && $format =~ m/-list$/) { + $param->{$key} = join(',', $value->@*); + } elsif (!$ref && $type eq 'array') { + $param->{$key} = [$value]; + } + } + } + + return $param; +}; + sub handle { - my ($self, $info, $param) = @_; + my ($self, $info, $param, $result_verification) = @_; my $func = $info->{code}; if (!($info->{name} && $func)) { - raise("Method lookup failed ('$info->{name}')\n", - code => HTTP_INTERNAL_SERVER_ERROR); + raise("Method lookup failed ('$info->{name}')\n", code => HTTP_INTERNAL_SERVER_ERROR); } if (my $schema = $info->{parameters}) { # warn "validate ". Dumper($param}) . "\n" . Dumper($schema); + $param = $normalize_legacy_param_formats->($param, $schema); PVE::JSONSchema::validate($param, $schema); # untaint data (already validated) - my $extra = delete $param->{'extra-args'}; - while (my ($key, $val) = each %$param) { - if (defined($val)) { - ($param->{$key}) = $val =~ /^(.*)$/s; - } else { - $param->{$key} = undef; - } - } - $param->{'extra-args'} = [map { /^(.*)$/ } @$extra] if $extra; + $param = untaint_recursive($param); } - my $result = &$func($param); + my $result = $func->($param); # the actual API code execution call - # todo: this is only to be safe - disable? - if (my $schema = $info->{returns}) { + if ($result_verification && (my $schema = $info->{returns})) { + # return validation is rather lose-lose, as it can require quite a bit of time and lead to + # false-positive errors, any HTTP API handler should avoid enabling it by default. PVE::JSONSchema::validate($result, $schema, "Result verification failed\n"); } - return $result; } @@ -519,6 +565,9 @@ my $get_property_description = sub { chomp $wdescr; $wdescr =~ s/^$/+/mg; + $wdescr =~ s/{/\\{/g; + $wdescr =~ s/}/\\}/g; + $res .= $wdescr . "\n"; if (my $req = $phash->{requires}) { @@ -549,7 +598,6 @@ my $get_property_description = sub { my $indend = " "; $res .= Text::Wrap::wrap('', $indend, ($tmp)); - $res .= "\n", $res .= Text::Wrap::wrap($indend, $indend, ($descr)) . "\n\n"; if (my $req = $phash->{requires}) { @@ -677,12 +725,19 @@ sub getopt_usage { my $idx_param = {}; # -vlan\d+ -scsi\d+ my $opts = ''; + + my $type_specific_opts = {}; + foreach my $k (sort keys %$prop) { next if $arg_hash->{$k}; next if defined($fixed_param->{$k}); my $type_text = $prop->{$k}->{type} || 'string'; + if ($prop->{$k}->{oneOf}) { + $type_text = 'multiple'; + } + my $param_map = {}; if (defined($param_cb)) { @@ -701,10 +756,51 @@ sub getopt_usage { } } + my $is_optional = $prop->{$k}->{optional} // 0; + + if (my $type_property = $prop->{$k}->{'type-property'}) { + # save type specific descriptions for later + my $type_schema = $prop->{$type_property}; + if ($prop->{$k}->{oneOf}) { + # it's optional if there are less options than types + $is_optional = 1 if scalar($type_schema->{enum}->@*) > scalar($prop->{$k}->{oneOf}->@*); + for my $alternative ($prop->{$k}->{oneOf}->@*) { + # it's optional if at least one variant is optional + $is_optional = 1 if $alternative->{optional}; + for my $type ($alternative->{'instance-types'}->@*) { + my $key = "${type_property}=${type}"; + $type_specific_opts->{$key} //= ""; + $type_specific_opts->{$key} + .= $get_property_description->($base, 'arg', $alternative, $format, $param_map->{$k}); + } + } + } elsif (my $types = $prop->{$k}->{'instance-types'}) { + # it's optional if not all types has that option + $is_optional = 1 if scalar($type_schema->{enum}->@*) > scalar($types->@*); + for my $type ($types->@*) { + my $key = "${type_property}=${type}"; + $type_specific_opts->{$key} //= ""; + $type_specific_opts->{$key} + .= $get_property_description->($base, 'arg', $prop->{$k}, $format, $param_map->{$k}); + } + } + } elsif ($prop->{$k}->{oneOf}) { + my $res = []; + for my $alternative ($prop->{$k}->{oneOf}->@*) { + # it's optional if at least one variant is optional + $is_optional = 1 if $alternative->{optional}; + push $res->@*, $get_property_description->($base, 'arg', $alternative, $format, $param_map->{$k}); + } + if ($format eq 'asciidoc') { + $opts .= join("\n\nor\n\n", $res->@*); + } else { + $opts .= join(" or\n\n", $res->@*); + } + } else { + $opts .= $get_property_description->($base, 'arg', $prop->{$k}, $format, $param_map->{$k}); + } - $opts .= $get_property_description->($base, 'arg', $prop->{$k}, $format, $param_map->{$k}); - - if (!$prop->{$k}->{optional}) { + if (!$is_optional) { $args .= " " if $args; $args .= "--$base <$type_text>" } @@ -740,6 +836,23 @@ sub getopt_usage { $out .= $opts if $opts; + if (scalar(keys $type_specific_opts->%*)) { + if ($format eq 'asciidoc') { + $out .= "\n\n\n`Conditional options:`\n\n"; + } else { + $out .= " Conditional options:\n\n"; + } + } + + for my $type_opts (sort keys $type_specific_opts->%*) { + if ($format eq 'asciidoc') { + $out .= "`[$type_opts]` ;;\n\n"; + } else { + $out .= " [$type_opts]\n\n"; + } + $out .= $type_specific_opts->{$type_opts}; + } + return $out; } @@ -777,7 +890,14 @@ sub dump_properties { } } - $raw .= $get_property_description->($base, $style, $phash, $format); + if ($phash->{oneOf}) { + for my $alternative ($phash->{oneOf}->@*) { + $raw .= $get_property_description->($base, $style, $alternative, $format); + } + } else { + $raw .= $get_property_description->($base, $style, $phash, $format); + } + next if $style ne 'config'; @@ -862,7 +982,7 @@ sub cli_handler { $replace_file_names_with_contents->($param, $param_map); } - $res = $self->handle($info, $param); + $res = $self->handle($info, $param, 1); }; if (my $err = $@) { my $ec = ref($err); diff --git a/src/PVE/SafeSyslog.pm b/src/PVE/SafeSyslog.pm index 7d3e7a7..af105a1 100644 --- a/src/PVE/SafeSyslog.pm +++ b/src/PVE/SafeSyslog.pm @@ -18,7 +18,11 @@ my $log_tag = "unknown"; # it corrupts the DBD database connection! sub syslog { - eval { Sys::Syslog::syslog (@_); }; # ignore errors + my ($level, @param) = @_; + + $level = 'warning' if $level eq 'warn'; + + eval { Sys::Syslog::syslog ($level, @param); }; # ignore errors } sub initlog { diff --git a/src/PVE/SectionConfig.pm b/src/PVE/SectionConfig.pm index b46b59e..a18e9d8 100644 --- a/src/PVE/SectionConfig.pm +++ b/src/PVE/SectionConfig.pm @@ -8,6 +8,67 @@ use Digest::SHA; use PVE::Exception qw(raise_param_exc); use PVE::JSONSchema qw(get_standard_option); +use PVE::Tools; + +# This package provides a way to have multiple (often similar) types of entries +# in the same config file, each in its own section, thus "Section Config". +# +# The intended structure is to have a single 'base' plugin that inherits from +# this class and provides meaningful defaults in its '$defaultData', e.g. a +# default list of the core properties in its propertyList (most often only 'id' +# and 'type') +# +# Each 'real' plugin then has it's own package that should inherit from the +# 'base' plugin and returns it's specific properties in the 'properties' method, +# its type in the 'type' method and all the known options, from both parent and +# itself, in the 'options' method. +# The options method can also be used to define if a property is 'optional' or +# 'fixed' (only settable on config entity-creation), for example: +# +# ```` +# sub options { +# return { +# 'some-optional-property' => { optional => 1 }, +# 'a-fixed-property' => { fixed => 1 }, +# 'a-required-but-not-fixed-property' => {}, +# }; +# } +# ``` +# +# 'fixed' options can be set on create, but not changed afterwards. +# +# To actually use it, you have to first register all the plugins and then init +# the 'base' plugin, like so: +# +# ``` +# use PVE::Dummy::Plugin1; +# use PVE::Dummy::Plugin2; +# use PVE::Dummy::BasePlugin; +# +# PVE::Dummy::Plugin1->register(); +# PVE::Dummy::Plugin2->register(); +# PVE::Dummy::BasePlugin->init(); +# ``` +# +# There are two modes for how properties are exposed, the default 'unified' +# mode and the 'isolated' mode. +# In the default unified mode, there is only a global list of properties +# which the plugins can use, so you cannot define the same property name twice +# in different plugins. The reason for this is to force the use of identical +# properties for multiple plugins. +# +# The second way is to use the 'isolated' mode, which can be achieved by +# calling init with `1` as its parameter like this: +# +# ``` +# PVE::Dummy::BasePlugin->init(property_isolation => 1); +# ``` +# +# With this, each plugin get's their own isolated list of properties which it +# can use. Note that in this mode, you only have to specify the property in the +# options method when it is either 'fixed' or comes from the global list of +# properties. All locally defined ones get automatically added to the schema +# for that plugin. my $defaultData = { options => {}, @@ -51,51 +112,126 @@ sub plugindata { return {}; } +sub has_isolated_properties { + my ($class) = @_; + + my $isolatedPropertyList = $class->private()->{isolatedPropertyList}; + + return defined($isolatedPropertyList) && scalar(keys $isolatedPropertyList->%*) > 0; +} + +my sub compare_property { + my ($a, $b, $skip_opts) = @_; + + my $merged = {$a->%*, $b->%*}; + delete $merged->{$_} for $skip_opts->@*; + + for my $opt (keys $merged->%*) { + return 0 if !PVE::Tools::is_deeply($a->{$opt}, $b->{$opt}); + } + + return 1; +}; + +my sub add_property { + my ($props, $key, $prop, $type) = @_; + + if (!defined($props->{$key})) { + $props->{$key} = $prop; + return; + } + + if (!defined($props->{$key}->{oneOf})) { + if (compare_property($props->{$key}, $prop, ['instance-types'])) { + push $props->{$key}->{'instance-types'}->@*, $type; + } else { + my $new_prop = delete $props->{$key}; + delete $new_prop->{'type-property'}; + delete $prop->{'type-property'}; + $props->{$key} = { + 'type-property' => 'type', + oneOf => [ + $new_prop, + $prop, + ], + }; + } + } else { + for my $existing_prop ($props->{$key}->{oneOf}->@*) { + if (compare_property($existing_prop, $prop, ['instance-types', 'type-property'])) { + push $existing_prop->{'instance-types'}->@*, $type; + return; + } + } + + push $props->{$key}->{oneOf}->@*, $prop; + } +}; + sub createSchema { - my ($class, $skip_type) = @_; + my ($class, $skip_type, $base) = @_; my $pdata = $class->private(); my $propertyList = $pdata->{propertyList}; my $plugins = $pdata->{plugins}; - my $props = {}; - - my $copy_property = sub { - my ($src) = @_; - - my $res = {}; - foreach my $k (keys %$src) { - $res->{$k} = $src->{$k}; - } + my $props = $base || {}; - return $res; - }; + if (!$class->has_isolated_properties()) { + foreach my $p (keys %$propertyList) { + next if $skip_type && $p eq 'type'; - foreach my $p (keys %$propertyList) { - next if $skip_type && $p eq 'type'; + if (!$propertyList->{$p}->{optional}) { + $props->{$p} = $propertyList->{$p}; + next; + } - if (!$propertyList->{$p}->{optional}) { - $props->{$p} = $propertyList->{$p}; - next; - } + my $required = 1; - my $required = 1; + my $copts = $class->options(); + $required = 0 if defined($copts->{$p}) && $copts->{$p}->{optional}; - my $copts = $class->options(); - $required = 0 if defined($copts->{$p}) && $copts->{$p}->{optional}; + foreach my $t (keys %$plugins) { + my $opts = $pdata->{options}->{$t} || {}; + $required = 0 if !defined($opts->{$p}) || $opts->{$p}->{optional}; + } - foreach my $t (keys %$plugins) { - my $opts = $pdata->{options}->{$t} || {}; - $required = 0 if !defined($opts->{$p}) || $opts->{$p}->{optional}; + if ($required) { + # make a copy, because we modify the optional property + my $res = {$propertyList->{$p}->%*}; # shallow copy + $res->{optional} = 0; + $props->{$p} = $res; + } else { + $props->{$p} = $propertyList->{$p}; + } } - - if ($required) { - # make a copy, because we modify the optional property - my $res = &$copy_property($propertyList->{$p}); - $res->{optional} = 0; - $props->{$p} = $res; - } else { - $props->{$p} = $propertyList->{$p}; + } else { + for my $type (sort keys %$plugins) { + my $opts = $pdata->{options}->{$type} || {}; + for my $key (sort keys $opts->%*) { + my $schema = $class->get_property_schema($type, $key); + my $prop = {$schema->%*}; + $prop->{'instance-types'} = [$type]; + $prop->{'type-property'} = 'type'; + $prop->{optional} = 1 if $opts->{$key}->{optional}; + + add_property($props, $key, $prop, $type); + } + } + # add remaining global properties + for my $opt (keys $propertyList->%*) { + next if $props->{$opt}; + $props->{$opt} = {$propertyList->{$opt}->%*}; + } + for my $opt (keys $props->%*) { + if (my $necessaryTypes = $props->{$opt}->{'instance-types'}) { + if ($necessaryTypes->@* == scalar(keys $plugins->%*)) { + delete $props->{$opt}->{'instance-types'}; + delete $props->{$opt}->{'type-property'}; + } else { + $props->{$opt}->{optional} = 1; + } + } } } @@ -107,40 +243,71 @@ sub createSchema { } sub updateSchema { - my ($class, $single_class) = @_; + my ($class, $single_class, $base) = @_; my $pdata = $class->private(); my $propertyList = $pdata->{propertyList}; my $plugins = $pdata->{plugins}; - my $props = {}; + my $props = $base || {}; - my $filter_type = $class->type() if $single_class; + my $filter_type = $single_class ? $class->type() : undef; - foreach my $p (keys %$propertyList) { - next if $p eq 'type'; + if (!$class->has_isolated_properties()) { + foreach my $p (keys %$propertyList) { + next if $p eq 'type'; - my $copts = $class->options(); + my $copts = $class->options(); - next if defined($filter_type) && !defined($copts->{$p}); + next if defined($filter_type) && !defined($copts->{$p}); - if (!$propertyList->{$p}->{optional}) { - $props->{$p} = $propertyList->{$p}; - next; - } + if (!$propertyList->{$p}->{optional}) { + $props->{$p} = $propertyList->{$p}; + next; + } + + my $modifyable = 0; - my $modifyable = 0; + $modifyable = 1 if defined($copts->{$p}) && !$copts->{$p}->{fixed}; - $modifyable = 1 if defined($copts->{$p}) && !$copts->{$p}->{fixed}; + foreach my $t (keys %$plugins) { + my $opts = $pdata->{options}->{$t} || {}; + next if !defined($opts->{$p}); + $modifyable = 1 if !$opts->{$p}->{fixed}; + } + next if !$modifyable; - foreach my $t (keys %$plugins) { - my $opts = $pdata->{options}->{$t} || {}; - next if !defined($opts->{$p}); - $modifyable = 1 if !$opts->{$p}->{fixed}; + $props->{$p} = $propertyList->{$p}; + } + } else { + for my $type (sort keys %$plugins) { + my $opts = $pdata->{options}->{$type} || {}; + for my $key (sort keys $opts->%*) { + next if $opts->{$key}->{fixed}; + + my $schema = $class->get_property_schema($type, $key); + my $prop = {$schema->%*}; + $prop->{'instance-types'} = [$type]; + $prop->{'type-property'} = 'type'; + $prop->{optional} = 1; + + add_property($props, $key, $prop, $type); + } + } + + for my $opt (keys $propertyList->%*) { + next if $props->{$opt}; + $props->{$opt} = {$propertyList->{$opt}->%*}; } - next if !$modifyable; - $props->{$p} = $propertyList->{$p}; + for my $opt (keys $props->%*) { + if (my $necessaryTypes = $props->{$opt}->{'instance-types'}) { + if ($necessaryTypes->@* == scalar(keys $plugins->%*)) { + delete $props->{$opt}->{'instance-types'}; + delete $props->{$opt}->{'type-property'}; + } + } + } } $props->{digest} = get_standard_option('pve-config-digest'); @@ -159,23 +326,37 @@ sub updateSchema { }; } +# the %param hash controls some behavior of the section config, currently the following options are +# understood: +# +# - property_isolation: if set, each child-plugin has a fully isolated property (schema) namespace. +# By default this is off, meaning all child-plugins share the schema of properties with the same +# name. Normally one wants to use oneOf schema's when enabling isolation. sub init { - my ($class) = @_; + my ($class, %param) = @_; + + my $property_isolation = $param{property_isolation}; my $pdata = $class->private(); - foreach my $k (qw(options plugins plugindata propertyList)) { + foreach my $k (qw(options plugins plugindata propertyList isolatedPropertyList)) { $pdata->{$k} = {} if !$pdata->{$k}; } my $plugins = $pdata->{plugins}; my $propertyList = $pdata->{propertyList}; + my $isolatedPropertyList = $pdata->{isolatedPropertyList}; foreach my $type (keys %$plugins) { my $props = $plugins->{$type}->properties(); foreach my $p (keys %$props) { - die "duplicate property '$p'" if defined($propertyList->{$p}); - my $res = $propertyList->{$p} = {}; + my $res; + if ($property_isolation) { + $res = $isolatedPropertyList->{$type}->{$p} = {}; + } else { + die "duplicate property '$p'" if defined($propertyList->{$p}); + $res = $propertyList->{$p} = {}; + } my $data = $props->{$p}; for my $a (keys %$data) { $res->{$a} = $data->{$a}; @@ -187,8 +368,23 @@ sub init { foreach my $type (keys %$plugins) { my $opts = $plugins->{$type}->options(); foreach my $p (keys %$opts) { - die "undefined property '$p'" if !$propertyList->{$p}; + my $prop; + if ($property_isolation) { + $prop = $isolatedPropertyList->{$type}->{$p}; + } + $prop //= $propertyList->{$p}; + die "undefined property '$p'" if !$prop; + } + + # automatically the properties to options (if not specified explicitly) + if ($property_isolation) { + foreach my $p (keys $isolatedPropertyList->{$type}->%*) { + next if $opts->{$p}; + $opts->{$p} = {}; + $opts->{$p}->{optional} = 1 if $isolatedPropertyList->{$type}->{$p}->{optional}; + } } + $pdata->{options}->{$type} = $opts; } @@ -241,7 +437,7 @@ sub check_value { die "unexpected property '$key'\n" if !defined($opts->{$key}); - my $schema = $pdata->{propertyList}->{$key}; + my $schema = $class->get_property_schema($type, $key); die "unknown property type\n" if !$schema; my $ct = $schema->{type}; @@ -254,7 +450,15 @@ sub check_value { if (!$skipSchemaCheck) { my $errors = {}; - PVE::JSONSchema::check_prop($value, $schema, '', $errors); + + my $checkschema = $schema; + + if ($ct eq 'array') { + die "no item schema for array" if !defined($schema->{items}); + $checkschema = $schema->{items}; + } + + PVE::JSONSchema::check_prop($value, $checkschema, '', $errors); if (scalar(keys %$errors)) { die "$errors->{$key}\n" if $errors->{$key}; die "$errors->{_root}\n" if $errors->{_root}; @@ -287,9 +491,23 @@ sub format_section_header { return "$type: $sectionId\n"; } +sub get_property_schema { + my ($class, $type, $key) = @_; + + my $pdata = $class->private(); + my $opts = $pdata->{options}->{$type}; + + my $schema; + if ($class->has_isolated_properties()) { + $schema = $pdata->{isolatedPropertyList}->{$type}->{$key}; + } + $schema //= $pdata->{propertyList}->{$key}; + + return $schema; +} sub parse_config { - my ($class, $filename, $raw) = @_; + my ($class, $filename, $raw, $allow_unknown) = @_; my $pdata = $class->private(); @@ -311,6 +529,16 @@ sub parse_config { } }; + my $is_array = sub { + my ($type, $key) = @_; + + my $schema = $class->get_property_schema($type, $key); + die "unknown property type\n" if !$schema; + + return $schema->{type} eq 'array'; + }; + + my $errors = []; while (@lines) { my $line = $nextline->(); next if !$line; @@ -319,26 +547,31 @@ sub parse_config { my ($type, $sectionId, $errmsg, $config) = $class->parse_section_header($line); if ($config) { - my $ignore = 0; + my $skip = 0; + my $unknown = 0; my $plugin; if ($errmsg) { - $ignore = 1; + $skip = 1; chomp $errmsg; warn "$errprefix (skip section '$sectionId'): $errmsg\n"; } elsif (!$type) { - $ignore = 1; + $skip = 1; warn "$errprefix (skip section '$sectionId'): missing type - internal error\n"; } else { if (!($plugin = $pdata->{plugins}->{$type})) { - $ignore = 1; - warn "$errprefix (skip section '$sectionId'): unsupported type '$type'\n"; + if ($allow_unknown) { + $unknown = 1; + } else { + $skip = 1; + warn "$errprefix (skip section '$sectionId'): unsupported type '$type'\n"; + } } } while ($line = $nextline->()) { - next if $ignore; # skip + next if $skip; # skip $errprefix = "file $filename line $lineno"; @@ -346,20 +579,51 @@ sub parse_config { my ($k, $v) = ($1, $3); eval { - die "duplicate attribute\n" if defined($config->{$k}); - $config->{$k} = $plugin->check_value($type, $k, $v, $sectionId); + if ($unknown) { + if (!defined($config->{$k})) { + $config->{$k} = $v; + } else { + if (!ref($config->{$k})) { + $config->{$k} = [$config->{$k}]; + } + push $config->{$k}->@*, $v; + } + } elsif ($is_array->($type, $k)) { + $v = $plugin->check_value($type, $k, $v, $sectionId); + $config->{$k} = [] if !defined($config->{$k}); + push $config->{$k}->@*, $v; + } else { + die "duplicate attribute\n" if defined($config->{$k}); + $v = $plugin->check_value($type, $k, $v, $sectionId); + $config->{$k} = $v; + } }; - warn "$errprefix (section '$sectionId') - unable to parse value of '$k': $@" if $@; + if (my $err = $@) { + warn "$errprefix (section '$sectionId') - unable to parse value of '$k': $err"; + push @$errors, { + context => $errprefix, + section => $sectionId, + key => $k, + err => $err, + }; + } } else { warn "$errprefix (section '$sectionId') - ignore config line: $line\n"; } } - if (!$ignore && $type && $plugin && $config) { + if ($unknown) { $config->{type} = $type; - eval { $ids->{$sectionId} = $plugin->check_config($sectionId, $config, 1, 1); }; - warn "$errprefix (skip section '$sectionId'): $@" if $@; + $ids->{$sectionId} = $config; + $order->{$sectionId} = $pri++; + } elsif (!$skip && $type && $plugin && $config) { + $config->{type} = $type; + if (!$unknown) { + $config = eval { $config = $plugin->check_config($sectionId, $config, 1, 1); }; + warn "$errprefix (skip section '$sectionId'): $@" if $@; + } + $ids->{$sectionId} = $config; $order->{$sectionId} = $pri++; } @@ -368,8 +632,12 @@ sub parse_config { } } - - my $cfg = { ids => $ids, order => $order, digest => $digest}; + my $cfg = { + ids => $ids, + order => $order, + digest => $digest + }; + $cfg->{errors} = $errors if scalar(@$errors) > 0; return $cfg; } @@ -420,16 +688,22 @@ my $format_config_line = sub { if ($ct eq 'boolean') { return "\t$key " . ($value ? 1 : 0) . "\n" if defined($value); + } elsif ($ct eq 'array') { + die "property '$key' is not an array" if ref($value) ne 'ARRAY'; + my $result = ''; + for my $line ($value->@*) { + $result .= "\t$key $line\n" if $value ne ''; + } + return $result; } else { return "\t$key $value\n" if "$value" ne ''; } }; sub write_config { - my ($class, $filename, $cfg) = @_; + my ($class, $filename, $cfg, $allow_unknown) = @_; my $pdata = $class->private(); - my $propertyList = $pdata->{propertyList}; my $out = ''; @@ -451,16 +725,38 @@ sub write_config { my $scfg = $ids->{$sectionId}; my $type = $scfg->{type}; my $opts = $pdata->{options}->{$type}; + my $global_opts = $pdata->{options}->{__global}; - die "unknown section type '$type'\n" if !$opts; + die "unknown section type '$type'\n" if !$opts && !$allow_unknown; my $done_hash = {}; my $data = $class->format_section_header($type, $sectionId, $scfg, $done_hash); + + if (!$opts && $allow_unknown) { + $done_hash->{type} = 1; + my @first = exists($scfg->{comment}) ? ('comment') : (); + for my $k (@first, sort keys %$scfg) { + next if defined($done_hash->{$k}); + $done_hash->{$k} = 1; + my $v = $scfg->{$k}; + my $ref = ref($v); + if (defined($ref) && $ref eq 'ARRAY') { + $data .= "\t$k $_\n" for $v->@*; + } else { + $data .= "\t$k $v\n"; + } + } + $out .= "$data\n"; + next; + } + + if ($scfg->{comment} && !$done_hash->{comment}) { my $k = 'comment'; my $v = $class->encode_value($type, $k, $scfg->{$k}); - $data .= &$format_config_line($propertyList->{$k}, $k, $v); + my $prop = $class->get_property_schema($type, $k); + $data .= &$format_config_line($prop, $k, $v); } $data .= "\tdisable\n" if $scfg->{disable} && !$done_hash->{disable}; @@ -477,7 +773,8 @@ sub write_config { die "section '$sectionId' - missing value for required option '$k'\n" if !defined ($v); $v = $class->encode_value($type, $k, $v); - $data .= &$format_config_line($propertyList->{$k}, $k, $v); + my $prop = $class->get_property_schema($type, $k); + $data .= &$format_config_line($prop, $k, $v); } foreach my $k (@option_keys) { @@ -485,7 +782,8 @@ sub write_config { my $v = $scfg->{$k}; next if !defined($v); $v = $class->encode_value($type, $k, $v); - $data .= &$format_config_line($propertyList->{$k}, $k, $v); + my $prop = $class->get_property_schema($type, $k); + $data .= &$format_config_line($prop, $k, $v); } $out .= "$data\n"; @@ -500,4 +798,19 @@ sub assert_if_modified { PVE::Tools::assert_if_modified($cfg->{digest}, $digest); } +sub delete_from_config { + my ($config, $option_schema, $new_options, $to_delete) = @_; + + for my $k ($to_delete->@*) { + my $d = $option_schema->{$k} || die "no such option '$k'\n"; + die "unable to delete required option '$k'\n" if !$d->{optional}; + die "unable to delete fixed option '$k'\n" if $d->{fixed}; + die "cannot set and delete property '$k' at the same time!\n" + if defined($new_options->{$k}); + delete $config->{$k}; + } + + return $config; +} + 1; diff --git a/src/PVE/Subscription.pm b/src/PVE/Subscription.pm deleted file mode 100644 index 1571152..0000000 --- a/src/PVE/Subscription.pm +++ /dev/null @@ -1,213 +0,0 @@ -package PVE::Subscription; - -use strict; -use warnings; -use Digest::MD5 qw(md5_hex md5_base64); -use MIME::Base64; -use HTTP::Request; -use URI; -use LWP::UserAgent; -use JSON; - -use PVE::Tools; -use PVE::INotify; - -# How long the local key is valid for in between remote checks -our $localkeydays = 15; -# How many days to allow after local key expiry before blocking -# access if connection cannot be made -my $allowcheckfaildays = 5; - -my $shared_key_data = "kjfdlskfhiuewhfk947368"; - -my $saved_fields = { - key => 1, - checktime => 1, - status => 1, - message => 0, - validdirectory => 1, - productname => 1, - regdate => 1, - nextduedate => 1, -}; - -sub check_fields { - my ($info, $server_id) = @_; - - foreach my $f (qw(status checktime key)) { - if (!$info->{$f}) { - die "Missing field '$f'\n"; - } - } - - if ($info->{checktime} > time()) { - die "Last check time in future.\n"; - } - - return undef if $info->{status} ne 'Active'; - - foreach my $f (keys %$saved_fields) { - next if !$saved_fields->{$f}; - if (!$info->{$f}) { - die "Missing field '$f'\n"; - } - } - - my $found; - foreach my $hwid (split(/,/, $info->{validdirectory})) { - if ($hwid eq $server_id) { - $found = 1; - last; - } - } - die "Server ID does not match\n" if !$found; - - return undef; -} - -sub check_subscription { - my ($key, $server_id, $proxy) = @_; - - my $whmcsurl = "https://shop.maurer-it.com"; - - my $uri = "$whmcsurl/modules/servers/licensing/verify.php"; - - my $check_token = time() . md5_hex(rand(8999999999) + 1000000000) . $key; - - my $params = { - licensekey => $key, - dir => $server_id, - domain => 'www.proxmox.com', - ip => 'localhost', - check_token => $check_token, - }; - - my $req = HTTP::Request->new('POST' => $uri); - $req->header('Content-Type' => 'application/x-www-form-urlencoded'); - # We use a temporary URI object to format - # the application/x-www-form-urlencoded content. - my $url = URI->new('http:'); - $url->query_form(%$params); - my $content = $url->query; - $req->header('Content-Length' => length($content)); - $req->content($content); - - my $ua = LWP::UserAgent->new(protocols_allowed => ['https'], timeout => 30); - - if ($proxy) { - $ua->proxy(['https'], $proxy); - } else { - $ua->env_proxy; - } - - my $response = $ua->request($req); - my $code = $response->code; - - if ($code != 200) { - my $msg = $response->message || 'unknown'; - die "Invalid response from server: $code $msg\n"; - } - - my $raw = $response->decoded_content; - - my $subinfo = {}; - while ($raw =~ m/<(.*?)>([^<]+)<\/\1>/g) { - my ($k, $v) = ($1, $2); - next if !($k eq 'md5hash' || defined($saved_fields->{$k})); - $subinfo->{$k} = $v; - } - $subinfo->{checktime} = time(); - $subinfo->{key} = $key; - - if ($subinfo->{message}) { - $subinfo->{message} =~ s/^Directory Invalid$/Invalid Server ID/; - } - - my $emd5sum = md5_hex($shared_key_data . $check_token); - if ($subinfo->{status} && $subinfo->{status} eq 'Active') { - if (!$subinfo->{md5hash} || ($subinfo->{md5hash} ne $emd5sum)) { - die "MD5 Checksum Verification Failed\n"; - } - } - - delete $subinfo->{md5hash}; - - check_fields($subinfo, $server_id); - - return $subinfo; -} - -sub read_subscription { - my ($server_id, $filename, $fh) = @_; - - my $info = { status => 'Invalid' }; - - my $key = <$fh>; # first line is the key - chomp $key; - - $info->{key} = $key; - - my $csum = <$fh>; # second line is a checksum - - my $data = ''; - while (defined(my $line = <$fh>)) { - $data .= $line; - } - - if ($key && $csum && $data) { - - chomp $csum; - - my $localinfo = {}; - - eval { - my $json_text = decode_base64($data); - $localinfo = decode_json($json_text); - my $newcsum = md5_base64($localinfo->{checktime} . $data . $shared_key_data); - die "checksum failure\n" if $csum ne $newcsum; - - check_fields($localinfo, $server_id); - - my $age = time() - $localinfo->{checktime}; - - my $maxage = ($localkeydays + $allowcheckfaildays)*60*60*24; - die "subscription info too old\n" - if ($localinfo->{status} eq 'Active') && ($age > $maxage); - }; - if (my $err = $@) { - chomp $err; - $info->{message} = $err; - } else { - $info = $localinfo; - } - } - - return $info; -} - -sub update_apt_auth { - my ($key, $server_id) = @_; - - my $auth = { 'enterprise.proxmox.com' => { login => $key, password => $server_id } }; - PVE::INotify::update_file('apt-auth', $auth); -} - -sub write_subscription { - my ($server_id, $filename, $fh, $info) = @_; - - if ($info->{status} eq 'New') { - PVE::Tools::safe_print($filename, $fh, "$info->{key}\n"); - } else { - my $json = encode_json($info); - my $data = encode_base64($json); - my $csum = md5_base64($info->{checktime} . $data . $shared_key_data); - - my $raw = "$info->{key}\n$csum\n$data"; - - PVE::Tools::safe_print($filename, $fh, $raw); - } - - update_apt_auth($info->{key}, $server_id); -} - -1; diff --git a/src/PVE/SysFSTools.pm b/src/PVE/SysFSTools.pm index a8d9a7f..57f0ac8 100644 --- a/src/PVE/SysFSTools.pm +++ b/src/PVE/SysFSTools.pm @@ -8,7 +8,8 @@ use IO::File; use PVE::Tools qw(file_read_firstline dir_glob_foreach); my $pcisysfs = "/sys/bus/pci"; -my $pciregex = "([a-f0-9]{4}):([a-f0-9]{2}):([a-f0-9]{2})\.([a-f0-9])"; +my $domainregex = "[a-f0-9]{4,}"; +my $pciregex = "($domainregex):([a-f0-9]{2}):([a-f0-9]{2})\.([a-f0-9])"; my $parse_pci_ids = sub { my $ids = {}; @@ -33,6 +34,12 @@ my $parse_pci_ids = sub { return $ids; }; +my sub normalize_pci_id { + my ($id) = @_; + $id = "0000:$id" if $id !~ m/^${domainregex}:/; + return $id; +}; + # returns a list of pci devices # # filter is either a string (then it tries to match to the id) @@ -148,14 +155,11 @@ sub lspci { sub get_mdev_types { my ($id) = @_; - my $fullid = $id; - if ($id !~ m/^[0-9a-fA-f]{4}:/) { - $fullid = "0000:$id"; - } + $id = normalize_pci_id($id); my $types = []; - my $mdev_path = "$pcisysfs/devices/$fullid/mdev_supported_types"; + my $mdev_path = "$pcisysfs/devices/$id/mdev_supported_types"; if (!-d $mdev_path) { return $types; } @@ -168,11 +172,16 @@ sub get_mdev_types { my $available = int(file_read_firstline("$type_path/available_instances")); my $description = PVE::Tools::file_get_contents("$type_path/description"); - push @$types, { + my $entry = { type => $type, description => $description, available => $available, }; + + my $name = file_read_firstline("$type_path/name"); + $entry->{name} = $name if defined($name); + + push @$types, $entry; }); return $types; @@ -197,26 +206,28 @@ sub file_write { } sub pci_device_info { - my ($name) = @_; + my ($name, $verbose) = @_; my $res; return undef if $name !~ m/^${pciregex}$/; my ($domain, $bus, $slot, $func) = ($1, $2, $3, $4); - my $irq = file_read_firstline("$pcisysfs/devices/$name/irq"); + my $devdir = "$pcisysfs/devices/$name"; + + my $irq = file_read_firstline("$devdir/irq"); return undef if !defined($irq) || $irq !~ m/^\d+$/; - my $vendor = file_read_firstline("$pcisysfs/devices/$name/vendor"); + my $vendor = file_read_firstline("$devdir/vendor"); return undef if !defined($vendor) || $vendor !~ s/^0x//; - my $product = file_read_firstline("$pcisysfs/devices/$name/device"); + my $product = file_read_firstline("$devdir/device"); return undef if !defined($product) || $product !~ s/^0x//; $res = { name => $name, vendor => $vendor, - product => $product, + device => $product, domain => $domain, bus => $bus, slot => $slot, @@ -225,6 +236,25 @@ sub pci_device_info { has_fl_reset => -f "$pcisysfs/devices/$name/reset" || 0, }; + if ($verbose) { + my $sub_vendor = file_read_firstline("$devdir/subsystem_vendor"); + $sub_vendor =~ s/^0x// if defined($sub_vendor); + my $sub_device = file_read_firstline("$devdir/subsystem_device"); + $sub_device =~ s/^0x// if defined($sub_device); + + $res->{subsystem_vendor} = $sub_vendor if defined($sub_vendor); + $res->{subsystem_device} = $sub_device if defined($sub_device); + + if (-e "$devdir/iommu_group") { + my ($iommugroup) = (readlink("$devdir/iommu_group") =~ m/\/(\d+)$/); + $res->{iommugroup} = int($iommugroup); + } + + if (-d "$devdir/mdev_supported_types") { + $res->{mdev} = 1; + } + } + return $res; } @@ -253,7 +283,7 @@ sub pci_dev_bind_to_vfio { my $testdir = "$vfio_basedir/$name"; return 1 if -d $testdir; - my $data = "$dev->{vendor} $dev->{product}"; + my $data = "$dev->{vendor} $dev->{device}"; return undef if !file_write("$vfio_basedir/new_id", $data); my $fn = "$pcisysfs/devices/$name/driver/unbind"; @@ -279,19 +309,18 @@ sub pci_dev_group_bind_to_vfio { } die "Cannot find vfio-pci module!\n" if !-d $vfio_basedir; - $pciid = "0000:$pciid" if $pciid !~ m/^[0-9a-f]{4}:/; + $pciid = normalize_pci_id($pciid); # get IOMMU group devices opendir(my $D, "$pcisysfs/devices/$pciid/iommu_group/devices/") || die "Cannot open iommu_group: $!\n"; - my @devs = grep /^[0-9a-f]{4}:/, readdir($D); + my @devs = grep /^${domainregex}:/, readdir($D); closedir($D); foreach my $pciid (@devs) { $pciid =~ m/^([:\.0-9a-f]+)$/ or die "PCI ID $pciid not valid!\n"; - # pci bridges, switches or root ports are not supported - # they have a pci_bus subdirectory so skip them - next if (-e "$pcisysfs/devices/$pciid/pci_bus"); + # PCI bridges, switches or root-ports aren't supported and all have a pci_bus dir we can test + next if (-e "$pcisysfs/devices/$pciid/pci_bus"); my $info = pci_device_info($1); pci_dev_bind_to_vfio($info) || die "Cannot bind $pciid to vfio\n"; @@ -303,7 +332,7 @@ sub pci_dev_group_bind_to_vfio { sub pci_create_mdev_device { my ($pciid, $uuid, $type) = @_; - $pciid = "0000:$pciid" if $pciid !~ m/^[0-9a-f]{4}:/; + $pciid = normalize_pci_id($pciid); my $basedir = "$pcisysfs/devices/$pciid"; my $mdev_dir = "$basedir/mdev_supported_types"; @@ -337,20 +366,6 @@ sub pci_create_mdev_device { return undef; } -sub pci_cleanup_mdev_device { - my ($pciid, $uuid) = @_; - - $pciid = "0000:$pciid" if $pciid !~ m/^[0-9a-f]{4}:/; - - my $basedir = "$pcisysfs/devices/$pciid/$uuid"; - - if (! -e $basedir) { - return 1; # no cleanup necessary if it does not exist - } - - return file_write("$basedir/remove", "1"); -} - # encode the hostpci index and vmid into the uuid sub generate_mdev_uuid { my ($vmid, $index) = @_; diff --git a/src/PVE/Syscall.pm b/src/PVE/Syscall.pm index 2d5019f..9ef3d5d 100644 --- a/src/PVE/Syscall.pm +++ b/src/PVE/Syscall.pm @@ -1,5 +1,8 @@ package PVE::Syscall; +use strict; +use warnings; + my %syscalls; my %fsmount_constants; BEGIN { @@ -13,19 +16,26 @@ BEGIN { openat => &SYS_openat, close => &SYS_close, mkdirat => &SYS_mkdirat, + mknod => &SYS_mknod, faccessat => &SYS_faccessat, setresuid => &SYS_setresuid, fchownat => &SYS_fchownat, mount => &SYS_mount, - - # These use asm-generic, so they're the same across (sane) architectures. We use numbers - # since they're not in perl's syscall.ph yet... - open_tree => 428, - move_mount => 429, - fsopen => 430, - fsconfig => 431, - fsmount => 432, - fspick => 433, + renameat2 => &SYS_renameat2, + open_tree => &SYS_open_tree, + move_mount => &SYS_move_mount, + fsopen => &SYS_fsopen, + fsconfig => &SYS_fsconfig, + fsmount => &SYS_fsmount, + fspick => &SYS_fspick, + getxattr => &SYS_getxattr, + setxattr => &SYS_setxattr, + fgetxattr => &SYS_fgetxattr, + fsetxattr => &SYS_fsetxattr, + prctl => &SYS_prctl, + + # Below aren't yet in perl's syscall.ph but use asm-generic, so the same across (sane) archs + # -> none unknown currently, yay ); %fsmount_constants = ( diff --git a/src/PVE/Systemd.pm b/src/PVE/Systemd.pm index 85b35a3..07c912e 100644 --- a/src/PVE/Systemd.pm +++ b/src/PVE/Systemd.pm @@ -3,10 +3,12 @@ package PVE::Systemd; use strict; use warnings; -use Net::DBus qw(dbus_uint32 dbus_uint64); +use Net::DBus qw(dbus_uint32 dbus_uint64 dbus_boolean); use Net::DBus::Callback; use Net::DBus::Reactor; +use PVE::Tools qw(file_set_contents file_get_contents trim); + sub escape_unit { my ($val, $is_path) = @_; @@ -105,7 +107,9 @@ sub enter_systemd_scope { foreach my $key (keys %extra) { if ($key eq 'Slice' || $key eq 'KillMode') { push @{$properties}, [$key, $extra{$key}]; - } elsif ($key eq 'CPUShares') { + } elsif ($key eq 'SendSIGKILL') { + push @{$properties}, [$key, dbus_boolean($extra{$key})]; + } elsif ($key eq 'CPUShares' || $key eq 'CPUWeight' || $key eq 'TimeoutStopUSec') { push @{$properties}, [$key, dbus_uint64($extra{$key})]; } elsif ($key eq 'CPUQuota') { push @{$properties}, ['CPUQuotaPerSecUSec', @@ -163,4 +167,91 @@ sub wait_for_unit_removed($;$) { }, $timeout); } +sub is_unit_active($;$) { + my ($unit) = @_; + + my $bus = Net::DBus->system(); + my $reactor = Net::DBus::Reactor->main(); + + my $service = $bus->get_service('org.freedesktop.systemd1'); + my $if = $service->get_object('/org/freedesktop/systemd1', 'org.freedesktop.systemd1.Manager'); + + my $unit_path = eval { $if->GetUnit($unit) } + or return 0; + $if = $service->get_object($unit_path, 'org.freedesktop.systemd1.Unit') + or return 0; + my $state = $if->ActiveState; + return defined($state) && $state eq 'active'; +} + +sub read_ini { + my ($filename) = @_; + + my $content = file_get_contents($filename); + my @lines = split /\n/, $content; + + my $result = {}; + my $section; + + foreach my $line (@lines) { + $line = trim($line); + if ($line =~ m/^\[([^\]]+)\]/) { + $section = $1; + if (!defined($result->{$section})) { + $result->{$section} = {}; + } + } elsif ($line =~ m/^(.*?)=(.*)$/) { + my ($key, $val) = ($1, $2); + if (!$section) { + warn "key value pair found without section, skipping\n"; + next; + } + + if ($result->{$section}->{$key}) { + # make duplicate properties to arrays to keep the order + my $prop = $result->{$section}->{$key}; + if (ref($prop) eq 'ARRAY') { + push @$prop, $val; + } else { + $result->{$section}->{$key} = [$prop, $val]; + } + } else { + $result->{$section}->{$key} = $val; + } + } + # ignore everything else + } + + return $result; +}; + +sub write_ini { + my ($ini, $filename) = @_; + + my $content = ""; + + foreach my $sname (sort keys %$ini) { + my $section = $ini->{$sname}; + + $content .= "[$sname]\n"; + + foreach my $pname (sort keys %$section) { + my $prop = $section->{$pname}; + + if (!ref($prop)) { + $content .= "$pname=$prop\n"; + } elsif (ref($prop) eq 'ARRAY') { + foreach my $val (@$prop) { + $content .= "$pname=$val\n"; + } + } else { + die "invalid property '$pname'\n"; + } + } + $content .= "\n"; + } + + file_set_contents($filename, $content); +}; + 1; diff --git a/src/PVE/Ticket.pm b/src/PVE/Ticket.pm index d522401..c5508ed 100644 --- a/src/PVE/Ticket.pm +++ b/src/PVE/Ticket.pm @@ -8,6 +8,7 @@ use Crypt::OpenSSL::RSA; use MIME::Base64; use Digest::SHA; use Time::HiRes qw(gettimeofday); +use URI::Escape; use PVE::Exception qw(raise); @@ -33,13 +34,7 @@ sub verify_csrf_prevention_token { my $timestamp = $1; my $ttime = hex($timestamp); - my $digest; - if (length($sig) == 27) { - # detected sha1 csrf token from older proxy, fallback. FIXME: remove with 7.0 - $digest = Digest::SHA::sha1_base64("$timestamp:$username", $secret); - } else { - $digest = Digest::SHA::hmac_sha256_base64("$timestamp:$username", $secret); - } + my $digest = Digest::SHA::hmac_sha256_base64("$timestamp:$username", $secret); my $age = time() - $ttime; return 1 if ($digest eq $sig) && ($age > $min_age) && @@ -60,7 +55,10 @@ sub assemble_rsa_ticket { my $plain = "$prefix:"; - $plain .= "$data:" if defined($data); + if (defined($data)) { + $data = uri_escape($data, ':'); + $plain .= "$data:"; + } $plain .= $timestamp; @@ -88,6 +86,10 @@ sub verify_rsa_ticket { my $age = time() - $ttime; + if (defined($data)) { + $data = uri_unescape($data); + } + if (($age > $min_age) && ($age < $max_age)) { if (defined($data)) { return wantarray ? ($data, $age) : $data; diff --git a/src/PVE/Tools.pm b/src/PVE/Tools.pm index 7d33683..766c809 100644 --- a/src/PVE/Tools.pm +++ b/src/PVE/Tools.pm @@ -2,30 +2,31 @@ package PVE::Tools; use strict; use warnings; -use POSIX qw(EINTR EEXIST EOPNOTSUPP); -use IO::Socket::IP; -use Socket qw(AF_INET AF_INET6 AI_ALL AI_V4MAPPED AI_CANONNAME SOCK_DGRAM - IPPROTO_TCP); -use IO::Select; + +use Date::Format qw(time2str); +use Digest::MD5; +use Digest::SHA; +use Encode; +use Fcntl qw(:DEFAULT :flock); use File::Basename; use File::Path qw(make_path); use Filesys::Df (); # don't overwrite our df() -use IO::Pipe; -use IO::File; use IO::Dir; +use IO::File; use IO::Handle; +use IO::Pipe; +use IO::Select; +use IO::Socket::IP; use IPC::Open3; -use Fcntl qw(:DEFAULT :flock); -use base 'Exporter'; -use URI::Escape; -use Encode; -use Digest::SHA; use JSON; -use Text::ParseWords; +use POSIX qw(EINTR EEXIST EOPNOTSUPP); +use Scalar::Util 'weaken'; +use Socket qw(AF_INET AF_INET6 AI_ALL AI_V4MAPPED AI_CANONNAME SOCK_DGRAM IPPROTO_TCP); use String::ShellQuote; +use Text::ParseWords; use Time::HiRes qw(usleep gettimeofday tv_interval alarm); -use Scalar::Util 'weaken'; -use Date::Format qw(time2str); +use URI::Escape; +use base 'Exporter'; use PVE::Syscall; @@ -48,6 +49,7 @@ template_replace safe_print trim extract_param +extract_sensitive_params file_copy get_host_arch O_PATH @@ -60,6 +62,20 @@ CLONE_NEWIPC CLONE_NEWUSER CLONE_NEWPID CLONE_NEWNET +MS_RDONLY +MS_NOSUID +MS_NODEV +MS_NOEXEC +MS_SYNCHRONOUS +MS_REMOUNT +MS_MANDLOCK +MS_DIRSYNC +MS_NOSYMFOLLOW +MS_NOATIME +MS_NODIRATIME +MS_BIND +MS_MOVE +MS_REC ); my $pvelogdir = "/var/log/pve"; @@ -86,6 +102,9 @@ our $IPV6RE = "(?:" . our $IPRE = "(?:$IPV4RE|$IPV6RE)"; +our $EMAIL_USER_RE = qr/[\w\+\-\~]+(\.[\w\+\-\~]+)*/; +our $EMAIL_RE = qr/$EMAIL_USER_RE@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*/; + use constant {CLONE_NEWNS => 0x00020000, CLONE_NEWUTS => 0x04000000, CLONE_NEWIPC => 0x08000000, @@ -95,11 +114,33 @@ use constant {CLONE_NEWNS => 0x00020000, use constant {O_PATH => 0x00200000, O_CLOEXEC => 0x00080000, - O_TMPFILE => 0x00410000}; # This includes O_DIRECTORY + O_TMPFILE => 0x00400000 | O_DIRECTORY}; use constant {AT_EMPTY_PATH => 0x1000, AT_FDCWD => -100}; +# from +use constant {RENAME_NOREPLACE => (1 << 0), + RENAME_EXCHANGE => (1 << 1), + RENAME_WHITEOUT => (1 << 2)}; + +use constant { + MS_RDONLY => (1), + MS_NOSUID => (1 << 1), + MS_NODEV => (1 << 2), + MS_NOEXEC => (1 << 3), + MS_SYNCHRONOUS => (1 << 4), + MS_REMOUNT => (1 << 5), + MS_MANDLOCK => (1 << 6), + MS_DIRSYNC => (1 << 7), + MS_NOSYMFOLLOW => (1 << 8), + MS_NOATIME => (1 << 10), + MS_NODIRATIME => (1 << 11), + MS_BIND => (1 << 12), + MS_MOVE => (1 << 13), + MS_REC => (1 << 14), +}; + sub run_with_timeout { my ($timeout, $code, @param) = @_; @@ -108,11 +149,12 @@ sub run_with_timeout { my $prev_alarm = alarm 0; # suspend outer alarm early my $sigcount = 0; + my $got_timeout = 0; my $res; eval { - local $SIG{ALRM} = sub { $sigcount++; die "got timeout\n"; }; + local $SIG{ALRM} = sub { $sigcount++; $got_timeout = 1; die "got timeout\n"; }; local $SIG{PIPE} = sub { $sigcount++; die "broken pipe\n" }; local $SIG{__DIE__}; # see SA bug 4631 @@ -132,9 +174,10 @@ sub run_with_timeout { # this shouldn't happen anymore? die "unknown error" if $sigcount && !$err; # seems to happen sometimes - die $err if $err; + # assume that user handles timeout err if called in list context + die $err if $err && (!wantarray || !$got_timeout); - return $res; + return wantarray ? ($res, $got_timeout) : $res; } # flock: we use one file handle per process, so lock file @@ -226,7 +269,7 @@ sub lock_file { } sub file_set_contents { - my ($filename, $data, $perm) = @_; + my ($filename, $data, $perm, $force_utf8) = @_; $perm = 0644 if !defined($perm); @@ -241,6 +284,9 @@ sub file_set_contents { } } die "unable to open file '$tmpname' - $!\n" if !$fh; + + binmode($fh, ":encoding(UTF-8)") if $force_utf8; + die "unable to write '$tmpname' - $!\n" unless print $fh $data; die "closing file '$tmpname' failed - $!\n" unless close $fh; }; @@ -281,7 +327,10 @@ sub file_read_firstline { my ($filename) = @_; my $fh = IO::File->new ($filename, "r"); - return undef if !$fh; + if (!$fh) { + return undef if $! == POSIX::ENOENT; + die "file '$filename' exists but open for reading failed - $!\n"; + } my $res = <$fh>; chomp $res if $res; $fh->close; @@ -292,7 +341,7 @@ sub safe_read_from { my ($fh, $max, $oneline, $filename) = @_; # pmxcfs file size limit - $max = 512*1024 if !$max; + $max = 1024 * 1024 if !$max; my $subject = defined($filename) ? "file '$filename'" : 'input'; @@ -444,13 +493,12 @@ sub run_command { $pid = open3($writer, $reader, $error, @$cmd) || die $!; - # if we pipe fron STDIN, open3 closes STDIN, so we we - # a perl warning "Filehandle STDIN reopened as GENXYZ .. " - # as soon as we open a new file. + # if we pipe fron STDIN, open3 closes STDIN, so we get a perl warning like + # "Filehandle STDIN reopened as GENXYZ .. " as soon as we open a new file. # to avoid that we open /dev/null if (!ref($writer) && !defined(fileno(STDIN))) { POSIX::close(0); - open(STDIN, "new(); $select->add($reader) if ref($reader); $select->add($error); @@ -566,7 +614,7 @@ sub run_command { } } - alarm(0); + alarm(0); }; my $err = $@; @@ -807,6 +855,28 @@ sub extract_param { return $res; } +# For extracting sensitive keys (e.g. password), to avoid writing them to www-data owned configs +sub extract_sensitive_params :prototype($$$) { + my ($param, $sensitive_list, $delete_list) = @_; + + my %delete = map { $_ => 1 } ($delete_list || [])->@*; + + my $sensitive = {}; + for my $opt (@$sensitive_list) { + # handle deletions as explicitly setting `undef`, so subs which only have $param but not + # $delete_list available can recognize them. Afterwards new values may override. + if (exists($delete{$opt})) { + $sensitive->{$opt} = undef; + } + + if (defined(my $value = extract_param($param, $opt))) { + $sensitive->{$opt} = $value; + } + } + + return $sensitive; +} + # Note: we use this to wait until vncterm/spiceterm is ready sub wait_for_vnc_port { my ($port, $family, $timeout) = @_; @@ -981,9 +1051,16 @@ sub run_fork_with_timeout { $res = $child_res->{result}; $error = $child_res->{error}; }; + + my $got_timeout = 0; + my $wantarray = wantarray; # so it can be queried inside eval eval { if (defined($timeout)) { - run_with_timeout($timeout, $readvalues); + if ($wantarray) { + (undef, $got_timeout) = run_with_timeout($timeout, $readvalues); + } else { + run_with_timeout($timeout, $readvalues); + } } else { $readvalues->(); } @@ -991,13 +1068,14 @@ sub run_fork_with_timeout { warn $@ if $@; $pipe_out->close(); kill('KILL', $child); + # FIXME: hangs if $child doesn't exits?! (D state) waitpid($child, 0); alarm $prev_alarm; die "interrupted by unexpected signal\n" if $sig_received; die $error if $error; - return $res; + return wantarray ? ($res, $got_timeout) : $res; } sub run_fork { @@ -1130,6 +1208,8 @@ sub upid_read_status { return 'OK'; } elsif ($line =~ m/^TASK ERROR: (.+)$/) { return $1; + } elsif ($line =~ m/^TASK (WARNINGS: \d+)$/) { + return $1; } else { return "unexpected status"; } @@ -1137,6 +1217,31 @@ sub upid_read_status { return "unable to read tail (got $br bytes)"; } +# Check if the status returned by upid_read_status is an error status. +# If the status could not be parsed it's also treated as an error. +sub upid_status_is_error { + my ($status) = @_; + + return !($status eq 'OK' || $status =~ m/^WARNINGS: \d+$/); +} + +# takes the parsed status and returns the type, either ok, warning, error or unknown +sub upid_normalize_status_type { + my ($status) = @_; + + if (!$status) { + return 'unknown'; + } elsif ($status eq 'OK') { + return 'ok'; + } elsif ($status =~ m/^WARNINGS: \d+$/) { + return 'warning'; + } elsif ($status eq 'unexpected status') { + return 'unknown'; + } else { + return 'error'; + } +} + # useful functions to store comments in config files sub encode_text { my ($text) = @_; @@ -1152,8 +1257,7 @@ sub decode_text { return Encode::decode("utf8", uri_unescape($data)); } -# depreciated - do not use! -# we now decode all parameters by default +# NOTE: deprecated - do not use! we now decode all parameters by default sub decode_utf8_parameters { my ($param) = @_; @@ -1207,54 +1311,76 @@ sub split_args { return $str ? [ Text::ParseWords::shellwords($str) ] : []; } -sub dump_logfile { - my ($filename, $start, $limit, $filter) = @_; - - my $lines = []; - my $count = 0; +sub dump_logfile_by_filehandle { + my ($fh, $filter, $state) = @_; - my $fh = IO::File->new($filename, "r"); - if (!$fh) { - $count++; - push @$lines, { n => $count, t => "unable to open file - $!"}; - return ($count, $lines); - } - - $start = 0 if !$start; - $limit = 50 if !$limit; + my $count = ($state->{count} //= 0); + my $lines = ($state->{lines} //= []); + my $start = ($state->{start} //= 0); + my $limit = ($state->{limit} //= 50); + my $final = ($state->{final} //= 1); + my $read_until_end = ($state->{read_until_end} //= $limit == 0); my $line; - if ($filter) { # duplicate code, so that we do not slow down normal path while (defined($line = <$fh>)) { - next if $line !~ m/$filter/; + if (ref($filter) eq 'CODE') { + next if !$filter->($line); + } else { + next if $line !~ m/$filter/; + } next if $count++ < $start; - next if $limit <= 0; + if (!$read_until_end) { + next if $limit <= 0; + $limit--; + } chomp $line; push @$lines, { n => $count, t => $line}; - $limit--; } } else { while (defined($line = <$fh>)) { next if $count++ < $start; - next if $limit <= 0; + if (!$read_until_end) { + next if $limit <= 0; + $limit--; + } chomp $line; push @$lines, { n => $count, t => $line}; - $limit--; } } - close($fh); - # HACK: ExtJS store.guaranteeRange() does not like empty array # so we add a line - if (!$count) { + if (!$count && $final) { $count++; push @$lines, { n => $count, t => "no content"}; } - return ($count, $lines); + $state->{count} = $count; + $state->{limit} = $limit; +} + +sub dump_logfile { + my ($filename, $start, $limit, $filter) = @_; + + my $fh = IO::File->new($filename, "r"); + if (!$fh) { + return (1, { n => 1, t => "unable to open file - $!"}); + } + + my %state = ( + 'count' => 0, + 'lines' => [], + 'start' => $start, + 'limit' => $limit, + ); + + dump_logfile_by_filehandle($fh, $filter, \%state); + + close($fh); + + return ($state{'count'}, $state{'lines'}); } sub dump_journal { @@ -1269,7 +1395,7 @@ sub dump_journal { my $parser = sub { my $line = shift; - return if $count++ < $start; + return if $count++ < $start; return if $limit <= 0; push @$lines, { n => int($count), t => $line}; $limit--; @@ -1362,8 +1488,10 @@ sub unpack_sockaddr_in46 { sub getaddrinfo_all { my ($hostname, @opts) = @_; - my %hints = ( flags => AI_V4MAPPED | AI_ALL, - @opts ); + my %hints = ( + flags => AI_V4MAPPED | AI_ALL, + @opts, + ); my ($err, @res) = Socket::getaddrinfo($hostname, '0', \%hints); die "failed to get address info for: $hostname: $err\n" if $err; return @res; @@ -1408,27 +1536,39 @@ sub parse_host_and_port { sub setresuid($$$) { my ($ruid, $euid, $suid) = @_; - return 0 == syscall(PVE::Syscall::setresuid, $ruid, $euid, $suid); + return 0 == syscall(PVE::Syscall::setresuid, int($ruid), int($euid), int($suid)); } sub unshare($) { my ($flags) = @_; - return 0 == syscall(PVE::Syscall::unshare, $flags); + return 0 == syscall(PVE::Syscall::unshare, int($flags)); } sub setns($$) { my ($fileno, $nstype) = @_; - return 0 == syscall(PVE::Syscall::setns, $fileno, $nstype); + return 0 == syscall(PVE::Syscall::setns, int($fileno), int($nstype)); } sub syncfs($) { my ($fileno) = @_; - return 0 == syscall(PVE::Syscall::syncfs, $fileno); + return 0 == syscall(PVE::Syscall::syncfs, int($fileno)); } sub fsync($) { my ($fileno) = @_; - return 0 == syscall(PVE::Syscall::fsync, $fileno); + return 0 == syscall(PVE::Syscall::fsync, int($fileno)); +} + +sub renameat2($$$$$) { + my ($olddirfd, $oldpath, $newdirfd, $newpath, $flags) = @_; + return 0 == syscall( + PVE::Syscall::renameat2, + int($olddirfd), + $oldpath, + int($newdirfd), + $newpath, + int($flags), + ); } sub sync_mountpoint { @@ -1442,93 +1582,105 @@ sub sync_mountpoint { die "syncfs '$path' failed - $syncfs_err\n" if defined $syncfs_err; } +my sub check_mail_addr { + my ($addr) = @_; + die "'$addr' does not look like a valid email address or username\n" + if $addr !~ /^$EMAIL_RE$/ && $addr !~ /^$EMAIL_USER_RE$/; +} + # support sending multi-part mail messages with a text and or a HTML part # mailto may be a single email string or an array of receivers sub sendmail { my ($mailto, $subject, $text, $html, $mailfrom, $author) = @_; - my $mail_re = qr/[^-a-zA-Z0-9+._@]/; $mailto = [ $mailto ] if !ref($mailto); - foreach (@$mailto) { - die "illegal character in mailto address\n" - if ($_ =~ $mail_re); - } - - my $rcvrtxt = join (', ', @$mailto); + check_mail_addr($_) for $mailto->@*; + my $to_quoted = [ map { shellquote($_) } $mailto->@* ]; $mailfrom = $mailfrom || "root"; - die "illegal character in mailfrom address\n" - if $mailfrom =~ $mail_re; + check_mail_addr($mailfrom); + my $from_quoted = shellquote($mailfrom); $author = $author // 'Proxmox VE'; - open (MAIL, "|-", "sendmail", "-B", "8BITMIME", "-f", $mailfrom, "--", @$mailto) || - die "unable to open 'sendmail' - $!"; - - my $date = time2str('%a, %d %b %Y %H:%M:%S %z', time()); + open (my $mail, "|-", "sendmail", "-B", "8BITMIME", "-f", $from_quoted, "--", $to_quoted->@*) + or die "unable to open 'sendmail' - $!"; my $is_multipart = $text && $html; + my $boundary = "----_=_NextPart_001_" . int(time()) . $$; # multipart spec, see rfc 1521 - # multipart spec see https://www.ietf.org/rfc/rfc1521.txt - my $boundary = "----_=_NextPart_001_".int(time).$$; + $subject = Encode::encode('MIME-Header', $subject) if $subject =~ /[^[:ascii:]]/; - if ($subject =~ /[^[:ascii:]]/) { - $subject = Encode::encode('MIME-Header', $subject); - } + print $mail "MIME-Version: 1.0\n" if $subject =~ /[^[:ascii:]]/ || $is_multipart; - if ($subject =~ /[^[:ascii:]]/ || $is_multipart) { - print MAIL "MIME-Version: 1.0\n"; - } - print MAIL "From: $author <$mailfrom>\n"; - print MAIL "To: $rcvrtxt\n"; - print MAIL "Date: $date\n"; - print MAIL "Subject: $subject\n"; + print $mail "From: $author <$mailfrom>\n"; + print $mail "To: " . join(', ', @$mailto) ."\n"; + print $mail "Date: " . time2str('%a, %d %b %Y %H:%M:%S %z', time()) . "\n"; + print $mail "Subject: $subject\n"; if ($is_multipart) { - print MAIL "Content-Type: multipart/alternative;\n"; - print MAIL "\tboundary=\"$boundary\"\n"; - print MAIL "\n"; - print MAIL "This is a multi-part message in MIME format.\n\n"; - print MAIL "--$boundary\n"; + print $mail "Content-Type: multipart/alternative;\n"; + print $mail "\tboundary=\"$boundary\"\n"; + print $mail "\n"; + print $mail "This is a multi-part message in MIME format.\n\n"; + print $mail "--$boundary\n"; } if (defined($text)) { - print MAIL "Content-Type: text/plain;\n"; - print MAIL "\tcharset=\"UTF-8\"\n"; - print MAIL "Content-Transfer-Encoding: 8bit\n"; - print MAIL "\n"; + print $mail "Content-Type: text/plain;\n"; + print $mail "Auto-Submitted: auto-generated;\n"; + print $mail "\tcharset=\"UTF-8\"\n"; + print $mail "Content-Transfer-Encoding: 8bit\n"; + print $mail "\n"; # avoid 'remove extra line breaks' issue (MS Outlook) my $fill = ' '; $text =~ s/^/$fill/gm; - print MAIL $text; + print $mail $text; - print MAIL "\n--$boundary\n" if $is_multipart; + print $mail "\n--$boundary\n" if $is_multipart; } if (defined($html)) { - print MAIL "Content-Type: text/html;\n"; - print MAIL "\tcharset=\"UTF-8\"\n"; - print MAIL "Content-Transfer-Encoding: 8bit\n"; - print MAIL "\n"; + print $mail "Content-Type: text/html;\n"; + print $mail "Auto-Submitted: auto-generated;\n"; + print $mail "\tcharset=\"UTF-8\"\n"; + print $mail "Content-Transfer-Encoding: 8bit\n"; + print $mail "\n"; - print MAIL $html; + print $mail $html; - print MAIL "\n--$boundary--\n" if $is_multipart; + print $mail "\n--$boundary--\n" if $is_multipart; } - close(MAIL); + close($mail); } +# creates a temporary file that does not shows up on the file system hierarchy. +# +# Uses O_TMPFILE if available, which makes it just an anon inode that never shows up in the FS. +# If O_TMPFILE is not available, which unlikely nowadays (added in 3.11 kernel and all FS relevant +# for us support it) back to open-create + immediate unlink while still holding the file handle. +# +# TODO: to avoid FS dependent features we could (transparently) switch to memfd_create as backend sub tempfile { my ($perm, %opts) = @_; # default permissions are stricter than with file_set_contents $perm = 0600 if !defined($perm); - my $dir = $opts{dir} // '/run'; + my $dir = $opts{dir}; + if (!$dir) { + if (-d "/run/user/$<") { + $dir = "/run/user/$<"; + } elsif ($< == 0) { + $dir = "/run"; + } else { + $dir = "/tmp"; + } + } my $mode = $opts{mode} // O_RDWR; $mode |= O_EXCL if !$opts{allow_links}; @@ -1543,6 +1695,7 @@ sub tempfile { return $fh; } +# create an (ideally) anon file with the $data as content and return its FD-path and FH sub tempfile_contents { my ($data, $perm, %opts) = @_; @@ -1576,7 +1729,11 @@ sub validate_ssh_public_keys { sub openat($$$;$) { my ($dirfd, $pathname, $flags, $mode) = @_; - my $fd = syscall(PVE::Syscall::openat, $dirfd, $pathname, $flags, $mode//0); + $dirfd = int($dirfd); + $flags = int($flags); + $mode = int($mode // 0); + + my $fd = syscall(PVE::Syscall::openat, $dirfd, $pathname, $flags, $mode); return undef if $fd < 0; # sysopen() doesn't deal with numeric file descriptors apparently # so we need to convert to a mode string for IO::Handle->new_from_fd @@ -1591,12 +1748,24 @@ sub openat($$$;$) { sub mkdirat($$$) { my ($dirfd, $name, $mode) = @_; - return syscall(PVE::Syscall::mkdirat, $dirfd, $name, $mode) == 0; + return syscall(PVE::Syscall::mkdirat, int($dirfd), $name, int($mode)) == 0; +} + +sub mknod($$$) { + my ($filename, $mode, $dev) = @_; + return syscall(PVE::Syscall::SYS_mknod, $filename, int($mode), int($dev)) == 0; } sub fchownat($$$$$) { my ($dirfd, $pathname, $owner, $group, $flags) = @_; - return syscall(PVE::Syscall::fchownat, $dirfd, $pathname, $owner, $group, $flags) == 0; + return syscall( + PVE::Syscall::fchownat, + int($dirfd), + $pathname, + int($owner), + int($group), + int($flags), + ) == 0; } my $salt_starter = time(); @@ -1726,9 +1895,9 @@ sub open_tree($$$) { my ($dfd, $pathname, $flags) = @_; return PVE::Syscall::file_handle_result(syscall( &PVE::Syscall::open_tree, - $dfd, + int($dfd), $pathname, - $flags, + int($flags), )); } @@ -1736,26 +1905,26 @@ sub move_mount($$$$$) { my ($from_dirfd, $from_pathname, $to_dirfd, $to_pathname, $flags) = @_; return 0 == syscall( &PVE::Syscall::move_mount, - $from_dirfd, + int($from_dirfd), $from_pathname, - $to_dirfd, + int($to_dirfd), $to_pathname, - $flags, + int($flags), ); } sub fsopen($$) { my ($fsname, $flags) = @_; - return PVE::Syscall::file_handle_result(syscall(&PVE::Syscall::fsopen, $fsname, $flags)); + return PVE::Syscall::file_handle_result(syscall(&PVE::Syscall::fsopen, $fsname, int($flags))); } sub fsmount($$$) { my ($fd, $flags, $mount_attrs) = @_; return PVE::Syscall::file_handle_result(syscall( &PVE::Syscall::fsmount, - $fd, - $flags, - $mount_attrs, + int($fd), + int($flags), + int($mount_attrs), )); } @@ -1763,15 +1932,22 @@ sub fspick($$$) { my ($dirfd, $pathname, $flags) = @_; return PVE::Syscall::file_handle_result(syscall( &PVE::Syscall::fspick, - $dirfd, + int($dirfd), $pathname, - $flags, + int($flags), )); } sub fsconfig($$$$$) { my ($fd, $command, $key, $value, $aux) = @_; - return 0 == syscall(&PVE::Syscall::fsconfig, $fd, $command, $key, $value, $aux); + return 0 == syscall( + &PVE::Syscall::fsconfig, + int($fd), + int($command), + $key, + $value, + int($aux), + ); } # "raw" mount, old api, not for generic use (as it does not invoke any helpers). @@ -1783,11 +1959,57 @@ sub mount($$$$$) { $source, $target, $filesystemtype, - $mountflags, + int($mountflags), $data, ); } +# size is optional and defaults to 256, note that xattr limits are FS specific and that xattrs can +# get arbitrary long. pass `0` for $size in array context to get the actual size of a value +sub getxattr($$;$) { + my ($path_or_handle, $name, $size) = @_; + $size //= 256; + my $buf = pack("x${size}"); + + my $xattr_size = -1; # the actual size of the xattr, can be zero + if (defined(my $fd = fileno($path_or_handle))) { + $xattr_size = syscall(&PVE::Syscall::fgetxattr, $fd, $name, $buf, int($size)); + } else { + $xattr_size = syscall(&PVE::Syscall::getxattr, $path_or_handle, $name, $buf, int($size)); + } + if ($xattr_size < 0) { + return undef; + } + $buf = substr($buf, 0, $xattr_size); + return wantarray ? ($buf, $xattr_size) : $buf; +} + +# NOTE: can take either a path or an open file handle, i.e., its multiplexing setxattr and fsetxattr +sub setxattr($$$;$) { + my ($path_or_handle, $name, $value, $flags) = @_; + my $size = length($value); # NOTE: seems to get correct length also for wide-characters in text.. + + if (defined(my $fd = fileno($path_or_handle))) { + return 0 == syscall( + &PVE::Syscall::fsetxattr, + $fd, + $name, + $value, + int($size), + int($flags // 0), + ); + } else { + return 0 == syscall( + &PVE::Syscall::setxattr, + $path_or_handle, + $name, + $value, + int($size), + int($flags // 0), + ); + } +} + sub safe_compare { my ($left, $right, $cmp) = @_; @@ -1797,4 +2019,166 @@ sub safe_compare { return $cmp->($left, $right); } + +# opts is a hash ref with the following known properties +# allow_overwrite - if 1, overwriting existing files is allowed, use with care. Default to false +# hash_required - if 1, at least one checksum has to be specified otherwise an error will be thrown +# http_proxy +# https_proxy +# verify_certificates - if 0 (false) we tell wget to ignore untrusted TLS certs. Default to true +# md5sum|sha(1|224|256|384|512)sum - the respective expected checksum string +sub download_file_from_url { + my ($dest, $url, $opts) = @_; + + my ($checksum_algorithm, $checksum_expected); + for ('sha512', 'sha384', 'sha256', 'sha224', 'sha1', 'md5') { + if (defined($opts->{"${_}sum"})) { + $checksum_algorithm = $_; + $checksum_expected = $opts->{"${_}sum"}; + last; + } + } + die "checksum required but not specified\n" if ($opts->{hash_required} && !$checksum_algorithm); + + print "downloading $url to $dest\n"; + + if (-f $dest) { + if ($checksum_algorithm) { + print "calculating checksum of existing file..."; + my $checksum_got = get_file_hash($checksum_algorithm, $dest); + + if (lc($checksum_got) eq lc($checksum_expected)) { + print "OK, got correct file already, no need to download\n"; + return; + } elsif ($opts->{allow_overwrite}) { + print "checksum mismatch: got '$checksum_got' != expect '$checksum_expected', re-download\n"; + } else { + print "\n"; # the front end expects the error to reside at the last line without any noise + die "checksum mismatch: got '$checksum_got' != expect '$checksum_expected', aborting\n"; + } + } elsif (!$opts->{allow_overwrite}) { + die "refusing to override existing file '$dest'\n"; + } + } + + my $tmp_download = "$dest.tmp_dwnl.$$"; + my $tmp_decomp = "$dest.tmp_dcom.$$"; + eval { + local $SIG{INT} = sub { + unlink $tmp_download or warn "could not cleanup temporary file: $!" + if -e $tmp_download; + unlink $tmp_decomp or warn "could not cleanup temporary file: $!" + if $opts->{decompression_command} && -e $tmp_decomp; + die "got interrupted by signal\n"; + }; + + { # limit the scope of the ENV change + local %ENV; + if ($opts->{http_proxy}) { + $ENV{http_proxy} = $opts->{http_proxy}; + } + if ($opts->{https_proxy}) { + $ENV{https_proxy} = $opts->{https_proxy}; + } + + my $cmd = ['wget', '--progress=dot:giga', '-O', $tmp_download, $url]; + + if (!($opts->{verify_certificates} // 1)) { # default to true + push @$cmd, '--no-check-certificate'; + } + + run_command($cmd, errmsg => "download failed"); + } + + if ($checksum_algorithm) { + print "calculating checksum..."; + + my $checksum_got = get_file_hash($checksum_algorithm, $tmp_download); + + if (lc($checksum_got) eq lc($checksum_expected)) { + print "OK, checksum verified\n"; + } else { + print "\n"; # the front end expects the error to reside at the last line without any noise + die "checksum mismatch: got '$checksum_got' != expect '$checksum_expected'\n"; + } + } + + if (my $cmd = $opts->{decompression_command}) { + push @$cmd, $tmp_download; + my $fh; + if (!open($fh, ">", "$tmp_decomp")) { + die "cant open temporary file $tmp_decomp for decompresson: $!\n"; + } + print "decompressing $tmp_download to $tmp_decomp\n"; + run_command($cmd, output => '>&'.fileno($fh)); + unlink $tmp_download; + rename($tmp_decomp, $dest) or die "unable to rename temporary file: $!\n"; + } else { + rename($tmp_download, $dest) or die "unable to rename temporary file: $!\n"; + } + }; + if (my $err = $@) { + unlink $tmp_download or warn "could not cleanup temporary file: $!" + if -e $tmp_download; + unlink $tmp_decomp or warn "could not cleanup temporary file: $!" + if $opts->{decompression_command} && -e $tmp_decomp; + die $err; + } + + print "download of '$url' to '$dest' finished\n"; +} + +sub get_file_hash { + my ($algorithm, $filename) = @_; + + my $algorithm_map = { + 'md5' => sub { Digest::MD5->new }, + 'sha1' => sub { Digest::SHA->new(1) }, + 'sha224' => sub { Digest::SHA->new(224) }, + 'sha256' => sub { Digest::SHA->new(256) }, + 'sha384' => sub { Digest::SHA->new(384) }, + 'sha512' => sub { Digest::SHA->new(512) }, + }; + + my $digester = $algorithm_map->{$algorithm}->() or die "unknown algorithm '$algorithm'\n"; + + open(my $fh, '<', $filename) or die "unable to open '$filename': $!\n"; + binmode($fh); + + my $digest = $digester->addfile($fh)->hexdigest; + + return lc($digest); +} + +# compare two perl variables recursively, so this works for scalars, nested +# hashes and nested arrays +sub is_deeply { + my ($a, $b) = @_; + + return 0 if defined($a) != defined($b); + return 1 if !defined($a); # both are undef + + my ($ref_a, $ref_b) = (ref($a), ref($b)); + + # scalar case + return 0 if !$ref_a && !$ref_b && "$a" ne "$b"; + + # different types, ok because ref never returns undef, only empty string + return 0 if $ref_a ne $ref_b; + + if ($ref_a eq 'HASH') { + return 0 if scalar(keys $a->%*) != scalar(keys $b->%*); + for my $opt (keys $a->%*) { + return 0 if !is_deeply($a->{$opt}, $b->{$opt}); + } + } elsif ($ref_a eq 'ARRAY') { + return 0 if scalar($a->@*) != scalar($b->@*); + for (my $i = 0; $i < $a->@*; $i++) { + return 0 if !is_deeply($a->[$i], $b->[$i]); + } + } + + return 1; +} + 1; diff --git a/test/Makefile b/test/Makefile index b8118c7..4e25a46 100644 --- a/test/Makefile +++ b/test/Makefile @@ -1,4 +1,13 @@ SUBDIRS = etc_network_interfaces +TESTS = lock_file.test \ + calendar_event_test.test \ + convert_size_test.test \ + procfs_tests.test \ + format_test.test \ + section_config_test.test \ + api_parameter_test.test \ + is_deeply_test.test \ + section_config_property_isolation_test.pl \ all: @@ -6,11 +15,11 @@ all: export PERLLIB=../src -check: lock_file.test calendar_event_test.test convert_size_test.test procfs_tests.test +check: $(TESTS) for d in $(SUBDIRS); do $(MAKE) -C $$d check; done %.test: %.pl - ./$< + TZ=UTC-1 ./$< distclean: clean clean: diff --git a/test/api_parameter_test.pl b/test/api_parameter_test.pl new file mode 100755 index 0000000..7ade386 --- /dev/null +++ b/test/api_parameter_test.pl @@ -0,0 +1,100 @@ +#!/usr/bin/perl +package PVE::TestAPIParameters; + +# Tests the automatic conversion of -list and array parameter types + +use strict; +use warnings; + +use lib '../src'; + +use PVE::RESTHandler; +use PVE::JSONSchema; + +use Test::More; + +use base qw(PVE::RESTHandler); + +my $setup = [ + { + name => 'list-format-with-list', + parameter => { + type => 'string', + format => 'pve-configid-list', + }, + value => "foo,bar", + 'value-expected' => "foo,bar", + }, + { + name => 'array-format-with-array', + parameter => { + type => 'array', + items => { + type => 'string', + format => 'pve-configid', + }, + }, + value => ['foo', 'bar'], + 'value-expected' => ['foo', 'bar'], + }, + # TODO: below behaviour should be deprecated with 9.x and fail with 10.x + { + name => 'list-format-with-alist', + parameter => { + type => 'string', + format => 'pve-configid-list', + }, + value => "foo\0bar", + 'value-expected' => "foo\0bar", + }, + { + name => 'array-format-with-non-array', + parameter => { + type => 'array', + items => { + type => 'string', + format => 'pve-configid', + }, + }, + value => "foo", + 'value-expected' => ['foo'], + }, + { + name => 'list-format-with-array', + parameter => { + type => 'string', + format => 'pve-configid-list', + }, + value => ['foo', 'bar'], + 'value-expected' => "foo,bar", + }, +]; + +for my $data ($setup->@*) { + __PACKAGE__->register_method({ + name => $data->{name}, + path => $data->{name}, + method => 'POST', + parameters => { + additionalProperties => 0, + properties => { + param => $data->{parameter}, + }, + }, + returns => { type => 'null' }, + code => sub { + my ($param) = @_; + return $param->{param}; + } + }); + + my ($handler, $info) = __PACKAGE__->find_handler('POST', $data->{name}); + my $param = { + param => $data->{value}, + }; + + my $res = $handler->handle($info, $param); + is_deeply($res, $data->{'value-expected'}, $data->{name}); +} + +done_testing(); diff --git a/test/calendar_event_test.pl b/test/calendar_event_test.pl index abbd74c..4572965 100755 --- a/test/calendar_event_test.pl +++ b/test/calendar_event_test.pl @@ -18,7 +18,7 @@ my $alldays = [0,1,2,3,4,5,6]; my $tests = [ [ '*', - { h => '*', m => '*', dow => $alldays }, + undef, [ [0, 60], [30, 60], @@ -28,7 +28,7 @@ my $tests = [ ], [ '*/10', - { h => '*', m => [0, 10, 20, 30, 40, 50], dow => $alldays }, + undef, [ [0, 600], [599, 600], @@ -38,7 +38,7 @@ my $tests = [ ], [ '*/12:0' , - { h => [0, 12], m => [0], dow => $alldays }, + undef, [ [ 10, 43200], [ 13*3600, 24*3600], @@ -46,7 +46,7 @@ my $tests = [ ], [ '1/12:0/15' , - { h => [1, 13], m => [0, 15, 30, 45], dow => $alldays }, + undef, [ [0, 3600], [3600, 3600+15*60], @@ -61,7 +61,7 @@ my $tests = [ ], [ '1,4,6', - { h => '*', m => [1, 4, 6], dow => $alldays}, + undef, [ [0, 60], [60, 4*60], @@ -71,15 +71,15 @@ my $tests = [ ], [ '0..3', - { h => '*', m => [ 0, 1, 2, 3 ], dow => $alldays }, + undef, ], [ '23..23:0..3', - { h => [ 23 ], m => [ 0, 1, 2, 3 ], dow => $alldays }, + undef, ], [ 'Mon', - { h => [0], m => [0], dow => [1] }, + undef, [ [0, 4*86400], # Note: Epoch 0 is Thursday, 1. January 1970 [4*86400, 11*86400], @@ -88,7 +88,7 @@ my $tests = [ ], [ 'sat..sun', - { h => [0], m => [0], dow => [0, 6] }, + undef, [ [0, 2*86400], [2*86400, 3*86400], @@ -97,7 +97,7 @@ my $tests = [ ], [ 'sun..sat', - { h => [0], m => [0], dow => $alldays }, + undef, ], [ 'Fri..Mon', @@ -105,15 +105,15 @@ my $tests = [ ], [ 'wed,mon..tue,fri', - { h => [0], m => [0], dow => [ 1, 2, 3, 5] }, + undef, ], [ 'mon */15', - { h => '*', m => [0, 15, 30, 45], dow => [1]}, + undef, ], [ '22/1:0', - { h => [22, 23], m => [0], dow => $alldays }, + undef, [ [0, 22*60*60], [22*60*60, 23*60*60], @@ -122,7 +122,7 @@ my $tests = [ ], [ '*/2:*', - { h => [0,2,4,6,8,10,12,14,16,18,20,22], m => '*', dow => $alldays }, + undef, [ [0, 60], [60*60, 2*60*60], @@ -131,7 +131,7 @@ my $tests = [ ], [ '20..22:*/30', - { h => [20,21,22], m => [0,30], dow => $alldays }, + undef, [ [0, 20*60*60], [20*60*60, 20*60*60 + 30*60], @@ -164,7 +164,7 @@ my $tests = [ ], [ '0,1,3..5', - { h => '*', m => [0,1,3,4,5], dow => $alldays }, + undef, [ [0, 60], [60, 3*60], @@ -173,7 +173,7 @@ my $tests = [ ], [ '2,4:0,1,3..5', - { h => [2,4], m => [0,1,3,4,5], dow => $alldays }, + undef, [ [0, 2*60*60], [2*60*60 + 60, 2*60*60 + 3*60], @@ -185,18 +185,16 @@ my $tests = [ foreach my $test (@$tests) { my ($t, $expect, $nextsync) = @$test; + $expect //= {}; + my $timespec; eval { $timespec = PVE::CalendarEvent::parse_calendar_event($t); }; my $err = $@; - delete $timespec->{utc}; if ($expect->{error}) { chomp $err if $err; - $timespec = { error => $err } if $err; - is_deeply($timespec, $expect, "expect parse error on '$t' - $expect->{error}"); + ok(defined($err) == defined($expect->{error}), "parsing '$t' failed expectedly"); die "unable to execute nextsync tests" if $nextsync; - } else { - is_deeply($timespec, $expect, "parse '$t'"); } next if !$nextsync; diff --git a/test/etc_network_interfaces/base-allow-hotplug b/test/etc_network_interfaces/base-allow-hotplug new file mode 100644 index 0000000..967aeab --- /dev/null +++ b/test/etc_network_interfaces/base-allow-hotplug @@ -0,0 +1,17 @@ +# network interface settings; autogenerated +# Please do NOT modify this file directly, unless you know what +# you're doing. +# +# If you want to manage parts of the network configuration manually, +# please utilize the 'source' or 'source-directory' directives to do +# so. +# PVE will preserve these directives, but will NOT read its network +# configuration from sourced files, so do not attempt to move any of +# the PVE managed interfaces into external files! + +auto lo +iface lo inet loopback + +allow-hotplug ens18 +iface ens18 inet dhcp + diff --git a/test/etc_network_interfaces/base-auto-allow-hotplug b/test/etc_network_interfaces/base-auto-allow-hotplug new file mode 100644 index 0000000..b3aae7f --- /dev/null +++ b/test/etc_network_interfaces/base-auto-allow-hotplug @@ -0,0 +1,18 @@ +# network interface settings; autogenerated +# Please do NOT modify this file directly, unless you know what +# you're doing. +# +# If you want to manage parts of the network configuration manually, +# please utilize the 'source' or 'source-directory' directives to do +# so. +# PVE will preserve these directives, but will NOT read its network +# configuration from sourced files, so do not attempt to move any of +# the PVE managed interfaces into external files! + +auto lo +iface lo inet loopback + +auto ens18 +allow-hotplug ens18 +iface ens18 inet dhcp + diff --git a/test/etc_network_interfaces/runtest.pl b/test/etc_network_interfaces/runtest.pl index b5277c3..10fafae 100755 --- a/test/etc_network_interfaces/runtest.pl +++ b/test/etc_network_interfaces/runtest.pl @@ -9,6 +9,7 @@ use Carp; use POSIX; use IO::Handle; use Storable qw(dclone); +use JSON; # allows simple debug-dumping of variables `print to_json($foo, {pretty => 1}) ."\n"` use PVE::INotify; @@ -77,7 +78,7 @@ sub r($;$$) { sub w() { # write shouldn't be able to change a previously parsed config my $config_clone = dclone($config); - return PVE::INotify::__write_etc_network_interfaces($config_clone); + return PVE::INotify::__write_etc_network_interfaces($config_clone, 1); } ## diff --git a/test/etc_network_interfaces/t.base-auto-allow-hotplug.pl b/test/etc_network_interfaces/t.base-auto-allow-hotplug.pl new file mode 100644 index 0000000..772da83 --- /dev/null +++ b/test/etc_network_interfaces/t.base-auto-allow-hotplug.pl @@ -0,0 +1,25 @@ +my $active_ifaces = ['lo', 'ens18', 'ens']; +my $proc_net = load('proc_net_dev'); +$proc_net =~ s/eth0/ens18/; + +my $wanted = load('base-allow-hotplug'); + +# parse the config +r($wanted, $proc_net, $active_ifaces); + +$wanted =~ s/allow-hotplug ens18/auto ens18/; # FIXME: hack! rather we need to keep allow-hotplug! + +expect $wanted; + +# idempotency (save, re-parse, and re-check) +r(w(), $proc_net, $active_ifaces); +expect $wanted; + +# parse one with both, "auto" and "allow-hotplug" +my $bad = load('base-auto-allow-hotplug'); +r($bad, $proc_net, $active_ifaces); + +# should drop the first occuring one of the conflicting options ("auto" currently) +expect $wanted; + +1; diff --git a/test/etc_network_interfaces/t.bridge_eth_remove_auto.pl b/test/etc_network_interfaces/t.bridge_eth_remove_auto.pl deleted file mode 100644 index 98f5df8..0000000 --- a/test/etc_network_interfaces/t.bridge_eth_remove_auto.pl +++ /dev/null @@ -1,24 +0,0 @@ -use strict; - -# access to the current config -our $config; - -# replace proc_net_dev with one with a bunch of interfaces -save('proc_net_dev', <<'/proc/net/dev'); -eth0: -eth1: -/proc/net/dev - -r(''); -update_iface('eth0', [], autostart => 1); -update_iface('eth1', [], autostart => 1); -r(w()); -die "autostart lost" if !$config->{ifaces}->{eth0}->{autostart}; -die "autostart lost" if !$config->{ifaces}->{eth1}->{autostart}; -new_iface("vmbr0", 'bridge', [{ family => 'inet' }], bridge_ports => 'eth0'); -new_iface("vmbr1", 'OVSBridge', [{ family => 'inet' }], ovs_ports => 'eth1'); -r(w()); -die "autostart wrongly removed for linux bridge port" if !$config->{ifaces}->{eth0}->{autostart}; -die "autostart not removed for ovs bridge port" if $config->{ifaces}->{eth1}->{autostart}; - -1; diff --git a/test/etc_network_interfaces/t.create_network.pl b/test/etc_network_interfaces/t.create_network.pl index b8da513..6aad74c 100644 --- a/test/etc_network_interfaces/t.create_network.pl +++ b/test/etc_network_interfaces/t.create_network.pl @@ -420,7 +420,7 @@ auto eth1.100 iface eth1.100 inet manual mtu 1400 -allow-vmbr6 ovsintvlan +auto ovsintvlan iface ovsintvlan inet manual ovs_type OVSIntPort ovs_bridge vmbr6 @@ -429,7 +429,7 @@ iface ovsintvlan inet manual $bond0_part -allow-vmbr6 bond1 +auto bond1 iface bond1 inet manual ovs_bonds eth4 eth5 ovs_type OVSBond @@ -464,7 +464,7 @@ iface vmbr5 inet manual bridge-fd 0 mtu 1100 -allow-ovs vmbr6 +auto vmbr6 iface vmbr6 inet manual ovs_type OVSBridge ovs_ports bond1 ovsintvlan diff --git a/test/etc_network_interfaces/t.ifupdown2-typeless.pl b/test/etc_network_interfaces/t.ifupdown2-typeless.pl new file mode 100644 index 0000000..d0ec5e6 --- /dev/null +++ b/test/etc_network_interfaces/t.ifupdown2-typeless.pl @@ -0,0 +1,47 @@ +my $ip = '10.0.0.2/24'; +my $gw = '10.0.0.1'; +my $ip6 = 'fc05::1:2/112'; +my $gw6 = 'fc05::1:1'; + +r(load('base') . <<"EOF"); +auto vmbr1 +iface vmbr1 + address 1.2.3.4/24 + address fccc::a:1/64 + gateway 1.2.3.1 + gateway fccc::1 + bridge-ports eth0 + bridge-stp off + bridge-fd 0 +# Comment + +EOF + +my $run = 'first'; +my $ifaces = $config->{ifaces}; + +my $ck = sub { + my ($i, $v, $e) = @_; + $ifaces->{$i}->{$v} eq $e + or die "$run run: $i variable $v: got \"$ifaces->{$i}->{$v}\", expected: $e\n"; +}; + +my $check_config = sub { + $ck->('vmbr1', type => 'bridge'); + $ck->('vmbr1', cidr => '1.2.3.4/24'); + $ck->('vmbr1', gateway => '1.2.3.1'); + $ck->('vmbr1', cidr6 => 'fccc::a:1/64'); + $ck->('vmbr1', gateway6 => 'fccc::1'); +}; + +$check_config->(); + +# idempotency +save('idem', w()); +r(load('idem')); +expect load('idem'); + +$run = 'second'; +$check_config->(); + +1; diff --git a/test/etc_network_interfaces/t.ovs_bridge_allow.pl b/test/etc_network_interfaces/t.ovs_bridge_allow.pl index 9479ff5..742c9ef 100644 --- a/test/etc_network_interfaces/t.ovs_bridge_allow.pl +++ b/test/etc_network_interfaces/t.ovs_bridge_allow.pl @@ -37,7 +37,7 @@ iface eth2 inet manual iface eth3 inet manual -allow-ovs vmbr0 +auto vmbr0 iface vmbr0 inet static address $ip gateway $gw @@ -52,19 +52,19 @@ expect load('loopback') . <<"/etc/network/interfaces"; auto eth0 iface eth0 inet manual -allow-vmbr0 eth1 +auto eth1 iface eth1 inet manual ovs_type OVSPort ovs_bridge vmbr0 -allow-vmbr0 eth2 +auto eth2 iface eth2 inet manual ovs_type OVSPort ovs_bridge vmbr0 iface eth3 inet manual -allow-ovs vmbr0 +auto vmbr0 iface vmbr0 inet static address $ip gateway $gw @@ -89,7 +89,7 @@ expect load('loopback') . <<"/etc/network/interfaces"; auto eth0 iface eth0 inet manual -allow-vmbr0 eth1 +auto eth1 iface eth1 inet manual ovs_type OVSPort ovs_bridge vmbr0 @@ -98,7 +98,7 @@ iface eth3 inet manual iface eth2 inet manual -allow-ovs vmbr0 +auto vmbr0 iface vmbr0 inet static address $ip gateway $gw diff --git a/test/etc_network_interfaces/t.vlan-parsing.pl b/test/etc_network_interfaces/t.vlan-parsing.pl new file mode 100644 index 0000000..6646683 --- /dev/null +++ b/test/etc_network_interfaces/t.vlan-parsing.pl @@ -0,0 +1,54 @@ +save('proc_net_dev', <<'/proc/net/dev'); +eth0: +eth1: +/proc/net/dev + +# Check for dropped or duplicated options + +my $ip = '192.168.0.2'; +my $nm = '255.255.255.0'; +my $gw = '192.168.0.1'; +my $ip6 = 'fc05::2'; +my $nm6 = '112'; +my $gw6 = 'fc05::1'; + +# Load +my $cfg = load('base') . <<"CHECK"; +iface eth1 inet manual + +auto vmbr0 +iface vmbr0 inet static + address 10.0.0.2/24 + gateway 10.0.0.1 + bridge-ports eth0 + bridge-stp off + bridge-fd 0 + bridge-vlan-aware yes + bridge-vids 2-4094 + +auto vmbr0.10 +iface vmbr0.10 inet static + +auto vmbr0.20 +iface vmbr0.20 inet static + +auto vmbr0.30 +iface vmbr0.30 inet static + +auto vmbr0.40 +iface vmbr0.40 inet static + +auto vmbr0.100 +iface vmbr0.100 inet static + +auto zmgmt +iface zmgmt inet static + vlan-id 1 + vlan-raw-device vmbr0 + +CHECK + +r $cfg; +expect $cfg; + +1; diff --git a/test/format_test.pl b/test/format_test.pl new file mode 100755 index 0000000..32c00f1 --- /dev/null +++ b/test/format_test.pl @@ -0,0 +1,56 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use lib '../src'; +use PVE::JSONSchema; +use PVE::CLIFormatter; + +use Test::More; +use Test::MockModule; + +my $valid_configids = [ + 'aa', 'a0', 'a_', 'a-', 'a-a', 'a'x100, 'Aa', 'AA', +]; +my $invalid_configids = [ + 'a', 'a+', '1a', '_a', '-a', '+a', 'A', +]; + +my $noerr = 1; # easier to test +foreach my $id (@$valid_configids) { + is(PVE::JSONSchema::pve_verify_configid($id, $noerr), $id, 'valid configid'); +} +foreach my $id (@$invalid_configids) { + is(PVE::JSONSchema::pve_verify_configid($id, $noerr), undef, 'invalid configid'); +} + +# test some string rendering +my $render_data = [ + ["timestamp", 0, undef, "1970-01-01 01:00:00"], + ["timestamp", 1612776831, undef, "2021-02-08 10:33:51"], + ["timestamp_gmt", 0, undef, "1970-01-01 00:00:00"], + ["timestamp_gmt", 1612776831, undef, "2021-02-08 09:33:51"], + ["duration", undef, undef, "0s"], + ["duration", 0.3, undef, "0s"], + ["duration", 0, undef, "0s"], + ["duration", 40, undef, "40s"], + ["duration", 59.64432, undef, "1m"], + ["duration", 110, undef, "1m 50s"], + ["duration", 7*24*3829*2, undef, "2w 21h 22m 24s"], + ["fraction_as_percentage", 0.412, undef, "41.20%"], + ["bytes", 0, undef, "0.00 B"], + ["bytes", 1023, 4, "1023.0000 B"], + ["bytes", 1024, undef, "1.00 KiB"], + ["bytes", 1024*1024*123 + 1024*300, 1, "123.3 MiB"], + ["bytes", 1024*1024*1024*1024*4 + 1024*1024*2048*8, undef, "4.02 TiB"], +]; + +foreach my $data (@$render_data) { + my ($renderer_name, $p1, $p2, $expected) = @$data; + my $renderer = PVE::JSONSchema::get_renderer($renderer_name); + my $actual = $renderer->($p1, $p2); + is($actual, $expected, "string format '$renderer_name'"); +} + +done_testing(); diff --git a/test/is_deeply_test.pl b/test/is_deeply_test.pl new file mode 100755 index 0000000..f546b36 --- /dev/null +++ b/test/is_deeply_test.pl @@ -0,0 +1,142 @@ +#!/usr/bin/perl + +use lib '../src'; + +use strict; +use warnings; + +use Test::More; +use PVE::Tools; + +my $tests = [ + { + name => 'both undef', + a => undef, + b => undef, + expected => 1, + }, + { + name => 'empty string', + a => '', + b => '', + expected => 1, + }, + { + name => 'empty string and undef', + a => '', + b => undef, + expected => 0, + }, + { + name => '0 and undef', + a => 0, + b => undef, + expected => 0, + }, + { + name => 'equal strings', + a => 'test', + b => 'test', + expected => 1, + }, + { + name => 'unequal strings', + a => 'test', + b => 'tost', + expected => 0, + }, + { + name => 'equal numerics', + a => 42, + b => 42, + expected => 1, + }, + { + name => 'unequal numerics', + a => 42, + b => 420, + expected => 0, + }, + { + name => 'equal arrays', + a => ['foo', 'bar'], + b => ['foo', 'bar'], + expected => 1, + }, + { + name => 'equal empty arrays', + a => [], + b => [], + expected => 1, + }, + { + name => 'unequal arrays', + a => ['foo', 'bar'], + b => ['bar', 'foo'], + expected => 0, + }, + { + name => 'equal empty hashes', + a => { }, + b => { }, + expected => 1, + }, + { + name => 'equal hashes', + a => { foo => 'bar' }, + b => { foo => 'bar' }, + expected => 1, + }, + { + name => 'unequal hashes', + a => { foo => 'bar' }, + b => { bar => 'foo' }, + expected => 0, + }, + { + name => 'equal nested hashes', + a => { + foo => 'bar', + bar => 1, + list => ['foo', 'bar'], + properties => { + baz => 'boo', + }, + }, + b => { + foo => 'bar', + bar => 1, + list => ['foo', 'bar'], + properties => { + baz => 'boo', + }, + }, + expected => 1, + }, + { + name => 'unequal nested hashes', + a => { + foo => 'bar', + bar => 1, + list => ['foo', 'bar'], + properties => { + baz => 'boo', + }, + }, + b => { + foo => 'bar', + bar => 1, + list => ['foo', 'bar'], + properties => { + baz => undef, + }, + }, + expected => 0, + }, +]; + +for my $test ($tests->@*) { + is (PVE::Tools::is_deeply($test->{a}, $test->{b}), $test->{expected}, $test->{name}); +} + +done_testing(); diff --git a/test/procfs_tests.pl b/test/procfs_tests.pl index de094ab..4cf4991 100755 --- a/test/procfs_tests.pl +++ b/test/procfs_tests.pl @@ -63,7 +63,7 @@ subtest 'test kernel_version parser' => sub { my $res = [ PVE::ProcFSTools::kernel_version() ]; - is_deeply($res, $test->{expect}, "got verison <". $res->[4] ."> same as expected"); + is_deeply($res, $test->{expect}, "got version <". $res->[4] ."> same as expected"); } }; diff --git a/test/section_config_property_isolation_test.pl b/test/section_config_property_isolation_test.pl new file mode 100755 index 0000000..4bade3b --- /dev/null +++ b/test/section_config_property_isolation_test.pl @@ -0,0 +1,489 @@ +#!/usr/bin/perl + +use lib '../src'; + +package Conf; +use strict; +use warnings; + +use Test::More; + +use base qw(PVE::SectionConfig); + +my $defaultData = { + propertyList => { + type => { description => "Section type." }, + id => { + description => "ID", + type => 'string', + format => 'pve-configid', + maxLength => 64, + }, + common => { + type => 'string', + description => 'common value', + maxLength => 512, + }, + }, +}; + +sub private { + return $defaultData; +} + +sub expect_success { + my ($class, $filename, $expected, $raw, $allow_unknown) = @_; + + my $res = $class->parse_config($filename, $raw, $allow_unknown); + delete $res->{digest}; + + is_deeply($res, $expected, $filename); + + my $written = $class->write_config($filename, $res, $allow_unknown); + my $res2 = $class->parse_config($filename, $written, $allow_unknown); + delete $res2->{digest}; + + is_deeply($res, $res2, "$filename - verify rewritten data"); +} + +sub expect_fail { + my ($class, $filename, $expected, $raw) = @_; + + eval { $class->parse_config($filename, $raw) }; + die "test '$filename' succeeded unexpectedly\n" if !$@; + ok(1, "$filename should fail to parse"); +} + +package Conf::One; +use strict; +use warnings; + +use base 'Conf'; + +sub type { + return 'one'; +} + +sub properties { + return { + field1 => { + description => 'Field One', + type => 'integer', + minimum => 3, + maximum => 9, + }, + field2 => { + description => 'Field Two', + type => 'integer', + minimum => 10, + maximum => 19, + }, + another => { + description => 'Another field', + type => 'string', + optional => 1, + }, + arrayfield => { + description => "Array Field with property string", + optional => 1, + type => 'array', + items => { + type => 'string', + description => 'a property string', + format => { + subfield1 => { + type => 'string', + description => 'first subfield' + }, + subfield2 => { + type => 'integer', + minimum => 0, + optional => 1, + }, + }, + }, + }, + }; +} + +sub options { + return { + common => { optional => 1 }, + }; +} + +package Conf::Two; +use strict; +use warnings; + +use base 'Conf'; + +sub type { + return 'two'; +} + +sub properties { + return { + field2 => { + description => 'Field Two but different', + type => 'integer', + minimum => 3, + maximum => 9, + }, + another => { + description => 'Another field', + type => 'string', + }, + arrayfield => { + optional => 1, + description => "Array Field with property string", + type => 'array', + items => { + type => 'string', + description => 'a property string', + format => { + subfield1 => { + type => 'string', + description => 'first subfield' + }, + subfield2 => { + type => 'integer', + minimum => 0, + optional => 1, + }, + }, + }, + }, + }; +} + +sub options { + return { + common => { optional => 1 }, + }; +} + +package main; + +use strict; +use warnings; + +use Test::More; + +Conf::One->register(); +Conf::Two->register(); +Conf->init(property_isolation => 1); + +# FIXME: allow development debug warnings?! +local $SIG{__WARN__} = sub { die @_; }; + +my sub enum { + my $n = 1; + return { map { $_ => $n++ } @_ }; +} + +Conf->expect_success( + 'property-isolation-test1', + { + ids => { + t1 => { + type => 'one', + common => 'foo', + field1 => 3, + field2 => 10, + arrayfield => [ 'subfield1=test' ], + }, + t2 => { + type => 'one', + common => 'foo2', + field1 => 4, + field2 => 15, + another => 'more-text', + }, + t3 => { + type => 'two', + field2 => 5, + another => 'even more text', + }, + }, + order => { t1 => 1, t2 => 2, t3 => 3 }, + }, + <<"EOF"); +one: t1 + common foo + field1 3 + field2 10 + arrayfield subfield1=test + +one: t2 + common foo2 + field1 4 + field2 15 + another more-text + +two: t3 + field2 5 + another even more text +EOF + +my $with_unknown_data = { + ids => { + t1 => { + type => 'one', + common => 'foo', + field1 => 3, + field2 => 10, + }, + t2 => { + type => 'one', + common => 'foo2', + field1 => 4, + field2 => 15, + another => 'more-text', + }, + t3 => { + type => 'two', + field2 => 5, + another => 'even more text', + arrayfield => [ + 'subfield1=test,subfield2=2', + 'subfield1=test2', + ], + }, + invalid => { + type => 'bad', + common => 'omg', + unknownfield => 'shouldnotbehere', + unknownarray => ['entry1', 'entry2'], + }, + }, + order => enum(qw(t1 t2 invalid t3)), +}; +my $with_unknown_text = <<"EOF"; +one: t1 + common foo + field1 3 + field2 10 + +one: t2 + common foo2 + field1 4 + field2 15 + another more-text + +bad: invalid + common omg + unknownfield shouldnotbehere + unknownarray entry1 + unknownarray entry2 + +two: t3 + field2 5 + another even more text + arrayfield subfield1=test,subfield2=2 + arrayfield subfield1=test2 +EOF + +my $wrong_field_schema_data = { + ids => { + t1 => { + type => 'one', + common => 'foo', + field1 => 3, + field2 => 5, # this should fail + }, + }, + order => enum(qw(t1)), +}; + +my $wrong_field_schema_text = <<"EOF"; +one: t1 + common foo + field1 3 + field2 5 +EOF + +Conf->expect_fail('property-isolation-wrong-field-schema', $wrong_field_schema_data, $wrong_field_schema_text); +Conf->expect_fail('property-isolation-unknown-forbidden', $with_unknown_data, $with_unknown_text); +Conf->expect_success('property-isolation-unknown-allowed', $with_unknown_data, $with_unknown_text, 1); + +# schema tests +my $create_schema = Conf->createSchema(); +my $expected_create_schema = { + additionalProperties => 0, + type => 'object', + properties => { + id => { + description => "ID", + type => 'string', + format => 'pve-configid', + maxLength => 64, + }, + type => { + description => 'Section type.', + enum => [ 'one', 'two' ], + type => 'string' + }, + common => { + maxLength => 512, + optional => 1, + type => 'string', + description => 'common value' + }, + field1 => { + type => 'integer', + 'type-property' => 'type', + 'instance-types' => [ 'one' ], + maximum => 9, + optional => 1, + minimum => 3, + description => 'Field One' + }, + field2 => { + oneOf => [ + { + description => 'Field Two', + optional => 1, + minimum => 10, + 'instance-types' => [ 'one' ], + type => 'integer', + maximum => 19 + }, + { + optional => 1, + minimum => 3, + description => 'Field Two but different', + type => 'integer', + 'instance-types' => [ 'two' ], + maximum => 9 + } + ], + 'type-property' => 'type' + }, + arrayfield => { + items => { + type => 'string', + format => { + subfield1 => { + description => 'first subfield', + type => 'string' + }, + subfield2 => { + minimum => 0, + type => 'integer', + optional => 1 + } + }, + description => 'a property string' + }, + description => 'Array Field with property string', + type => 'array', + optional => 1 + }, + another => { + optional => 1, + type => 'string', + description => 'Another field' + }, + }, +}; + +is_deeply($create_schema, $expected_create_schema, "property-isolation create schema test"); + +my $update_schema = Conf->updateSchema(); +my $expected_update_schema = { + additionalProperties => 0, + type => 'object', + properties => { + id => { + description => "ID", + type => 'string', + format => 'pve-configid', + maxLength => 64, + }, + type => { + type => 'string', + enum => [ 'one', 'two' ], + description => 'Section type.' + }, + digest => { + optional => 1, + type => 'string', + description => 'Prevent changes if current configuration file has a different digest. This can be used to prevent concurrent modifications.', + maxLength => 64 + }, + delete => { + description => 'A list of settings you want to delete.', + maxLength => 4096, + format => 'pve-configid-list', + optional => 1, + type => 'string' + }, + common => { + maxLength => 512, + description => 'common value', + type => 'string', + optional => 1 + }, + field1 => { + description => 'Field One', + maximum => 9, + 'instance-types' => [ 'one' ], + 'type-property' => 'type', + minimum => 3, + optional => 1, + type => 'integer' + }, + field2 => { + 'type-property' => 'type', + oneOf => [ + { + type => 'integer', + minimum => 10, + optional => 1, + maximum => 19, + 'instance-types' => [ 'one' ], + description => 'Field Two' + }, + { + description => 'Field Two but different', + maximum => 9, + 'instance-types' => [ 'two' ], + minimum => 3, + optional => 1, + type => 'integer' + } + ] + }, + arrayfield => { + type => 'array', + optional => 1, + items => { + description => 'a property string', + type => 'string', + format => { + subfield2 => { + type => 'integer', + minimum => 0, + optional => 1 + }, + subfield1 => { + description => 'first subfield', + type => 'string' + } + } + }, + description => 'Array Field with property string' + }, + another => { + description => 'Another field', + optional => 1, + type => 'string' + }, + } +}; +is_deeply($update_schema, $expected_update_schema, "property-isolation update schema test"); + +done_testing(); + +1; diff --git a/test/section_config_test.pl b/test/section_config_test.pl new file mode 100755 index 0000000..343e4c8 --- /dev/null +++ b/test/section_config_test.pl @@ -0,0 +1,389 @@ +#!/usr/bin/perl + +use lib '../src'; + +package Conf; +use strict; +use warnings; + +use Test::More; + +use base qw(PVE::SectionConfig); + +my $defaultData = { + propertyList => { + type => { description => "Section type." }, + id => { + description => "ID", + type => 'string', + format => 'pve-configid', + maxLength => 64, + }, + common => { + type => 'string', + description => 'common value', + maxLength => 512, + }, + }, +}; + +sub private { + return $defaultData; +} + +sub expect_success { + my ($class, $filename, $expected, $raw, $allow_unknown) = @_; + + my $res = $class->parse_config($filename, $raw, $allow_unknown); + delete $res->{digest}; + + is_deeply($res, $expected, $filename); + + my $written = $class->write_config($filename, $res, $allow_unknown); + my $res2 = $class->parse_config($filename, $written, $allow_unknown); + delete $res2->{digest}; + + is_deeply($res, $res2, "$filename - verify rewritten data"); +} + +sub expect_fail { + my ($class, $filename, $expected, $raw) = @_; + + eval { $class->parse_config($filename, $raw) }; + die "test '$filename' succeeded unexpectedly\n" if !$@; + ok(1, "$filename should fail to parse"); +} + +package Conf::One; +use strict; +use warnings; + +use base 'Conf'; + +sub type { + return 'one'; +} + +sub properties { + return { + field1 => { + description => 'Field One', + type => 'integer', + minimum => 3, + maximum => 9, + }, + another => { + description => 'Another field', + type => 'string', + }, + }; +} + +sub options { + return { + common => { optional => 1 }, + field1 => {}, + another => { optional => 1 }, + }; +} + +package Conf::Two; +use strict; +use warnings; + +use base 'Conf'; + +sub type { + return 'two'; +} + +sub properties { + return { + field2 => { + description => 'Field Two', + type => 'integer', + minimum => 3, + maximum => 9, + }, + arrayfield => { + description => "Array Field with property string", + type => 'array', + items => { + type => 'string', + description => 'a property string', + format => { + subfield1 => { + type => 'string', + description => 'first subfield' + }, + subfield2 => { + type => 'integer', + minimum => 0, + optional => 1, + }, + }, + }, + }, + }; +} + +sub options { + return { + common => { optional => 1 }, + field2 => {}, + another => {}, + arrayfield => { optional => 1 }, + }; +} + +package main; + +use strict; +use warnings; + +use Test::More; +use PVE::JSONSchema; + +Conf::One->register(); +Conf::Two->register(); +Conf->init(); + +# FIXME: allow development debug warnings?! +local $SIG{__WARN__} = sub { die @_; }; + +my sub enum { + my $n = 1; + return { map { $_ => $n++ } @_ }; +} + +Conf->expect_success( + 'test1', + { + ids => { + t1 => { + type => 'one', + common => 'foo', + field1 => 3, + }, + t2 => { + type => 'one', + common => 'foo2', + field1 => 4, + another => 'more-text', + }, + t3 => { + type => 'two', + field2 => 5, + another => 'even more text', + }, + }, + order => { t1 => 1, t2 => 2, t3 => 3 }, + }, + <<"EOF"); +one: t1 + common foo + field1 3 + +one: t2 + common foo2 + field1 4 + another more-text + +two: t3 + field2 5 + another even more text +EOF + +my $with_unknown_data = { + ids => { + t1 => { + type => 'one', + common => 'foo', + field1 => 3, + }, + t2 => { + type => 'one', + common => 'foo2', + field1 => 4, + another => 'more-text', + }, + t3 => { + type => 'two', + field2 => 5, + another => 'even more text', + arrayfield => [ + 'subfield1=test,subfield2=2', + 'subfield1=test2', + ], + }, + invalid => { + type => 'bad', + common => 'omg', + unknownfield => 'shouldnotbehere', + unknownarray => ['entry1', 'entry2'], + }, + }, + order => enum(qw(t1 t2 invalid t3)), +}; +my $with_unknown_text = <<"EOF"; +one: t1 + common foo + field1 3 + +one: t2 + common foo2 + field1 4 + another more-text + +bad: invalid + common omg + unknownfield shouldnotbehere + unknownarray entry1 + unknownarray entry2 + +two: t3 + field2 5 + another even more text + arrayfield subfield1=test,subfield2=2 + arrayfield subfield1=test2 +EOF + +Conf->expect_fail('unknown-forbidden', $with_unknown_data, $with_unknown_text); +Conf->expect_success('unknown-allowed', $with_unknown_data, $with_unknown_text, 1); + +# schema tests +my $create_schema = Conf->createSchema(); +my $expected_create_schema = { + additionalProperties => 0, + type => 'object', + properties => { + id => { + description => 'ID', + format => 'pve-configid', + maxLength => 64, + type => 'string', + }, + type => { + description => 'Section type.', + enum => ['one', 'two'], + type => 'string', + }, + common => { + type => 'string', + description => 'common value', + maxLength => 512, + }, + field1 => { + description => 'Field One', + maximum => 9, + minimum => 3, + optional => 1, + type => 'integer', + + }, + 'field2'=> { + 'description'=> 'Field Two', + 'maximum'=> 9, + 'minimum'=> 3, + 'optional'=> 1, + 'type'=> 'integer', + }, + 'arrayfield'=> { + 'description'=> 'Array Field with property string', + 'items'=> { + 'description'=> 'a property string', + 'format'=> { + 'subfield2'=> { + 'optional'=> 1, + 'type'=> 'integer', + 'minimum'=> 0 + }, + 'subfield1'=> { + 'description'=> 'first subfield', + 'type'=> 'string', + }, + }, + 'type'=> 'string' + }, + 'optional'=> 1, + 'type'=> 'array', + }, + 'another'=> { + 'description'=> 'Another field', + 'optional'=> 1, + 'type'=> 'string', + }, + }, +}; + +is_deeply($create_schema, $expected_create_schema, "create schema test"); + +my $update_schema = Conf->updateSchema(); +my $expected_update_schema = { + additionalProperties => 0, + type => 'object', + properties => { + id => { + description => 'ID', + format => 'pve-configid', + maxLength => 64, + type => 'string', + }, + delete => { + type => 'string', format => 'pve-configid-list', + description => "A list of settings you want to delete.", + maxLength => 4096, + optional => 1, + }, + digest => PVE::JSONSchema::get_standard_option('pve-config-digest'), + common => { + description => 'common value', + maxLength => 512, + type => 'string', + }, + field1 => { + description => 'Field One', + maximum => 9, + minimum => 3, + optional => 1, + type => 'integer' + }, + field2 => { + description => 'Field Two', + maximum => 9, + minimum => 3, + optional => 1, + type => 'integer', + }, + arrayfield => { + description => 'Array Field with property string', + items => { + type => 'string', + description => 'a property string', + format => { + subfield2 => { + type => 'integer', + minimum => 0, + optional => 1 + }, + subfield1 => { + description => 'first subfield', + type => 'string' + } + } + }, + optional => 1, + type => 'array', + }, + another => { + description => 'Another field', + optional => 1, + type => 'string', + }, + }, +}; +is_deeply($update_schema, $expected_update_schema, "update schema test"); + +done_testing(); + +1;