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:
.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)
= 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
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
+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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> Fri, 20 May 2022 14:01:17 +0200
+
+libpve-common-perl (7.2-1) bullseye; urgency=medium
+
+ * pbs-client: namespace support
+
+ -- Proxmox Support Team <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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 <support@proxmox.com> 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
Section: perl
Priority: optional
Maintainer: Proxmox Support Team <support@proxmox.com>
-Build-Depends: debhelper (>= 10~),
+Build-Depends: debhelper-compat (= 13),
+ libanyevent-perl,
libclone-perl,
libdevel-cycle-perl,
libfilesys-df-perl,
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,
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.
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
--- /dev/null
+# 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;
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;
$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};
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);
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 {
}
}
- $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) = @_;
}
};
- $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;
}
}
- $writeln->($borderstring_b) if $border;
+ $writeln->($border->{b}) if $show_border;
}
sub extract_properties_to_print {
}
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";
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);
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')) {
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;
return $a cmp $b;
}
} keys %$h;
+ return @sorted_commands;
});
}
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}});
$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'] ];
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);
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
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;
},
});
-# see RFC 7468
-my $b64_char_re = qr![0-9A-Za-z\+/]!;
my $header_re = sub {
my ($label) = @_;
return qr!-----BEGIN\ $label-----(?:\s|\n)*!;
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);
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 {
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 {
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;
};
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);
}
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) = @_;
$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);
}
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;
# 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;
}
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 {
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 {
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};
$self->init();
if (!$debug) {
- open STDIN, '</dev/null' || die "can't read /dev/null";
- open STDOUT, '>/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) {
# checks if the process was started by systemd
my $init_ppid = sub {
-
if (getppid() == 1) {
return 1;
} else {
# some useful helper
sub create_reusable_socket {
- my ($self, $port, $host, $family) = @_;
+ my ($self, $port, $host) = @_;
die "no port specifed" if !$port;
$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
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 {
$self->{$p} = ref($v) ? dclone($v) : $v;
}
- return bless $self;
+ return bless $self, $class;
}
sub raise {
--- /dev/null
+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;
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;
}
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;
\&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,
'bridge-fd' => 'bridge_fd',
'bridge-stp' => 'bridge_stp',
'bridge-ports' => 'bridge_ports',
- 'bridge-vids' => 'bridge_vids'
+ 'bridge-vids' => 'bridge_vids',
};
my $line;
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+(.*)$/) {
+
+ # 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;
$f->{comments} = '' if !$f->{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) {
+ } elsif ($line =~ m/^\s*(?:(?:iface|mapping|auto|source|source-directory)\s|allow-)/) {
last;
} elsif ($line =~ m/^\s*((\S+)\s+(.+))$/) {
my $option = $1;
'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,
'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')) {
+ if ($id eq 'address' || $id eq 'netmask' || $id eq 'broadcast' || $id eq 'gateway') {
$f->{$id} = $value;
} elsif ($simple_options->{$id}) {
$d->{$id} = $value;
} 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;
}
last;
}
}
- $d->{"$_$suffix"} = $f->{$_} foreach (keys %$f);
+ $d->{"$_$suffix"} = $f->{$_} for keys $f->%*;
last SECTION if !defined($line);
redo SECTION;
} elsif ($line =~ /\w/) {
}
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+$/) {
} 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';
}
+ if (!defined($d->{bridge_fd}) && $d->{bridge_stp} eq 'off') {
+ $d->{bridge_fd} = 0;
+ }
} elsif ($d->{ovs_type} eq 'OVSBridge') {
$d->{type} = $d->{ovs_type};
}
$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 $raw_iface = $d->{'vlan-raw-device'} ? $d->{'vlan-raw-device'} : $1;
+ 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';
+
+ 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 {
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';
}
}
$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'];
}
return '' if !($d && $d->{"method$suffix"});
- my $raw = '';
-
- $raw .= "iface $iface $family " . $d->{"method$suffix"} . "\n";
+ my $raw = "iface $iface $family " . $d->{"method$suffix"} . "\n";
if (my $addr = $d->{"address$suffix"}) {
-
if ($addr !~ /\/\d+$/ && $d->{"netmask$suffix"}) {
if ($d->{"netmask$suffix"} =~ m/^\d+$/) {
$addr .= "/" . $d->{"netmask$suffix"};
$addr .= "/" . $mask;
}
}
-
- $raw .= "\taddress " . $addr . "\n";
+ $raw .= "\taddress ${addr}\n";
}
$raw .= "\tgateway " . $d->{"gateway$suffix"} . "\n" if $d->{"gateway$suffix"};
- 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
$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') {
$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
# 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/) {
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';
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);
}
}
# 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
$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'};
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;
}
my $if_type_hash = {
loopback => 100000,
+ dummy => 100000,
eth => 200000,
OVSPort => 200000,
OVSIntPort => 300000,
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 {
}
}
+ # if 'inet6' is the only family
+ if (scalar($d->{families}->@*) == 1 && $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}};
}
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;
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/
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', {
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', {
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";
}
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) = @_;
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) = @_;
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);
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) = @_;
};
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;
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) = @_;
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;
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.
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 {
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) = @_;
}
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) {
}
}
- 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) {
}
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;
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);
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;
# 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) {
},
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.",
$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;
# 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";
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;
}
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}))) {
# 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";
- }
}
}
}
}
# 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} ||
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;
$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);
--- /dev/null
+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;
scheme => $scheme,
port => $port,
timeout => 10,
- onerror => 'die',
);
my $hosts = [];
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;
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;
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;
if ($code) {
return undef if $noerr;
- die $err;
+ die "$err\n";
}
return 1;
$err = "LDAP user query unsuccessful" if !$err;
}
- die $err if $err;
+ die "$err\n" if $err;
return $users;
}
$err = "LDAP group query unsuccessful" if !$err;
}
- die $err if $err;
+ die "$err\n" if $err;
return $groups;
}
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',
"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 {
my $burst = 1024*1024;
setup_tc_rate_limit($iface, $rate, $burst);
+
+ return;
}
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) = @_;
$vmid = $1;
$devid = $2;
} else {
- return undef if $noerr;
+ return if $noerr;
die "can't create firewall bridge for random interface name '$iface'\n";
}
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) };
eval { iface_set($iface, 'nomaster') };
die "can't unenslave '$iface'\n" if $@;
}
+ return;
}
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);
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';
};
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) = @_;
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 {
# 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 {
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);
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 {
};
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
}
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;
&$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 {
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 {
};
warn $@ if $@;
}
+ return;
}
sub activate_bridge_vlan_slave {
# add $ifacevlan to the bridge
&$bridge_add_interface($bridgevlan, $ifacevlan);
+ return;
}
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);
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;
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 {
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 {
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;
--- /dev/null
+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;
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;
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++;
}
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;
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 {
swaptotal => 0,
swapfree => 0,
swapused => 0,
+ arcsize => 0,
};
my $fh = IO::File->new ("/proc/meminfo", "r");
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;
}
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();
}
sub parse_mounts {
my ($mounts) = @_;
+
my $mntent = [];
while ($mounts =~ /^\s*([^#].*)$/gm) {
# lines from the file are encoded so we can just split at spaces
# 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;
}
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;
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
# 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;
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;
&$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);
}
}
- # 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;
PVE::INotify::write_file('active', $tlist) if $save;
return $tlist;
- };
-
- my $res = PVE::Tools::lock_file($lkfn, $timeout, $code);
+ });
die $@ if $@;
return $res;
};
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);
}
}
- # get status (error or OK)
POSIX::read($ctrlfd, $readbuf, 4096);
if ($readbuf =~ m/^TASK OK\n?$/) {
# skip printing to stdout
} 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";
}
$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;
my @psync = POSIX::pipe();
my @csync = POSIX::pipe();
- my @ctrlfd = POSIX::pipe() if $sync;
+ my @ctrlfd = $sync ? POSIX::pipe() : ();
my $node = $self->{nodename};
close STDIN;
POSIX::close(0) if $fd != 0;
- die "unable to redirect STDIN - $!"
- if !open(STDIN, "</dev/null");
+ open(STDIN, '<', '/dev/null') or die "unable to redirect STDIN - $!";
$outfh = PVE::Tools::upid_open($upid);
$resfh = fileno($outfh);
close STDOUT;
POSIX::close (1) if $fd != 1;
- die "unable to redirect STDOUT - $!"
- if !open(STDOUT, ">&", $outfh);
+ open(STDOUT, ">&", $outfh) or die "unable to redirect STDOUT - $!";
STDOUT->autoflush (1);
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);
};
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;
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 {
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 = {};
}
}
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)) {
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 {
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 {
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;
}
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;
}
chomp $wdescr;
$wdescr =~ s/^$/+/mg;
+ $wdescr =~ s/{/\\{/g;
+ $wdescr =~ s/}/\\}/g;
+
$res .= $wdescr . "\n";
if (my $req = $phash->{requires}) {
my $indend = " ";
$res .= Text::Wrap::wrap('', $indend, ($tmp));
- $res .= "\n",
$res .= Text::Wrap::wrap($indend, $indend, ($descr)) . "\n\n";
if (my $req = $phash->{requires}) {
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)) {
}
}
+ 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>"
}
$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;
}
}
}
- $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';
$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);
# 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 {
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 => {},
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;
+ }
+ }
}
}
}
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');
};
}
+# 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};
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;
}
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};
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};
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();
}
};
+ 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;
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";
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++;
}
}
}
-
- 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;
}
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 = '';
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};
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) {
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";
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;
+++ /dev/null
-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;
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 = {};
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)
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;
}
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;
}
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,
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;
}
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";
}
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";
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";
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) = @_;
package PVE::Syscall;
+use strict;
+use warnings;
+
my %syscalls;
my %fsmount_constants;
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 = (
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) = @_;
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',
}, $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;
use MIME::Base64;
use Digest::SHA;
use Time::HiRes qw(gettimeofday);
+use URI::Escape;
use PVE::Exception qw(raise);
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) &&
my $plain = "$prefix:";
- $plain .= "$data:" if defined($data);
+ if (defined($data)) {
+ $data = uri_escape($data, ':');
+ $plain .= "$data:";
+ }
$plain .= $timestamp;
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;
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;
safe_print
trim
extract_param
+extract_sensitive_params
file_copy
get_host_arch
O_PATH
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";
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,
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 <linux/fs.h>
+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) = @_;
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
# 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
}
sub file_set_contents {
- my ($filename, $data, $perm) = @_;
+ my ($filename, $data, $perm, $force_utf8) = @_;
$perm = 0644 if !defined($perm);
}
}
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;
};
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;
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';
$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, "</dev/null");
+ open(STDIN, '<', '/dev/null');
}
};
close $writer;
}
- my $select = new IO::Select;
+ my $select = IO::Select->new();
$select->add($reader) if ref($reader);
$select->add($error);
}
}
- alarm(0);
+ alarm(0);
};
my $err = $@;
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) = @_;
$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->();
}
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 {
return 'OK';
} elsif ($line =~ m/^TASK ERROR: (.+)$/) {
return $1;
+ } elsif ($line =~ m/^TASK (WARNINGS: \d+)$/) {
+ return $1;
} else {
return "unexpected 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) = @_;
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) = @_;
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 {
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--;
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;
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 {
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};
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) = @_;
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
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();
my ($dfd, $pathname, $flags) = @_;
return PVE::Syscall::file_handle_result(syscall(
&PVE::Syscall::open_tree,
- $dfd,
+ int($dfd),
$pathname,
- $flags,
+ int($flags),
));
}
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),
));
}
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).
$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) = @_;
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;
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:
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:
--- /dev/null
+#!/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();
my $tests = [
[
'*',
- { h => '*', m => '*', dow => $alldays },
+ undef,
[
[0, 60],
[30, 60],
],
[
'*/10',
- { h => '*', m => [0, 10, 20, 30, 40, 50], dow => $alldays },
+ undef,
[
[0, 600],
[599, 600],
],
[
'*/12:0' ,
- { h => [0, 12], m => [0], dow => $alldays },
+ undef,
[
[ 10, 43200],
[ 13*3600, 24*3600],
],
[
'1/12:0/15' ,
- { h => [1, 13], m => [0, 15, 30, 45], dow => $alldays },
+ undef,
[
[0, 3600],
[3600, 3600+15*60],
],
[
'1,4,6',
- { h => '*', m => [1, 4, 6], dow => $alldays},
+ undef,
[
[0, 60],
[60, 4*60],
],
[
'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],
],
[
'sat..sun',
- { h => [0], m => [0], dow => [0, 6] },
+ undef,
[
[0, 2*86400],
[2*86400, 3*86400],
],
[
'sun..sat',
- { h => [0], m => [0], dow => $alldays },
+ undef,
],
[
'Fri..Mon',
],
[
'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],
],
[
'*/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],
],
[
'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],
],
[
'0,1,3..5',
- { h => '*', m => [0,1,3,4,5], dow => $alldays },
+ undef,
[
[0, 60],
[60, 3*60],
],
[
'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],
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;
--- /dev/null
+# 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
+
--- /dev/null
+# 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
+
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;
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);
}
##
--- /dev/null
+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;
+++ /dev/null
-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;
iface eth1.100 inet manual
mtu 1400
-allow-vmbr6 ovsintvlan
+auto ovsintvlan
iface ovsintvlan inet manual
ovs_type OVSIntPort
ovs_bridge vmbr6
$bond0_part
-allow-vmbr6 bond1
+auto bond1
iface bond1 inet manual
ovs_bonds eth4 eth5
ovs_type OVSBond
bridge-fd 0
mtu 1100
-allow-ovs vmbr6
+auto vmbr6
iface vmbr6 inet manual
ovs_type OVSBridge
ovs_ports bond1 ovsintvlan
iface eth3 inet manual
-allow-ovs vmbr0
+auto vmbr0
iface vmbr0 inet static
address $ip
gateway $gw
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
auto eth0
iface eth0 inet manual
-allow-vmbr0 eth1
+auto eth1
iface eth1 inet manual
ovs_type OVSPort
ovs_bridge vmbr0
iface eth2 inet manual
-allow-ovs vmbr0
+auto vmbr0
iface vmbr0 inet static
address $ip
gateway $gw
--- /dev/null
+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;
--- /dev/null
+#!/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();
--- /dev/null
+#!/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();
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");
}
};
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
projects / pve-common.git / commitdiff