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.2.1) bookworm; urgency=medium
+
+ * interfaces: support stanzas without types/methods, like ifupdown2 supports
+
+ -- Proxmox Support Team <support@proxmox.com> Tue, 23 Apr 2024 15:42:55 +0200
+
+libpve-common-perl (8.2.0) bookworm; urgency=medium
+
+ * fix #545: interfaces: allow arbitrary bridge names in network config
+
+ -- Proxmox Support Team <support@proxmox.com> Sun, 21 Apr 2024 11:50:54 +0200
+
+libpve-common-perl (8.1.2) bookworm; urgency=medium
+
+ * remote format: improve documentation of expected API-token format
+
+ * json schema: add format description for pve-storage-id standard option
+
+ -- Proxmox Support Team <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
+
+ * sendmail helper: allow empty display name in "from" field
+
+ * CLI option parser: allow ommiting optional positional arguemnts, if there's
+ no ambiguity about it.
+
+ -- Proxmox Support Team <support@proxmox.com> Mon, 07 Sep 2020 10:01:03 +0200
+
+libpve-common-perl (6.2-1) pve pmg; urgency=medium
+
+ * file get contents: bump default size limit to 512k to match pmxcfs max file
+ size
+
+ * run command helper: improve performance for logging and long lines
+
+ * run command helper: fix matching of \r\n line ending
+
+ -- Proxmox Support Team <support@proxmox.com> Wed, 19 Aug 2020 12:29:06 +0200
+
+libpve-common-perl (6.1-5) pve pmg; urgency=medium
+
+ * JSONSchema: add format validator support and cleanup check_format
+
+ * sendmail: separate 'mailto' list from the rest of the parameters
+
+ -- Proxmox Support Team <support@proxmox.com> Tue, 07 Jul 2020 19:26:58 +0200
+
+libpve-common-perl (6.1-4) pve pmg; urgency=medium
+
+ * fix #2374: bridge-ports is assumed to be defined
+
+ * schema: register timezone format and add verification method
+
+ * fix #2796: debian/postinst: check for existing /etc/aliases
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 03 Jul 2020 14:16:49 +0200
+
+libpve-common-perl (6.1-3) pve pmg; urgency=medium
+
+ * network: vlan-aware bridge: fix PVID when trunks are defined
+
+ * Add total sum of physical CPU core count to CPU info used by node status
+ API call
+
+ * netowrk: always autostart bond slaves interfaces
+
+ -- Proxmox Support Team <support@proxmox.com> Mon, 08 Jun 2020 17:37:11 +0200
+
+libpve-common-perl (6.1-2) pve pmg; urgency=medium
+
+ * fix adding VLAN trunks to virtual guests NICs
+
+ -- Proxmox Support Team <support@proxmox.com> Sat, 09 May 2020 21:00:29 +0200
+
+libpve-common-perl (6.1-1) pve pmg; urgency=medium
+
+ * fix #2696: avoid 'undefined value' warning in unkown commands
+
+ * ProcFSTools: fix read_meminfo without KSM
+
+ * network: fix adding vlan tags to bridge
+
+ -- Proxmox Support Team <support@proxmox.com> Wed, 06 May 2020 12:14:19 +0200
+
+libpve-common-perl (6.0-20) pve pmg; urgency=medium
+
+ * network: replace system() with run_command()
+
+ * acme: split out into new package proxmox-acme-perl
+
+ -- Proxmox Support Team <support@proxmox.com> Mon, 20 Apr 2020 10:03:53 +0200
+
+libpve-common-perl (6.0-19) pve pmg; urgency=medium
+
+ * cpuset: cgroupv2 support and cleanup/refactor
+
+ * cpuset: allow empty cpusets
+
+ * JSONSchema: add acme-plugin-format
+
+ * JSONSchema: add idmap parser and storagepair format
+
+ -- Proxmox Support Team <support@proxmox.com> Sat, 04 Apr 2020 19:55:24 +0200
+
+libpve-common-perl (6.0-18) pve pmg; urgency=medium
+
+ * ldap: add optional classes to query_users and use them to filter
+
+ * ldap: optionally save group name by attribute
+
+ -- Proxmox Support Team <support@proxmox.com> Sat, 21 Mar 2020 16:49:47 +0100
+
+libpve-common-perl (6.0-17) pve pmg; urgency=medium
+
+ * inotify: ensure backwards compatibility on interface read
+
+ * normalize cidr, address and netmask entries.
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 13 Mar 2020 12:24:58 +0100
+
+libpve-common-perl (6.0-16) pve pmg; urgency=medium
+
+ * notify: fix compatibility when address and netmask got passed separately on
+ write
+
+ -- Proxmox Support Team <support@proxmox.com> Thu, 12 Mar 2020 16:15:17 +0100
+
+libpve-common-perl (6.0-15) pve pmg; urgency=medium
+
+ * inotify: read interfaces: avoid uninitialized value access
+
+ * RESTHandler getopt_usage: schema properties can be optional
+
+ * add ldap-simple-attr format from Proxmox Mailgateway for reuse
+
+ -- Proxmox Support Team <support@proxmox.com> Mon, 09 Mar 2020 17:01:42 +0100
+
+libpve-common-perl (6.0-14) pve pmg; urgency=medium
+
+ * INotify: use 'auto' for ovs interfaces with ifupdown2
+
+ * INotify : fix OVSBond and OvsintPort order, and add more tests
+
+ -- Proxmox Support Team <support@proxmox.com> Sat, 07 Mar 2020 17:51:16 +0100
+
+libpve-common-perl (6.0-13) pve pmg; urgency=medium
+
+ * INotify: fix mtu check and add test
+
+ * INotify : check_bridge : fix bridge-ports with vlan tagged interface
+
+ * zsh-completion: Add missing "options end here flag" to compadd
+
+ * get_ip_from_hostname: check all address we get from getaddrinfo_all for non-local IP
+
+ * INotify: use cidr for address on config change
+
+ * partially fix #2618: increase maximum port for spice to 61999
+
+ * add LDAP Wrapper code from Mailgateway
+
+ -- Proxmox Support Team <support@proxmox.com> Wed, 04 Mar 2020 15:44:15 +0100
+
+libpve-common-perl (6.0-12) pve pmg; urgency=medium
+
+ * systemd: add un-/escape_unit helpers
+
+ * procfs: add check_kernel_release
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 31 Jan 2020 10:32:59 +0100
+
+libpve-common-perl (6.0-11) pve pmg; urgency=medium
+
+ * ACME: use GET-as-POST call for compatibility with new API authorization
+ requirements
+
+ * API schema: add 'allowtoken' property
+
+ * INotify network: improve vlan interface parsing
+
+ -- Proxmox Support Team <support@proxmox.com> Tue, 28 Jan 2020 11:33:21 +0100
+
libpve-common-perl (6.0-10) pve pmg; urgency=medium
* INotify: add "bond-primary" and "ovs_mtu" option
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,
-Standards-Version: 3.9.8
+ libtest-mockmodule-perl,
+ 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: pmg-api (<< 5.0-74),
- pve-container (<< 3.0-9),
- pve-manager (<< 5.2-5),
- qemu-server (<< 5.0-49),
+Breaks: ifupdown2 (<< 2.0.1-1+pve5),
+ 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.
-Copyright (C) 2010 Proxmox Server Solutions GmbH
+Copyright (C) 2010 - 2020 Proxmox Server Solutions GmbH
This software is written by Proxmox Server Solutions GmbH <support@proxmox.com>
if test -n "$2"; then
# TODO: remove once PVE 7.0 is released
- if dpkg --compare-versions "$2" 'lt' '6.0-5'; then
+ if dpkg --compare-versions "$2" 'lt' '6.0-5' && [ -e /etc/aliases ]; then
sed -E -i -e 's/^www:(\w)/www: \1/' /etc/aliases
fi
fi
PERLDIR=${PREFIX}/share/perl5
LIB_SOURCES = \
- ACME.pm \
- ACME/Challenge.pm \
- ACME/StandAlone.pm \
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/ACME
+ 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
-package PVE::ACME;
-
-use strict;
-use warnings;
-
-use POSIX;
-
-use Data::Dumper;
-use Date::Parse;
-use MIME::Base64 qw(encode_base64url);
-use File::Path qw(make_path);
-use JSON;
-use Digest::SHA qw(sha256 sha256_hex);
-
-use HTTP::Request;
-use LWP::UserAgent;
-
-use Crypt::OpenSSL::RSA;
-
-use PVE::Certificate;
-use PVE::Tools qw(
-file_set_contents
-file_get_contents
-);
-
-Crypt::OpenSSL::RSA->import_random_seed();
-
-my $LETSENCRYPT_STAGING = 'https://acme-staging-v02.api.letsencrypt.org/directory';
-
-### ACME library (compatible with Let's Encrypt v2 API)
-#
-# sample usage:
-#
-# 1) my $acme = PVE::ACME->new('path/to/account.json', 'API directory URL');
-# 2) $acme->init(4096); # generate account key
-# 4) my $tos_url = $acme->get_meta()->{termsOfService}; # optional, display if applicable
-# 5) $acme->new_account($tos_url, contact => ['mailto:example@example.com']);
-#
-# 1) my $acme = PVE::ACME->new('path/to/account.json', 'API directory URL');
-# 2) $acme->load();
-# 3) my ($order_url, $order) = $acme->new_order(['foo.example.com', 'bar.example.com']);
-# 4) # repeat a-f for each $auth_url in $order->{authorizations}
-# a) my $authorization = $acme->get_authorization($auth_url);
-# b) # pick $challenge from $authorization->{challenges} according to desired type
-# c) my $key_auth = $acme->key_authorization($challenge->{token});
-# d) # setup challenge validation according to specification
-# e) $acme->request_challenge_validation($challenge->{url}, $key_auth);
-# f) # poll $acme->get_authorization($auth_url) until status is 'valid'
-# 5) # generate CSR in PEM format
-# 6) $acme->finalize_order($order, $csr);
-# 7) # poll $acme->get_order($order_url) until status is 'valid'
-# 8) my $cert = $acme->get_certificate($order);
-# 9) # $key is path to key file, $cert contains PEM-encoded certificate chain
-#
-# 1) my $acme = PVE::ACME->new('path/to/account.json', 'API directory URL');
-# 2) $acme->load();
-# 3) $acme->revoke_certificate($cert);
-
-# Tools
-sub encode($) { # acme requires 'base64url' encoding
- return encode_base64url($_[0]);
-}
-
-sub tojs($;%) { # shortcut for to_json with utf8=>1
- my ($data, %data) = @_;
- return to_json($data, { utf8 => 1, %data });
-}
-
-sub fromjs($) {
- return from_json($_[0]);
-}
-
-sub fatal($$;$$) {
- my ($self, $msg, $dump, $noerr) = @_;
-
- warn Dumper($dump), "\n" if $self->{debug} && $dump;
- if ($noerr) {
- warn "$msg\n";
- } else {
- die "$msg\n";
- }
-}
-
-# Implementation
-
-# $path: account JSON file
-# $directory: the ACME directory URL used to find method URLs
-sub new($$$) {
- my ($class, $path, $directory) = @_;
-
- $directory //= $LETSENCRYPT_STAGING;
-
- my $ua = LWP::UserAgent->new();
- $ua->env_proxy();
- $ua->agent('pve-acme/0.1');
- $ua->protocols_allowed(['https']);
-
- my $self = {
- ua => $ua,
- path => $path,
- directory => $directory,
- nonce => undef,
- key => undef,
- location => undef,
- account => undef,
- tos => undef,
- };
-
- return bless $self, $class;
-}
-
-# RS256: PKCS#1 padding, no OAEP, SHA256
-my $configure_key = sub {
- my ($key) = @_;
- $key->use_pkcs1_padding();
- $key->use_sha256_hash();
-};
-
-# Create account key with $keybits bits
-# use instead of load, overwrites existing account JSON file!
-sub init {
- my ($self, $keybits) = @_;
- die "Already have a key\n" if defined($self->{key});
- $keybits //= 4096;
- my $key = Crypt::OpenSSL::RSA->generate_key($keybits);
- $configure_key->($key);
- $self->{key} = $key;
- $self->save();
-}
-
-my @SAVED_VALUES = qw(location account tos debug directory);
-# Serialize persistent parts of $self to $self->{path} as JSON
-sub save {
- my ($self) = @_;
- my $o = {};
- my $keystr;
- if (my $key = $self->{key}) {
- $keystr = $key->get_private_key_string();
- $o->{key} = $keystr;
- }
- for my $k (@SAVED_VALUES) {
- my $v = $self->{$k} // next;
- $o->{$k} = $v;
- }
- # pretty => 1 for readability
- # canonical => 1 to reduce churn
- file_set_contents($self->{path}, tojs($o, pretty => 1, canonical => 1));
-}
-
-# Load serialized account JSON file into $self
-sub load {
- my ($self) = @_;
- return if $self->{loaded};
- $self->{loaded} = 1;
- my $raw = file_get_contents($self->{path});
- if ($raw =~ m/^(.*)$/s) { $raw = $1; } # untaint
- my $data = fromjs($raw);
- $self->{$_} = $data->{$_} for @SAVED_VALUES;
- if (defined(my $keystr = $data->{key})) {
- my $key = Crypt::OpenSSL::RSA->new_private_key($keystr);
- $configure_key->($key);
- $self->{key} = $key;
- }
-}
-
-# The 'jwk' object needs the key type, key parameters and the usage,
-# except for when we want to take the JWK-Thumbprint, then the usage
-# must not be included.
-sub jwk {
- my ($self, $pure) = @_;
- my $key = $self->{key}
- or die "No key was generated yet\n";
- my ($n, $e) = $key->get_key_parameters();
- return {
- kty => 'RSA',
- ($pure ? () : (use => 'sig')), # for thumbprints
- n => encode($n->to_bin),
- e => encode($e->to_bin),
- };
-}
-
-# The thumbprint is a sha256 hash of the lexicographically sorted (iow.
-# canonical) condensed json string of the JWK object which gets base64url
-# encoded.
-sub jwk_thumbprint {
- my ($self) = @_;
- my $jwk = $self->jwk(1); # $pure = 1
- return encode(sha256(tojs($jwk, canonical=>1))); # canonical sorts
-}
-
-# A key authorization string in acme is a challenge token dot-connected with
-# a JWK Thumbprint. You put the base64url encoded sha256-hash of this string
-# into the DNS TXT record.
-sub key_authorization {
- my ($self, $token) = @_;
- return $token .'.'. $self->jwk_thumbprint();
-}
-
-# JWS signing using the RS256 alg (RSA/SHA256).
-sub jws {
- my ($self, $use_jwk, $data, $url) = @_;
- my $key = $self->{key}
- or die "No key was generated yet\n";
-
- my $payload = $data ne '' ? encode(tojs($data)) : $data;
-
- if (!defined($self->{nonce})) {
- my $method = $self->_method('newNonce');
- $self->do(GET => $method);
- }
-
- # The acme protocol requires the actual request URL be in the protected
- # header. There is no unprotected header.
- my $protected = {
- alg => 'RS256',
- url => $url,
- nonce => $self->{nonce} // die "missing nonce\n"
- };
-
- # header contains either
- # - kid, reference to account URL
- # - jwk, key itself
- # the latter is only allowed for
- # - creating accounts (no account URL yet)
- # - revoking certificates with the certificate key instead of account key
- if ($use_jwk) {
- $protected->{jwk} = $self->jwk();
- } else {
- $protected->{kid} = $self->{location};
- }
-
- $protected = encode(tojs($protected));
-
- my $signdata = "$protected.$payload";
- my $signature = encode($key->sign($signdata));
-
- return {
- protected => $protected,
- payload => $payload,
- signature => $signature,
- };
-}
-
-sub __get_result {
- my ($resp, $code, $plain) = @_;
-
- die "expected code '$code', received '".$resp->code."'\n"
- if $resp->code != $code;
-
- return $plain ? $resp->decoded_content : fromjs($resp->decoded_content);
-}
-
-# Get the list of method URLs and query the directory if we have to.
-sub __get_methods {
- my ($self) = @_;
- if (my $methods = $self->{methods}) {
- return $methods;
- }
- my $r = $self->do(GET => $self->{directory});
- my $methods = __get_result($r, 200);
- $self->fatal("unable to decode methods returned by directory - $@", $r) if $@;
- return ($self->{methods} = $methods);
-}
-
-# Get a method, causing the directory to be queried first if necessary.
-sub _method {
- my ($self, $method) = @_;
- my $methods = $self->__get_methods();
- my $url = $methods->{$method}
- or die "no such method: $method\n";
- return $url;
-}
-
-# Get $self->{account} with an error if we don't have one yet.
-sub _account {
- my ($self) = @_;
- my $account = $self->{account}
- // die "no account loaded\n";
- return wantarray ? ($account, $self->{location}) : $account;
-}
-
-# debugging info
-sub list_methods {
- my ($self) = @_;
- my $methods = $self->__get_methods();
- if (my $meta = $methods->{meta}) {
- print("(meta): $_ : $meta->{$_}\n") for sort keys %$meta;
- }
- print("$_ : $methods->{$_}\n") for sort grep {$_ ne 'meta'} keys %$methods;
-}
-
-# return (optional) meta directory entry.
-# this is public because it might contain the ToS, which should be displayed
-# and agreed to before creating an account
-sub get_meta {
- my ($self) = @_;
- my $methods = $self->__get_methods();
- return $methods->{meta};
-}
-
-# Common code between new_account and update_account
-sub __new_account {
- my ($self, $expected_code, $url, $new, %info) = @_;
- my $req = {
- %info,
- };
- my $r = $self->do(POST => $url, $req, $new);
- eval {
- my $account = __get_result($r, $expected_code);
- if (!defined($self->{location})) {
- my $account_url = $r->header('Location')
- or die "did not receive an account URL\n";
- $self->{location} = $account_url;
- }
- $self->{account} = $account;
- $self->save();
- };
- $self->fatal("POST to '$url' failed - $@", $r) if $@;
- return $self->{account};
-}
-
-# Create a new account using data in %info.
-# Optionally pass $tos_url to agree to the given Terms of Service
-# POST to newAccount endpoint
-# Expects a '201 Created' reply
-# Saves and returns the account data
-sub new_account {
- my ($self, $tos_url, %info) = @_;
- my $url = $self->_method('newAccount');
-
- if ($tos_url) {
- $self->{tos} = $tos_url;
- $info{termsOfServiceAgreed} = JSON::true;
- }
-
- return $self->__new_account(201, $url, 1, %info);
-}
-
-# Update existing account with new %info
-# POST to account URL
-# Expects a '200 OK' reply
-# Saves and returns updated account data
-sub update_account {
- my ($self, %info) = @_;
- my (undef, $url) = $self->_account;
-
- return $self->__new_account(200, $url, 0, %info);
-}
-
-# Retrieves existing account information
-# POST to account URL with empty body!
-# Expects a '200 OK' reply
-# Saves and returns updated account data
-sub get_account {
- my ($self) = @_;
- return $self->update_account();
-}
-
-# Start a new order for one or more domains
-# POST to newOrder endpoint
-# Expects a '201 Created' reply
-# returns order URL and parsed order object, including authorization and finalize URLs
-sub new_order {
- my ($self, $domains) = @_;
-
- my $url = $self->_method('newOrder');
- my $req = {
- identifiers => [ map { { type => 'dns', value => $_ } } @$domains ],
- };
-
- my $r = $self->do(POST => $url, $req);
- my ($order_url, $order);
- eval {
- $order_url = $r->header('Location')
- or die "did not receive an order URL\n";
- $order = __get_result($r, 201)
- };
- $self->fatal("POST to '$url' failed - $@", $r) if $@;
- return ($order_url, $order);
-}
-
-# Finalize order after all challenges have been validated
-# POST to order's finalize URL
-# Expects a '200 OK' reply
-# returns (potentially updated) order object
-sub finalize_order {
- my ($self, $order, $csr) = @_;
-
- my $req = {
- csr => encode($csr),
- };
- my $r = $self->do(POST => $order->{finalize}, $req);
- my $return = eval { __get_result($r, 200); };
- $self->fatal("POST to '$order->{finalize}' failed - $@", $r) if $@;
- return $return;
-}
-
-# Get order status
-# GET-as-POST to order URL
-# Expects a '200 OK' reply
-# returns order object
-sub get_order {
- my ($self, $order_url) = @_;
- my $r = $self->do(POST => $order_url, '');
- my $return = eval { __get_result($r, 200); };
- $self->fatal("POST of '$order_url' failed - $@", $r) if $@;
- return $return;
-}
-
-# Gets authorization object
-# GET-as-POST to authorization URL
-# Expects a '200 OK' reply
-# returns authorization object, including challenges array
-sub get_authorization {
- my ($self, $auth_url) = @_;
-
- my $r = $self->do(POST => $auth_url, '');
- my $return = eval { __get_result($r, 200); };
- $self->fatal("POST of '$auth_url' failed - $@", $r) if $@;
- return $return;
-}
-
-# Deactivates existing authorization
-# POST to authorization URL
-# Expects a '200 OK' reply
-# returns updated authorization object
-sub deactivate_authorization {
- my ($self, $auth_url) = @_;
-
- my $req = {
- status => 'deactivated',
- };
- my $r = $self->do(POST => $auth_url, $req);
- my $return = eval { __get_result($r, 200); };
- $self->fatal("POST to '$auth_url' failed - $@", $r) if $@;
- return $return;
-}
-
-# Get certificate
-# GET-as-POST to order's certificate URL
-# Expects a '200 OK' reply
-# returns certificate chain in PEM format
-sub get_certificate {
- my ($self, $order) = @_;
-
- $self->fatal("no certificate URL available (yet?)", $order)
- if !$order->{certificate};
-
- my $r = $self->do(POST => $order->{certificate}, '');
- my $return = eval { __get_result($r, 200, 1); };
- $self->fatal("POST of '$order->{certificate}' failed - $@", $r) if $@;
- return $return;
-}
-
-# Revoke given certificate
-# POST to revokeCert endpoint
-# currently only supports revokation with account key
-# $certificate can either be PEM or DER encoded
-# Expects a '200 OK' reply
-sub revoke_certificate {
- my ($self, $certificate, $reason) = @_;
-
- my $url = $self->_method('revokeCert');
-
- if ($certificate =~ /^-----BEGIN CERTIFICATE-----/) {
- $certificate = PVE::Certificate::pem_to_der($certificate);
- }
-
- my $req = {
- certificate => encode($certificate),
- reason => $reason // 0,
- };
- # TODO: set use_jwk if revoking with certificate key
- my $r = $self->do(POST => $url, $req);
- eval {
- die "unexpected code $r->code\n" if $r->code != 200;
- };
- $self->fatal("POST to '$url' failed - $@", $r) if $@;
-}
-
-# Request validation of challenge
-# POST to challenge URL
-# call after validation has been setup
-# returns (potentially updated) challenge object
-sub request_challenge_validation {
- my ($self, $url, $key_authorization) = @_;
-
- my $req = { keyAuthorization => $key_authorization };
-
- my $r = $self->do(POST => $url, $req);
- my $return = eval { __get_result($r, 200); };
- $self->fatal("POST to '$url' failed - $@", $r) if $@;
- return $return;
-}
-
-# actually 'do' a $method request on $url
-# $data: input for JWS, optional
-# $use_jwk: use JWK instead of KID in JWD (see sub jws)
-sub do {
- my ($self, $method, $url, $data, $use_jwk) = @_;
-
- $self->fatal("Error: can't $method to empty URL") if !$url || $url eq '';
-
- my $headers = HTTP::Headers->new();
- $headers->header('Content-Type' => 'application/jose+json');
- my $content = defined($data) ? $self->jws($use_jwk, $data, $url) : undef;
- my $request;
- if (defined($content)) {
- $content = tojs($content);
- $request = HTTP::Request->new($method, $url, $headers, $content);
- } else {
- $request = HTTP::Request->new($method, $url, $headers);
- }
- my $res = $self->{ua}->request($request);
- if (!$res->is_success) {
- # check for nonce rejection
- if ($res->code == 400 && $res->decoded_content) {
- my $parsed_content = fromjs($res->decoded_content);
- if ($parsed_content->{type} eq 'urn:ietf:params:acme:error:badNonce') {
- warn("bad Nonce, retrying\n");
- $self->{nonce} = $res->header('Replay-Nonce');
- return $self->do($method, $url, $data, $use_jwk);
- }
- }
- $self->fatal("Error: $method to $url\n".$res->decoded_content, $res);
- }
- if (my $nonce = $res->header('Replay-Nonce')) {
- $self->{nonce} = $nonce;
- }
- return $res;
-}
-
-1;
+++ /dev/null
-package PVE::ACME::Challenge;
-
-use strict;
-use warnings;
-
-sub supported_challenge_types {
- return {};
-}
-
-sub setup {
- my ($class, $acme, $authorization) = @_;
-
- die "implement me\n";
-}
-
-sub teardown {
- my ($self) = @_;
-
- die "implement me\n";
-}
-
-1;
+++ /dev/null
-package PVE::ACME::StandAlone;
-
-use strict;
-use warnings;
-
-use HTTP::Daemon;
-use HTTP::Response;
-
-use base qw(PVE::ACME::Challenge);
-
-sub supported_challenge_types {
- return { 'http-01' => 1 };
-}
-
-sub setup {
- my ($class, $acme, $authorization) = @_;
-
- my $challenges = $authorization->{challenges};
- die "no challenges defined in authorization\n" if !$challenges;
-
- my $http_challenges = [ grep {$_->{type} eq 'http-01'} @$challenges ];
- die "no http-01 challenge defined in authorization\n"
- if ! scalar $http_challenges;
-
- my $http_challenge = $http_challenges->[0];
-
- die "no token found in http-01 challenge\n" if !$http_challenge->{token};
-
- my $key_authorization = $acme->key_authorization($http_challenge->{token});
-
- my $server = HTTP::Daemon->new(
- LocalPort => 80,
- ReuseAddr => 1,
- ) or die "Failed to initialize HTTP daemon\n";
- my $pid = fork() // die "Failed to fork HTTP daemon - $!\n";
- if ($pid) {
- my $self = {
- server => $server,
- pid => $pid,
- authorization => $authorization,
- key_auth => $key_authorization,
- url => $http_challenge->{url},
- };
-
- return bless $self, $class;
- } else {
- while (my $c = $server->accept()) {
- while (my $r = $c->get_request()) {
- if ($r->method() eq 'GET' and $r->uri->path eq "/.well-known/acme-challenge/$http_challenge->{token}") {
- my $resp = HTTP::Response->new(200, 'OK', undef, $key_authorization);
- $resp->request($r);
- $c->send_response($resp);
- } else {
- $c->send_error(404, 'Not found.')
- }
- }
- $c->close();
- $c = undef;
- }
- }
-}
-
-sub teardown {
- my ($self) = @_;
-
- eval { $self->{server}->close() };
- kill('KILL', $self->{pid});
- waitpid($self->{pid}, 0);
-}
-
-1;
--- /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;
# $props_to_print - ordered list of properties to print
# $options
# - sort_key: can be used to sort after a specific column, if it isn't set we sort
-# after the leftmost column (with no undef value in $data) this can be
-# turned off by passing 0 as sort_key
+# after the leftmost column. This can be turned off by passing 0 as sort_key
# - noborder: print without asciiart border
# - noheader: print without table header
# - columns: limit output width (if > 0)
$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};
if (defined($sort_key) && $sort_key ne 0) {
my $type = $returnprops->{$sort_key}->{type} // 'string';
+ my $cmpfn;
if ($type eq 'integer' || $type eq 'number') {
- @$data = sort { $a->{$sort_key} <=> $b->{$sort_key} } @$data;
+ $cmpfn = sub { $_[0] <=> $_[1] };
} else {
- @$data = sort { $a->{$sort_key} cmp $b->{$sort_key} } @$data;
+ $cmpfn = sub { $_[0] cmp $_[1] };
}
+ @$data = sort {
+ PVE::Tools::safe_compare($a->{$sort_key}, $b->{$sort_key}, $cmpfn)
+ } @$data;
}
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')) {
}
} else {
+ $abort->("unknown command '$cmd->[0]'") if !$def;
my ($class, $name, $arg_param, $fixed_param, undef, $formatter_properties) = @$def;
- $abort->("unknown command '$cmd'") if !$class;
$str .= $indent;
$str .= $class->usage_str($name, $prefix, $arg_param, $fixed_param, $format, $param_cb, $formatter_properties);
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}});
cmd=\${words[1]}
curr=\${words[cwords]}
prev=\${words[cwords-1]}
- compadd \$(COMP_CWORD="\$cwords" COMP_LINE="\$line" COMP_POINT="\$point" \\
+ compadd -- \$(COMP_CWORD="\$cwords" COMP_LINE="\$line" COMP_POINT="\$point" \\
$exename bashcomplete "\$cmd" "\$curr" "\$prev")
}
__EOD__
$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;
}
use PVE::ProcFSTools;
sub new {
- my ($this) = @_;
+ my ($class, $members) = @_;
- my $class = ref($this) || $this;
-
- my $self = bless { members => {} }, $class;
+ $members //= {};
+ my $self = bless { members => $members }, $class;
return $self;
}
+# Create a new set with the contents of a cgroup-v1 subdirectory.
+# Deprecated:
sub new_from_cgroup {
- my ($this, $cgroup, $kind) = @_;
+ my ($class, $cgroup, $effective) = @_;
+
+ return $class->new_from_path("/sys/fs/cgroup/cpuset/$cgroup", $effective);
+}
- $kind //= 'cpus';
+# Create a new set from the contents of a complete path to a cgroup directory.
+sub new_from_path {
+ my ($class, $path, $effective) = @_;
+
+ my $filename;
+ if ($effective) {
+ $filename = "$path/cpuset.effective_cpus";
+ if (!-e $filename) {
+ # cgroupv2:
+ $filename = "$path/cpuset.cpus.effective";
+ }
+ } else {
+ $filename = "$path/cpuset.cpus";
+ }
- my $filename = "/sys/fs/cgroup/cpuset/$cgroup/cpuset.$kind";
my $set_text = PVE::Tools::file_read_firstline($filename) // '';
- my $cpuset = $this->new();
+ my ($count, $members) = parse_cpuset($set_text);
- my $members = $cpuset->{members};
+ return $class->new($members);
+}
+sub parse_cpuset {
+ my ($set_text) = @_;
+
+ my $members = {};
my $count = 0;
foreach my $part (split(/,/, $set_text)) {
}
}
- die "got empty cpuset for cgroup '$cgroup'\n"
- if !$count;
-
- return $cpuset;
+ return ($count, $members);
}
+# Deprecated:
sub write_to_cgroup {
my ($self, $cgroup) = @_;
- my $filename = "/sys/fs/cgroup/cpuset/$cgroup/cpuset.cpus";
+ return $self->write_to_path("/sys/fs/cgroup/cpuset/$cgroup");
+}
+
+# Takes the cgroup directory containing the cpuset.cpus file (to be closer to
+# new_from_path behavior this doesn't take the complete file name).
+sub write_to_path {
+ my ($self, $path) = @_;
+
+ my $filename = "$path/cpuset.cpus";
my $value = '';
my @members = $self->members();
$value .= $cpuid;
}
- die "unable to write empty cpu set\n" if !length($value);
-
open(my $fh, '>', $filename) || die "failed to open '$filename' - $!\n";
PVE::Tools::safe_print($filename, $fh, "$value\n");
close($fh) || die "failed to close '$filename' - $!\n";
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;
package PVE::INotify;
# todo: maybe we do not need update_file() ?
-
use strict;
use warnings;
-use POSIX;
-use IO::File;
-use IO::Dir;
-use File::stat;
-use File::Basename;
+use Clone qw(clone);
+use Digest::SHA;
+use Encode qw(encode decode);
use Fcntl qw(:DEFAULT :flock);
-use PVE::SafeSyslog;
+use File::Basename;
+use File::stat;
+use IO::Dir;
+use IO::File;
+use JSON;
+use Linux::Inotify2;
+use POSIX;
+
use PVE::Exception qw(raise_param_exc);
+use PVE::JSONSchema;
use PVE::Network;
-use PVE::Tools;
use PVE::ProcFSTools;
-use PVE::JSONSchema;
-use Clone qw(clone);
-use Linux::Inotify2;
+use PVE::SafeSyslog;
+use PVE::Tools;
+use PVE::RESTEnvironment qw(log_warn);
+
use base 'Exporter';
-use JSON;
-use Digest::SHA;
-use Encode qw(encode decode);
-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+(.*)$/) {
- } elsif ($line =~ m/^\s*iface\s+(\S+)\s+(inet6?)\s+(\S+)\s*$/) {
+ # FIXME: handle those differently? auto makes it required on-boot, vs. best-effort
+ $ifaces->{$_}->{autostart} = 1 for split (/\s+/, $2);
+
+ } elsif ($line =~ m/^\s*iface\s+(\S+)(?:\s+(inet6?)\s+(\S+))?\s*$/) {
my $i = $1;
my $family = $2;
my $f = { method => $3 }; # by family, merged to $d with a $suffix
- (my $suffix = $family) =~ s/^inet//;
+ my $suffix = $family;
+ $suffix =~ s/^inet// if defined $suffix;
my $d = $ifaces->{$i} ||= {};
$d->{priority} = $priority++ if !$d->{priority};
+
+ # $family may be undef, an undef family means we have a stanza
+ # without an `inet` or `inet6` section
push @{$d->{families}}, $family;
+
while (defined ($line = <$fh>)) {
- chomp $line;
+ $line =~ s/\s+$//; # drop trailing whitespaces
+
if ($line =~ m/^\s*#(.*?)\s*$/) {
- $f->{comments} = '' if !$f->{comments};
+ my $pushto = defined($suffix) ? $f : $d;
+ $pushto->{comments} = '' if !$pushto->{comments};
my $comment = decode('UTF-8', $1);
- $f->{comments} .= "$comment\n";
- } elsif ($line =~ m/^\s*(?:iface\s
- |mapping\s
- |auto\s
- |allow-
- |source\s
- |source-directory\s
- )/x) {
+ $pushto->{comments} .= "$comment\n";
+ } elsif ($line =~ m/^\s*(?:(?:iface|mapping|auto|source|source-directory)\s|allow-)/) {
last;
} elsif ($line =~ m/^\s*((\S+)\s+(.+))$/) {
my $option = $1;
'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,
+ 'vlan-id' => 1,
'vxlan-id' => 1,
'vxlan-svcnodeip' => 1,
'vxlan-physdev' => 1,
- 'vxlan-local-tunnelip' => 1 };
-
- if (($id eq 'address') || ($id eq 'netmask') || ($id eq 'broadcast') || ($id eq 'gateway')) {
- $f->{$id} = $value;
+ 'vxlan-local-tunnelip' => 1,
+ };
+
+ if ($id eq 'address' || $id eq 'netmask' || $id eq 'broadcast' || $id eq 'gateway') {
+ if (defined($suffix)) {
+ $d->{$id.$suffix} = $value;
+ } elsif ($id ne 'netmask') {
+ if ($value =~ /:/) {
+ $d->{$id.'6'} = $value;
+ } else {
+ $d->{$id} = $value;
+ }
+ } else {
+ $d->{$id} = $value;
+ }
} elsif ($simple_options->{$id}) {
$d->{$id} = $value;
} elsif ($id eq 'slaves' || $id eq 'bridge_ports') {
} 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;
}
} elsif ($id eq 'vxlan-remoteip') {
push @{$d->{$id}}, $value;
} else {
- push @{$f->{options}}, $option;
+ my $pushto = defined($suffix) ? $f : $d;
+ push @{$pushto->{options}}, $option;
}
} else {
last;
}
}
- $d->{"$_$suffix"} = $f->{$_} foreach (keys %$f);
+ if (defined($suffix)) {
+ $d->{"$_$suffix"} = $f->{$_} for keys $f->%*;
+ }
last SECTION if !defined($line);
redo SECTION;
} elsif ($line =~ /\w/) {
}
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};
- if ($iface =~ m/^bond\d+$/) {
+ $d->{type} = 'unknown';
+ if (defined $d->{'bridge_ports'}) {
+ $d->{type} = 'bridge';
+ if (!defined ($d->{bridge_stp})) {
+ $d->{bridge_stp} = 'off';
+ }
+ if (!defined($d->{bridge_fd}) && $d->{bridge_stp} eq 'off') {
+ $d->{bridge_fd} = 0;
+ }
+ } elsif ($d->{ovs_type} && $d->{ovs_type} eq 'OVSBridge') {
+ $d->{type} = $d->{ovs_type};
+ } elsif ($iface =~ m/^bond\d+$/) {
if (!$d->{ovs_type}) {
$d->{type} = 'bond';
} elsif ($d->{ovs_type} eq 'OVSBond') {
}
my $tag = &$extract_ovs_option($d, 'tag');
$d->{ovs_tag} = $tag if defined($tag);
- } else {
- $d->{type} = 'unknown';
- }
- } elsif ($iface =~ m/^vmbr\d+$/) {
- if (!$d->{ovs_type}) {
- $d->{type} = 'bridge';
-
- if (!defined ($d->{bridge_fd})) {
- $d->{bridge_fd} = 0;
- }
- if (!defined ($d->{bridge_stp})) {
- $d->{bridge_stp} = 'off';
- }
- } elsif ($d->{ovs_type} eq 'OVSBridge') {
- $d->{type} = $d->{ovs_type};
- } else {
- $d->{type} = 'unknown';
}
} elsif ($iface =~ m/^(\S+):\d+$/) {
$d->{type} = 'alias';
$ifaces->{$1}->{exists} = 0;
$d->{exists} = 0;
}
- } elsif ($iface =~ m/^(\S+)\.\d+$/) {
+ } elsif ($iface =~ m/^(\S+)\.(\d+)$/) {
$d->{type} = 'vlan';
- if (defined ($ifaces->{$1})) {
- $d->{exists} = $ifaces->{$1}->{exists};
+
+ 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->{$1}->{exists} = 0;
+ $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 {
+ $ifaces->{$raw_iface}->{exists} = 0;
$d->{exists} = 0;
}
} elsif ($iface =~ m/^$PVE::Network::PHYSICAL_NIC_RE$/) {
$d->{type} = $d->{ovs_type};
my $tag = &$extract_ovs_option($d, 'tag');
$d->{ovs_tag} = $tag if defined($tag);
- } else {
- $d->{type} = 'unknown';
}
} elsif ($iface =~ m/^lo$/) {
$d->{type} = 'loopback';
} else {
if ($d->{'vxlan-id'}) {
$d->{type} = 'vxlan';
- } elsif (!$d->{ovs_type}) {
- $d->{type} = 'unknown';
- } elsif ($d->{ovs_type} eq 'OVSIntPort') {
- $d->{type} = $d->{ovs_type};
- my $tag = &$extract_ovs_option($d, 'tag');
- $d->{ovs_tag} = $tag if defined($tag);
+ } elsif (defined($d->{ovs_type})) {
+ if ($d->{ovs_type} eq 'OVSIntPort') {
+ $d->{type} = $d->{ovs_type};
+ my $tag = &$extract_ovs_option($d, 'tag');
+ $d->{ovs_tag} = $tag if defined($tag);
+ }
+ } elsif (defined($d->{'link-type'})) {
+ $d->{type} = $d->{'link-type'} if $d->{'link-type'} eq 'dummy';
}
}
+ log_warn("detected a interface $iface that is not a bridge!")
+ if !($d->{type} eq 'OVSBridge' || $d->{type} eq 'bridge') && $iface =~ m/^vmbr\d+$/;
+
# map address and netmask to cidr
- if ($d->{address}) {
- if ($d->{netmask} && $d->{netmask} =~ m/^\d+$/) { # e.g. netmask 20
- $d->{cidr} = $d->{address} . "/" . $d->{netmask};
- } elsif ($d->{netmask} &&
- (my $cidr = PVE::JSONSchema::get_netmask_bits($d->{netmask}))) { # e.g. netmask 255.255.255.0
- $d->{cidr} = $d->{address} . "/" . $cidr;
- } elsif ($d->{address} =~ m!^(.*)/(\d+)$!) {
- $d->{cidr} = $d->{address};
- $d->{address} = $1;
- $d->{netmask} = $2;
+ if (my $addr = $d->{address}) {
+ if (_address_is_cidr($addr)) {
+ $d->{cidr} = $addr;
+ my ($baseaddr, $mask) = _cidr_split($addr);
+ $d->{address} = $baseaddr;
+ $d->{netmask} = $mask;
+ } elsif (my $cidr = _get_cidr($d->{address}, $d->{netmask})) {
+ $d->{cidr} = $cidr;
+ (undef, $d->{netmask}) = _cidr_split($cidr);
} else {
- $d->{cidr} = $d->{address};
+ # no mask, else we'd got a cidr above
+ $d->{cidr} = $addr ."/32";
}
}
# map address6 and netmask6 to cidr6
- if ($d->{address6}) {
- $d->{cidr6} = $d->{address6};
- if ($d->{netmask6}) {
- $d->{cidr6} .= "/" . $d->{netmask6};
- } elsif ($d->{address6} =~ m!^(.*)/(\d+)$!) {
- $d->{address6} = $1;
- $d->{netmask6} = $2;
+ if (my $addr6 = $d->{address6}) {
+ if (_address_is_cidr($addr6)) {
+ $d->{cidr6} = $addr6;
+ my ($baseaddr, $mask) = _cidr_split($addr6);
+ $d->{address6} = $baseaddr;
+ $d->{netmask6} = $mask;
+ } elsif (my $cidr6 = _get_cidr($d->{address6}, $d->{netmask6})) {
+ $d->{cidr6} = $cidr6;
+ } else {
+ # no mask, else we'd got a cidr above
+ $d->{cidr6} = $addr6 ."/128";
}
}
$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 $config;
}
+sub _address_is_cidr {
+ my ($addr) = @_;
+ return $addr =~ /\/\d+$/ ? 1 : 0;
+}
+
+sub _cidr_split {
+ my ($cidr) = @_;
+ $cidr =~ /^(.+)\/(\d+)$/;
+ return ($1, $2); # (address, mask)
+}
+
+sub _get_cidr {
+ my ($addr, $mask) = @_;
+
+ return $addr if _address_is_cidr($addr);
+ return undef if !$mask;
+
+ if ($mask =~ m/^\d+$/) { # cidr notation
+ return $addr . "/" . $mask;
+ } elsif (my $cidrmask = PVE::JSONSchema::get_netmask_bits($mask)) {
+ return $addr . "/" . $cidrmask;
+ }
+ return undef;
+}
+
sub __interface_to_string {
my ($iface, $d, $family, $first_block, $ifupdown2) = @_;
- (my $suffix = $family) =~ s/^inet//;
+ my $suffix = $family;
+ $suffix =~ s/^inet// if defined($suffix);
- return '' if !($d && $d->{"method$suffix"});
+ return '' if $family && !($d && $d->{"method$suffix"});
- my $raw = '';
+ my $raw = "iface $iface";
+ $raw .= " $family " . $d->{"method$suffix"} if defined $family;
+ $raw .= "\n";
- $raw .= "iface $iface $family " . $d->{"method$suffix"} . "\n";
- $raw .= "\taddress " . $d->{"address$suffix"} . "\n" if $d->{"address$suffix"};
- $raw .= "\tnetmask " . $d->{"netmask$suffix"} . "\n" if $d->{"netmask$suffix"};
- $raw .= "\tgateway " . $d->{"gateway$suffix"} . "\n" if $d->{"gateway$suffix"};
- $raw .= "\tbroadcast " . $d->{"broadcast$suffix"} . "\n" if $d->{"broadcast$suffix"};
+ my $add_addr = sub {
+ my ($suffix) = @_;
+ if (my $addr = $d->{"address$suffix"}) {
+ if ($addr !~ /\/\d+$/ && $d->{"netmask$suffix"}) {
+ if ($d->{"netmask$suffix"} =~ m/^\d+$/) {
+ $addr .= "/" . $d->{"netmask$suffix"};
+ } elsif (my $mask = PVE::JSONSchema::get_netmask_bits($d->{"netmask$suffix"})) {
+ $addr .= "/" . $mask;
+ }
+ }
+ $raw .= "\taddress ${addr}\n";
+ }
+
+ $raw .= "\tgateway " . $d->{"gateway$suffix"} . "\n" if $d->{"gateway$suffix"};
+ };
+
+ if ($family) {
+ $add_addr->($suffix);
+ } else {
+ $add_addr->('');
+ $add_addr->('6');
+ }
- my $done = { type => 1, priority => 1, method => 1, active => 1, exists => 1,
- comments => 1, autostart => 1, options => 1,
- address => 1, netmask => 1, gateway => 1, broadcast => 1,
- method6 => 1, families => 1, options6 => 1,
- address6 => 1, netmask6 => 1, gateway6 => 1, broadcast6 => 1, 'uplink-id' => 1 };
+ my $done = {
+ type => 1, priority => 1, method => 1, active => 1, exists => 1, comments => 1,
+ autostart => 1, options => 1, address => 1, netmask => 1, gateway => 1, broadcast => 1,
+ method6 => 1, families => 1, options6 => 1, comments6 => 1, address6 => 1,
+ netmask6 => 1, gateway6 => 1, broadcast6 => 1, 'uplink-id' => 1,
+ };
if (!$first_block) {
# not printing out options
} elsif ($d->{type} eq 'bridge') {
- $d->{bridge_ports} =~ s/[;,\s]+/ /g;
my $ports = $d->{bridge_ports} || 'none';
+ $ports =~ s/[;,\s]+/ /g;
$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
$done->{ovs_type} = 1;
if (my $bridge = $d->{ovs_bridge}) {
- $raw = "allow-$bridge $iface\n$raw";
+ if ($ifupdown2) {
+ $raw = "auto $iface\n$raw";
+ } else {
+ $raw = "allow-$bridge $iface\n$raw";
+ }
+
$raw .= "\tovs_bridge $bridge\n";
$done->{ovs_bridge} = 1;
}
}
}
- foreach my $option (@{$d->{"options$suffix"}}) {
- $raw .= "\t$option\n";
- }
+ my $add_options_comments = sub {
+ my ($suffix) = @_;
+
+ foreach my $option (@{$d->{"options$suffix"}}) {
+ $raw .= "\t$option\n";
+ }
- # add comments
- my $comments = $d->{"comments$suffix"} || '';
- foreach my $cl (split(/\n/, $comments)) {
- $raw .= "#$cl\n";
+ # add comments
+ my $comments = $d->{"comments$suffix"} || '';
+ foreach my $cl (split(/\n/, $comments)) {
+ $raw .= "#$cl\n";
+ }
+ };
+
+ if ($family) {
+ $add_options_comments->($suffix);
+ } else {
+ $add_options_comments->('');
+ $add_options_comments->('6');
}
$raw .= "\n";
sub write_etc_network_interfaces {
my ($filename, $fh, $config) = @_;
- my $ifupdown2 = -e '/usr/share/ifupdown2';
+ my $ifupdown2 = -e '/usr/share/ifupdown2/ifupdown2';
my $raw = __write_etc_network_interfaces($config, $ifupdown2);
PVE::Tools::safe_print($filename, $fh, encode('UTF-8', $raw));
}
foreach my $iface (keys %$ifaces) {
my $d = $ifaces->{$iface};
- delete $d->{cidr};
- delete $d->{cidr6};
+ my ($cidr, $cidr6) = (delete $d->{cidr}, delete $d->{cidr6});
+ $d->{address} //= $cidr;
+ $d->{address6} //= $cidr6;
my $ports = '';
foreach my $k (qw(bridge_ports ovs_ports slaves ovs_bonds)) {
# 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/) {
- $ifaces->{$iface} = { type => 'eth',
- exists => 1,
- method => 'manual',
- families => ['inet'] };
+ $ifaces->{$iface} = {
+ type => 'eth',
+ exists => 1,
+ method => 'manual',
+ families => ['inet'],
+ };
} else {
delete $ifaces->{$iface};
}
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';
if ($d->{type} eq 'OVSBond' && $d->{ovs_bonds}) {
foreach my $p (split (/\s+/, $d->{ovs_bonds})) {
my $n = $ifaces->{$p};
- 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';
+ $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';
&$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};
+ 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
# check vlan
foreach my $iface (keys %$ifaces) {
my $d = $ifaces->{$iface};
- if ($d->{type} eq 'vlan' && $iface =~ m/^(\S+)\.\d+$/) {
- my $p = $1;
+ if ($d->{type} eq 'vlan') {
+
+ my $p = undef;
+ my $vlanid = undef;
+
+ if ($iface =~ m/^(\S+)\.(\d+)$/) {
+ $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'};
+
+ if ($iface =~ m/^vlan(\d+)$/) {
+ $vlanid = $1;
+ delete $d->{'vlan-id'} if $d->{'vlan-id'};
+ } else {
+ die "custom vlan interface name need ifupdown2" if !$ifupdown2;
+ die "missing vlan-id option" if !$d->{'vlan-id'};
+ $vlanid = $d->{'vlan-id'};
+ }
+ }
my $n = $ifaces->{$p};
+ die "vlan '$iface' - vlan-id $vlanid should be <= 4094\n" if $vlanid > 4094;
die "vlan '$iface' - unable to find parent '$p'\n"
if !$n;
# check bridgeport option
my $bridgeports = {};
my $bridges = {};
- foreach my $iface (keys %$ifaces) {
- my $d = $ifaces->{$iface};
+ my $ifaces_copy = { %$ifaces };
+ foreach my $iface (keys %$ifaces_copy) {
+ my $d = $ifaces_copy->{$iface};
if ($d->{type} eq 'bridge') {
- foreach my $p (split (/\s+/, $d->{bridge_ports})) {
- $p =~ s/\.\d+$//;
- my $n = $ifaces->{$p};
+ foreach my $p (split (/\s+/, $d->{bridge_ports} // '')) {
+ if($p =~ m/(\S+)\.(\d+)$/) {
+ my $vlanparent = $1;
+ if (!defined($ifaces_copy->{$p})) {
+ $ifaces_copy->{$p}->{type} = 'vlan';
+ $ifaces_copy->{$p}->{method} = 'manual';
+ $ifaces_copy->{$p}->{method6} = 'manual';
+ $ifaces_copy->{$p}->{mtu} = $ifaces_copy->{$vlanparent}->{mtu} if defined($ifaces_copy->{$1}->{mtu});
+ }
+ }
+ my $n = $ifaces_copy->{$p};
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} eq 'static' && $n->{address} ne '0.0.0.0') ||
- ($n->{method6} eq 'static' && $n->{address} ne '::');
-
- &$check_mtu($ifaces, $iface, $p);
+ if ($n->{method} && $n->{method} eq 'static' && $n->{address} ne '0.0.0.0') ||
+ ($n->{method6} && $n->{method6} eq 'static' && $n->{address6} ne '::');
+ &$check_mtu($ifaces_copy, $p, $iface);
$bridgeports->{$p} = $iface;
}
$bridges->{$iface} = $d;
my $if_type_hash = {
loopback => 100000,
+ dummy => 100000,
eth => 200000,
OVSPort => 200000,
- OVSIntPort => 200000,
- bond => 300000,
- bridge => 400000,
- OVSBridge => 400000,
- vxlan => 500000,
+ OVSIntPort => 300000,
+ OVSBond => 400000,
+ bond => 400000,
+ bridge => 500000,
+ OVSBridge => 500000,
+ vlan => 600000,
+ vxlan => 600000,
};
my $lookup_type_prio = sub {
my ($rootiface, @rest) = split(/[.:]/, $iface);
my $childlevel = scalar(@rest);
- my $n = $ifaces->{$rootiface};
-
- my $pri = $if_type_hash->{$n->{type}} + $childlevel
- if $n->{type} && $n->{type} ne 'unknown';
+ my $type = $ifaces->{$rootiface}->{type};
+ return if !$type || $type eq 'unknown';
- return $pri;
+ return $if_type_hash->{$type} + $childlevel
};
foreach my $iface (sort {
$printed->{$iface} = 1;
if ($d->{autostart}) {
- if ($d->{type} eq 'OVSBridge') {
+ if ($d->{type} eq 'OVSBridge' && !$ifupdown2) {
# cannot use 'auto' for OVS, would add race with systemd ifup@.service
$raw .= "allow-ovs $iface\n";
} else {
}
}
+ # if 'inet6' is the only family
+ if (scalar($d->{families}->@*) == 1 && defined($d->{families}->[0]) && $d->{families}->[0] eq 'inet6') {
+ $d->{comments6} = delete $d->{comments};
+ }
+
my $i = 0; # some options should be printed only once
$raw .= __interface_to_string($iface, $d, $_, !$i++, $ifupdown2) foreach @{$d->{families}};
}
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;
our @EXPORT_OK = qw(
register_standard_option
get_standard_option
+parse_property_string
+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', {
});
my $format_list = {};
+my $format_validators = {};
sub register_format {
- my ($format, $code) = @_;
+ my ($name, $format, $validator) = @_;
- die "JSON schema format '$format' already registered\n"
- if $format_list->{$format};
+ die "JSON schema format '$name' already registered\n"
+ if $format_list->{$name};
- $format_list->{$format} = $code;
+ if ($validator) {
+ die "A \$validator function can only be specified for hash-based formats\n"
+ if ref($format) ne 'HASH';
+ $format_validators->{$name} = $validator;
+ }
+
+ $format_list->{$name} = $format;
}
sub get_format {
- my ($format) = @_;
- return $format_list->{$format};
+ my ($name) = @_;
+ return $format_list->{$name};
}
my $renderer_hash = {};
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";
}
sub parse_storage_id {
my ($storeid, $noerr) = @_;
- if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
+ 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 "storage ID '$storeid' contains illegal characters\n";
+ die "invalid bridge ID '$id'\n";
}
- return $storeid;
+ return $id;
+}
+
+PVE::JSONSchema::register_format('acme-plugin-id', \&parse_acme_plugin_id);
+sub parse_acme_plugin_id {
+ my ($pluginid, $noerr) = @_;
+
+ return parse_id($pluginid, 'ACME plugin', $noerr);
}
+sub parse_id {
+ my ($id, $type, $noerr) = @_;
+
+ if ($id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
+ return undef if $noerr;
+ die "$type ID '$id' contains illegal characters\n";
+ }
+ return $id;
+}
register_format('pve-vmid', \&pve_verify_vmid);
sub pve_verify_vmid {
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 undef if !$idmap;
+
+ my $map = {};
+
+ foreach my $entry (PVE::Tools::split_list($idmap)) {
+ if ($entry eq '1') {
+ $map->{identity} = 1;
+ } elsif ($entry =~ m/^([^:]+):([^:]+)$/) {
+ my ($source, $target) = ($1, $2);
+ eval {
+ check_format($idformat, $source, '');
+ check_format($idformat, $target, '');
+ };
+ die "entry '$entry' contains invalid ID - $@\n" if $@;
+
+ die "duplicate mapping for source '$source'\n"
+ if exists $map->{entries}->{$source};
+
+ $map->{entries}->{$source} = $target;
+ } else {
+ eval {
+ check_format($idformat, $entry);
+ };
+ die "entry '$entry' contains invalid ID - $@\n" if $@;
+
+ die "default target ID can only be provided once\n"
+ if exists $map->{default};
+
+ $map->{default} = $entry;
+ }
+ }
+
+ die "identity mapping cannot be combined with other mappings\n"
+ if $map->{identity} && ($map->{default} || exists $map->{entries});
+
+ return $map;
+}
+
+my $verify_idpair = sub {
+ my ($input, $noerr, $format) = @_;
+
+ eval { parse_idmap($input, $format) };
+ if ($@) {
+ return undef if $noerr;
+ die "$@\n";
+ }
+
+ 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_mac_addr {
my ($mac_addr, $noerr) = @_;
return $ip;
}
+PVE::JSONSchema::register_format('ldap-simple-attr', \&verify_ldap_simple_attr);
+sub verify_ldap_simple_attr {
+ my ($attr, $noerr) = @_;
+
+ if ($attr =~ m/^[a-zA-Z0-9]+$/) {
+ return $attr;
+ }
+
+ die "value '$attr' does not look like a simple ldap attribute name\n" if !$noerr;
+
+ return undef;
+}
+
my $ipv4_mask_hash = {
'0.0.0.0' => 0,
'128.0.0.0' => 1,
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) = @_;
return $name;
}
+register_format('timezone', \&pve_verify_timezone);
+sub pve_verify_timezone {
+ my ($timezone, $noerr) = @_;
+
+ return $timezone if $timezone eq 'UTC';
+
+ open(my $fh, "<", "/usr/share/zoneinfo/zone.tab");
+ while (my $line = <$fh>) {
+ next if $line =~ /^\s*#/;
+ chomp $line;
+ my $zone = (split /\t/, $line)[2];
+ return $timezone if $timezone eq $zone; # found
+ }
+ close $fh;
+
+ return undef if $noerr;
+ die "invalid time zone '$timezone'\n";
+}
+
# network interface name
register_format('pve-iface', \&pve_verify_iface);
sub pve_verify_iface {
};
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";
}
-sub check_format {
- my ($format, $value, $path) = @_;
-
- return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
- return if $format eq 'regex';
-
- if ($format =~ m/^(.*)-a?list$/) {
- my $code = $format_list->{$1};
+PVE::JSONSchema::register_format('pve-task-status-type', \&verify_task_status_type);
+sub verify_task_status_type {
+ my ($value, $noerr) = @_;
- die "undefined format '$format'\n" if !$code;
+ return $value if $value =~ m/^(ok|error|warning|unknown)$/i;
- # Note: we allow empty lists
- foreach my $v (split_list($value)) {
- &$code($v);
- }
-
- } elsif ($format =~ m/^(.*)-opt$/) {
+ return undef if $noerr;
- my $code = $format_list->{$1};
+ die "invalid status '$value'\n";
+}
- die "undefined format '$format'\n" if !$code;
+sub check_format {
+ my ($format, $value, $path) = @_;
- return if !$value; # allow empty string
+ if (ref($format) eq 'HASH') {
+ # hash ref cannot have validator/list/opt handling attached
+ return parse_property_string($format, $value, $path);
+ }
- &$code($value);
+ if (ref($format) eq 'CODE') {
+ # we are the (sole, old-style) validator
+ return $format->($value);
+ }
- } else {
+ return if $format eq 'regex';
- my $code = $format_list->{$format};
+ my $parsed;
+ $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;
- die "undefined format '$format'\n" if !$code;
+ die "'-$format_type' format must have code ref, not hash\n"
+ if $format_type ne 'none' && ref($registered) ne 'CODE';
- return parse_property_string($code, $value, $path) if ref($code) eq 'HASH';
- &$code($value);
+ if ($format_type eq 'list') {
+ $parsed = [];
+ # Note: we allow empty lists
+ foreach my $v (split_list($value)) {
+ push @{$parsed}, $registered->($v);
+ }
+ } elsif ($format_type eq 'opt') {
+ $parsed = $registered->($value) if $value;
+ } 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.
+ # We do however have to call it with $format_name instead of
+ # $registered, so it knows about the name (and thus any validators).
+ $parsed = parse_property_string($format, $value, $path);
+ } else {
+ $parsed = $registered->($value);
+ }
}
+
+ return $parsed;
}
sub parse_size {
$additional_properties = 0 if !defined($additional_properties);
# Support named formats here, too:
+ my $validator;
if (!ref($format)) {
- if (my $desc = $format_list->{$format}) {
- $format = $desc;
+ if (my $reg = get_format($format)) {
+ die "parse_property_string only accepts hash based named formats\n"
+ if ref($reg) ne 'HASH';
+
+ # named formats can have validators attached
+ $validator = $format_validators->{$format};
+
+ $format = $reg;
} else {
die "unknown format: $format\n";
}
raise "format error\n", errors => $errors;
}
+ return $validator->($res) if $validator;
return $res;
}
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;
description => "Method needs special privileges - only pvedaemon can execute it",
optional => 1,
},
+ allowtoken => {
+ type => 'boolean',
+ description => "Method is available for clients authenticated using an API token.",
+ optional => 1,
+ default => 1,
+ },
download => {
type => 'boolean',
description => "Method downloads the file content (filename is the return value of the method).",
# 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";
$opts->{$list_param} = $args;
$args = [];
} elsif (ref($arg_param)) {
- foreach my $arg_name (@$arg_param) {
+ for (my $i = 0; $i < scalar(@$arg_param); $i++) {
+ my $arg_name = $arg_param->[$i];
if ($opts->{'extra-args'}) {
raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
}
$args = [];
next;
}
- raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
+ if (!@$args) {
+ # check if all left-over arg_param are optional, else we
+ # must die as the mapping is then ambigious
+ 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;
}
raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
foreach my $arg_name (@$arg_param) {
if ($arg_name eq 'extra-args') {
$opts->{'extra-args'} = [];
- } else {
+ } elsif (!$schema->{properties}->{$arg_name}->{optional}) {
raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
}
}
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);
sub print_property_string {
my ($data, $format, $skip, $path) = @_;
+ my $validator;
if (ref($format) ne 'HASH') {
my $schema = get_format($format);
die "not a valid format: $format\n" if !$schema;
+ # named formats can have validators attached
+ $validator = $format_validators->{$format};
$format = $schema;
}
raise "format error", errors => $errors;
}
+ $data = $validator->($data) if $validator;
+
my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
my $res = '';
--- /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;
--- /dev/null
+package PVE::LDAP;
+
+use strict;
+use warnings;
+
+use Net::IP;
+use Net::LDAP;
+use Net::LDAP::Control::Paged;
+use Net::LDAP::Constant qw(LDAP_CONTROL_PAGED);
+
+sub ldap_connect {
+ my ($servers, $scheme, $port, $opts) = @_;
+
+ my $start_tls = 0;
+
+ if ($scheme eq 'ldap+starttls') {
+ $scheme = 'ldap';
+ $start_tls = 1;
+ }
+
+ my %ldap_opts = (
+ scheme => $scheme,
+ port => $port,
+ timeout => 10,
+ );
+
+ my $hosts = [];
+ for my $host (@$servers) {
+ if (Net::IP::ip_is_ipv6($host)) {
+ push @$hosts, "[$host]";
+ } else {
+ push @$hosts, $host;
+ }
+ }
+
+ for my $opt (qw(clientcert clientkey capath cafile sslversion verify)) {
+ $ldap_opts{$opt} = $opts->{$opt} if $opts->{$opt};
+ }
+
+ my $ldap = Net::LDAP->new($hosts, %ldap_opts) || die "$@\n";
+
+ if ($start_tls) {
+ my $res = $ldap->start_tls(%$opts);
+ die $res->error . "\n" if $res->code;
+ }
+
+ return $ldap;
+}
+
+sub ldap_bind {
+ my ($ldap, $dn, $pw) = @_;
+
+ my $res;
+ if (defined($dn) && defined($pw)) {
+ $res = $ldap->bind($dn, password => $pw);
+ } else { # anonymous bind
+ $res = $ldap->bind();
+ }
+
+ my $code = $res->code;
+ my $err = $res->error;
+
+ die "ldap bind failed: $err\n" if $code;
+}
+
+sub get_user_dn {
+ my ($ldap, $name, $attr, $base_dn) = @_;
+
+ # search for dn
+ my $result = $ldap->search(
+ base => $base_dn // "",
+ scope => "sub",
+ 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;
+ my $err = $res->error;
+
+ if ($code) {
+ return undef if $noerr;
+ die "$err\n";
+ }
+
+ return 1;
+}
+
+sub query_users {
+ my ($ldap, $filter, $attributes, $base_dn, $classes) = @_;
+
+ # build filter from given filter and attribute list
+ my $tmp = "(|";
+ foreach my $att (@$attributes) {
+ $tmp .= "($att=*)";
+ }
+ $tmp .= ")";
+
+ if ($classes) {
+ $tmp = "(&$tmp(|";
+ for my $class (@$classes) {
+ $tmp .= "(objectclass=$class)";
+ }
+ $tmp .= "))";
+ }
+
+ if ($filter) {
+ $filter = "($filter)" if $filter !~ m/^\(.*\)$/;
+ $filter = "(&${filter}${tmp})"
+ } else {
+ $filter = $tmp;
+ }
+
+ my $page = Net::LDAP::Control::Paged->new(size => 900);
+
+ my @args = (
+ base => $base_dn // "",
+ scope => "subtree",
+ filter => $filter,
+ control => [ $page ],
+ attrs => [ @$attributes, 'memberOf'],
+ );
+
+ my $cookie;
+ my $err;
+ my $users = [];
+
+ while(1) {
+
+ my $mesg = $ldap->search(@args);
+
+ # stop on error
+ if ($mesg->code) {
+ $err = "ldap user search error: " . $mesg->error;
+ last;
+ }
+
+ #foreach my $entry ($mesg->entries) { $entry->dump; }
+ foreach my $entry ($mesg->entries) {
+ my $user = {
+ dn => $entry->dn,
+ attributes => {},
+ groups => [$entry->get_value('memberOf')],
+ };
+
+ foreach my $attr (@$attributes) {
+ my $vals = [$entry->get_value($attr)];
+ if (scalar(@$vals)) {
+ $user->{attributes}->{$attr} = $vals;
+ }
+ }
+
+ push @$users, $user;
+ }
+
+ # Get cookie from paged control
+ my ($resp) = $mesg->control(LDAP_CONTROL_PAGED) or last;
+ $cookie = $resp->cookie;
+
+ last if (!defined($cookie) || !length($cookie));
+
+ # Set cookie in paged control
+ $page->cookie($cookie);
+ }
+
+ if (defined($cookie) && length($cookie)) {
+ # We had an abnormal exit, so let the server know we do not want any more
+ $page->cookie($cookie);
+ $page->size(0);
+ $ldap->search(@args);
+ $err = "LDAP user query unsuccessful" if !$err;
+ }
+
+ die "$err\n" if $err;
+
+ return $users;
+}
+
+sub query_groups {
+ my ($ldap, $base_dn, $classes, $filter, $group_name_attr) = @_;
+
+ my $tmp = "(|";
+ for my $class (@$classes) {
+ $tmp .= "(objectclass=$class)";
+ }
+ $tmp .= ")";
+
+ if ($filter) {
+ $filter = "($filter)" if $filter !~ m/^\(.*\)$/;
+ $filter = "(&${filter}${tmp})"
+ } else {
+ $filter = $tmp;
+ }
+
+ my $page = Net::LDAP::Control::Paged->new(size => 100);
+
+ my $attrs = [ 'member', 'uniqueMember' ];
+ push @$attrs, $group_name_attr if $group_name_attr;
+ my @args = (
+ base => $base_dn,
+ scope => "subtree",
+ filter => $filter,
+ control => [ $page ],
+ attrs => $attrs,
+ );
+
+ my $cookie;
+ my $err;
+ my $groups = [];
+
+ while(1) {
+
+ my $mesg = $ldap->search(@args);
+
+ # stop on error
+ if ($mesg->code) {
+ $err = "ldap group search error: " . $mesg->error;
+ last;
+ }
+
+ foreach my $entry ( $mesg->entries ) {
+ my $group = {
+ dn => $entry->dn,
+ members => []
+ };
+ my $members = [$entry->get_value('member')];
+ if (!scalar(@$members)) {
+ $members = [$entry->get_value('uniqueMember')];
+ }
+ $group->{members} = $members;
+ if ($group_name_attr && (my $name = $entry->get_value($group_name_attr))) {
+ $group->{name} = $name;
+ }
+ push @$groups, $group;
+ }
+
+ # Get cookie from paged control
+ my ($resp) = $mesg->control(LDAP_CONTROL_PAGED) or last;
+ $cookie = $resp->cookie;
+
+ last if (!defined($cookie) || !length($cookie));
+
+ # Set cookie in paged control
+ $page->cookie($cookie);
+ }
+
+ if ($cookie) {
+ # We had an abnormal exit, so let the server know we do not want any more
+ $page->cookie($cookie);
+ $page->size(0);
+ $ldap->search(@args);
+ $err = "LDAP group query unsuccessful" if !$err;
+ }
+
+ die "$err\n" if $err;
+
+ return $groups;
+}
+
+1;
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',
};
sub setup_tc_rate_limit {
- my ($iface, $rate, $burst, $debug) = @_;
+ my ($iface, $rate, $burst) = @_;
# these are allowed / expected to fail, e.g. when there is no previous rate limit to remove
eval { run_command("/sbin/tc class del dev $iface parent 1: classid 1:1 >/dev/null 2>&1"); };
"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");
-
- if ($debug) {
- print "DEBUG tc settings\n";
- system("/sbin/tc qdisc ls dev $iface");
- system("/sbin/tc class ls dev $iface");
- system("/sbin/tc filter ls dev $iface parent ffff:");
- }
+ 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 ($iface, $rate) = @_;
- my $debug = 0;
$rate = int($rate*1024*1024) if $rate;
my $burst = 1024*1024;
- setup_tc_rate_limit($iface, $rate, $burst, $debug);
+ setup_tc_rate_limit($iface, $rate, $burst);
+
+ return;
}
-my $read_bridge_mtu = sub {
+sub read_bridge_mtu {
my ($bridge) = @_;
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);
my $vlan_aware = PVE::Tools::file_read_firstline("/sys/class/net/$bridge/bridge/vlan_filtering");
if ($vlan_aware) {
- if ($tag) {
- system({'/sbin/bridge'} 'bridge', 'vlan', 'del', 'dev', $iface, 'vid', '1-4094') == 0
- or die "failed to remove default vlan tags of $iface\n";
- system({'/sbin/bridge'} 'bridge', 'vlan', 'add', 'dev', $iface, 'vid', $tag, 'pvid', 'untagged') == 0
- or die "unable to add vlan $tag to interface $iface\n";
- warn "Caution: Setting VLAN ID 1 on a VLAN aware bridge may be dangerous\n" if $tag == 1;
- } else {
- system("/sbin/bridge vlan add dev $iface vid 2-4094") == 0 ||
- die "unable to add default vlan tags to interface $iface\n" if !$trunks;
- }
-
- if ($trunks) {
- my @trunks_array = split /;/, $trunks;
- foreach my $trunk (@trunks_array) {
- system("/sbin/bridge vlan add dev $iface vid $trunk") == 0 ||
- die "unable to add vlan $trunk to interface $iface\n";
- }
- }
+ eval { run_command(['/sbin/bridge', 'vlan', 'del', 'dev', $iface, 'vid', '1-4094']) };
+ die "failed to remove default vlan tags of $iface - $@\n" if $@;
+
+ if ($trunks) {
+ my @trunks_array = split /;/, $trunks;
+ foreach my $trunk (@trunks_array) {
+ eval { run_command(['/sbin/bridge', 'vlan', 'add', 'dev', $iface, 'vid', $trunk]) };
+ die "unable to add vlan $trunk to interface $iface - $@\n" if $@;
+ }
+ } elsif (!$tag) {
+ eval { run_command(['/sbin/bridge', 'vlan', 'add', 'dev', $iface, 'vid', '2-4094']) };
+ die "unable to add default vlan tags to interface $iface - $@\n" if $@;
+ }
+
+ $tag = 1 if !$tag;
+ eval { run_command(['/sbin/bridge', 'vlan', 'add', 'dev', $iface, 'vid', $tag, 'pvid', 'untagged']) };
+ die "unable to add vlan $tag to interface $iface - $@\n" if $@;
}
};
$trunks =~ s/;/,/g if $trunks;
- my $cmd = "/usr/bin/ovs-vsctl add-port $bridge $iface";
- $cmd .= " tag=$tag" if $tag;
- $cmd .= " trunks=". join(',', $trunks) if $trunks;
- $cmd .= " vlan_mode=native-untagged" if $tag && $trunks;
+ my $cmd = ['/usr/bin/ovs-vsctl'];
+ # first command
+ push @$cmd, '--', 'add-port', $bridge, $iface;
+ push @$cmd, "tag=$tag" if $tag;
+ 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';
+ }
+
+ eval { run_command($cmd) };
+ die "can't add ovs port '$iface' - $@\n" if $@;
- $cmd .= " -- set Interface $iface type=internal" if $internal;
- system($cmd) == 0 ||
- die "can't add ovs port '$iface'\n";
disable_ipv6($iface);
};
my $activate_interface = sub {
- my ($iface) = @_;
+ my ($iface, $mtu) = @_;
+
+ my $cmd = ['/sbin/ip', 'link', 'set', $iface, 'up'];
+ push @$cmd, ('mtu', $mtu) if $mtu;
- system("/sbin/ip link set $iface up") == 0 ||
- die "can't activate interface '$iface'\n";
+ 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) = @_;
die "unable to get bridge setting\n" if !$bridge;
- my $bridgemtu = &$read_bridge_mtu($bridge);
+ my $bridgemtu = read_bridge_mtu($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 {
die "unable to get bridge setting\n" if !$bridge;
- my $bridgemtu = &$read_bridge_mtu($bridge);
+ my $bridgemtu = read_bridge_mtu($bridge);
# create veth pair
if (! -d "/sys/class/net/$veth") {
- my $cmd = "/sbin/ip link add name $veth mtu $bridgemtu type veth peer name $vethpeer mtu $bridgemtu";
- $cmd .= " addr $mac" if $mac;
- system($cmd) == 0 || die "can't create interface $veth\n";
+ my $cmd = ['/sbin/ip', 'link', 'add'];
+ # veth device + MTU
+ push @$cmd, 'name', $veth;
+ push @$cmd, 'mtu', $bridgemtu;
+ push @$cmd, 'type', 'veth';
+ # peer device + MTU
+ push @$cmd, 'peer', 'name', $vethpeer, 'mtu', $bridgemtu;
+
+ push @$cmd, 'addr', $mac if $mac;
+
+ eval { run_command($cmd) };
+ die "can't create interface $veth - $@\n" if $@;
}
# 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);
+ 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 {
# create vlan on $iface is not already exist
if (! -d "/sys/class/net/$ifacevlan") {
- system("/sbin/ip link add link $iface name $ifacevlan type vlan id $tag") == 0 ||
- die "can't add vlan tag $tag to interface $iface\n";
+ eval {
+ my $cmd = ['/sbin/ip', 'link', 'add'];
+ push @$cmd, 'link', $iface;
+ push @$cmd, 'name', $ifacevlan;
+ push @$cmd, 'type', 'vlan', 'id', $tag;
+ run_command($cmd);
+ };
+ die "can't add vlan tag $tag to interface $iface - $@\n" if $@;
# remove ipv6 link-local address before activation
disable_ipv6($ifacevlan);
# 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;
+}
- return $cidr_obj->overlaps($ip_obj) == $Net::IP::IP_B_IN_A_OVERLAP;
+# 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 $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 {
sub get_ip_from_hostname {
my ($hostname, $noerr) = @_;
- my ($family, $ip);
-
- eval {
- my @res = PVE::Tools::getaddrinfo_all($hostname);
- $family = $res[0]->{family};
- $ip = addr_to_ip($res[0]->{addr})
- };
+ my @res = eval { PVE::Tools::getaddrinfo_all($hostname) };
if ($@) {
die "hostname lookup '$hostname' failed - $@" if !$noerr;
- return undef;
+ return;
}
- if ($ip =~ m/^127\.|^::1$/) {
- die "hostname lookup '$hostname' failed - got local IP address '$ip'\n" if !$noerr;
- return undef;
+ for my $ai (@res) {
+ my $ip = addr_to_ip($ai->{addr});
+ if ($ip !~ m/^127\.|^::1$/) {
+ return wantarray ? ($ip, $ai->{family}) : $ip;
+ }
}
-
- 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 Cwd qw();
+use IO::File;
+use List::Util qw(sum);
use POSIX;
+use Socket qw(PF_INET PF_INET6 SOCK_DGRAM IPPROTO_IP);
use Time::HiRes qw (gettimeofday);
-use IO::File;
-use PVE::Tools;
-use Cwd qw();
-use Socket qw(PF_INET PF_INET6 SOCK_DGRAM IPPROTO_IP);
+use PVE::Tools;
use constant IFF_UP => 1;
use constant IFNAMSIZ => 16;
my $fh = IO::File->new ($fn, "r");
return $res if !$fh;
+ my $cpuid = 0;
my $idhash = {};
my $count = 0;
while (defined(my $line = <$fh>)) {
} elsif ($line =~ m/^flags\s*:\s*(.*)$/) {
$res->{flags} = $1 if !length $res->{flags};
} elsif ($line =~ m/^physical id\s*:\s*(\d+)\s*$/i) {
- $idhash->{$1} = 1;
+ $cpuid = $1;
+ $idhash->{$1} = 1 if not defined($idhash->{$1});
+ } elsif ($line =~ m/^cpu cores\s*:\s*(\d+)\s*$/i) {
+ $idhash->{$cpuid} = $1 if defined($idhash->{$cpuid});
}
}
$res->{sockets} = scalar(keys %$idhash) || 1;
+ $res->{cores} = sum(values %$idhash) || 1;
+
$res->{cpus} = $count;
$fh->close;
return (0, 0, 0, '', '');
}
+# Check if the kernel is at least $major.$minor. Return either just a boolean,
+# or a boolean and the kernel version's major.minor string from /proc/version
+sub check_kernel_release {
+ my ($major, $minor) = @_;
+
+ my ($k_major, $k_minor) = kernel_version();
+
+ my $ok;
+ if (defined($minor)) {
+ $ok = $k_major > $major || ($k_major == $major && $k_minor >= $minor);
+ } else {
+ $ok = $k_major >= $major;
+ }
+
+ return wantarray ? ($ok, "$k_major.$k_minor") : $ok;
+}
+
sub read_loadavg {
my $line = PVE::Tools::file_read_firstline('/proc/loadavg');
return wantarray ? (0, 0, 0) : 0;
}
+sub parse_pressure {
+ my ($path) = @_;
+
+ my $res = {};
+ my $v = qr/\d+\.\d+/;
+ my $fh = IO::File->new($path, "r") or return undef;
+ while (defined (my $line = <$fh>)) {
+ if ($line =~ /^(some|full)\s+avg10\=($v)\s+avg60\=($v)\s+avg300\=($v)\s+total\=(\d+)/) {
+ $res->{$1}->{avg10} = $2;
+ $res->{$1}->{avg60} = $3;
+ $res->{$1}->{avg300} = $4;
+ $res->{$1}->{total} = $4;
+ }
+ }
+ $fh->close;
+ return $res;
+}
+
+sub read_pressure {
+ my $res = {};
+ foreach my $type (qw(cpu memory io)) {
+ my $stats = parse_pressure("/proc/pressure/$type");
+ $res->{$type} = $stats if $stats;
+ }
+ return $res;
+}
+
my $last_proc_stat;
sub read_proc_stat {
- my $res = { user => 0, nice => 0, system => 0, idle => 0 , sum => 0};
+ my $res = { user => 0, nice => 0, system => 0, idle => 0 , iowait => 0, irq => 0, softirq => 0, steal => 0, guest => 0, guest_nice => 0, sum => 0};
my $cpucount = 0;
if (my $fh = IO::File->new ("/proc/stat", "r")) {
while (defined (my $line = <$fh>)) {
- if ($line =~ m|^cpu\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s|) {
- $res->{user} = $1;
- $res->{nice} = $2;
+ if ($line =~ m|^cpu\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)(?:\s+(\d+)\s+(\d+))?|) {
+ $res->{user} = $1 - ($9 // 0);
+ $res->{nice} = $2 - ($10 // 0);
$res->{system} = $3;
$res->{idle} = $4;
- $res->{used} = $1+$2+$3;
+ $res->{used} = $1+$2+$3+$6+$7+$8;
$res->{iowait} = $5;
+ $res->{irq} = $6;
+ $res->{softirq} = $7;
+ $res->{steal} = $8;
+ $res->{guest} = $9 // 0;
+ $res->{guest_nice} = $10 // 0;
} elsif ($line =~ m|^cpu\d+\s|) {
$cpucount++;
}
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");
$res->{swapfree} = $d->{swapfree};
$res->{swapused} = $res->{swaptotal} - $res->{swapfree};
- my $spages = PVE::Tools::file_read_firstline("/sys/kernel/mm/ksm/pages_sharing");
+ 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 {
$errprefix = "register method ${self}/$info->{path} -";
$info->{method} = 'GET' if !$info->{method};
$method = $info->{method};
+
+ # apply default value
+ $info->{allowtoken} = 1 if !defined($info->{allowtoken});
}
$method_path_lookup->{$self} = {} if !defined($method_path_lookup->{$self});
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 $schema = $info->{parameters};
my $name = $info->{name};
- my $prop = { %{$schema->{properties}} }; # copy
+ my $prop = {};
+ if ($schema->{properties}) {
+ $prop = { %{$schema->{properties}} }; # copy
+ }
my $has_output_format_option = $formatter_properties->{'output-format'} ? 1 : 0;
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 strict;
use warnings;
+use Carp;
use Digest::SHA;
use PVE::Exception qw(raise_param_exc);
use PVE::JSONSchema qw(get_standard_option);
+use PVE::Tools;
+
+# This package provides a way to have multiple (often similar) types of entries
+# in the same config file, each in its own section, thus "Section Config".
+#
+# The intended structure is to have a single 'base' plugin that inherits from
+# this class and provides meaningful defaults in its '$defaultData', e.g. a
+# default list of the core properties in its propertyList (most often only 'id'
+# and 'type')
+#
+# Each 'real' plugin then has it's own package that should inherit from the
+# 'base' plugin and returns it's specific properties in the 'properties' method,
+# its type in the 'type' method and all the known options, from both parent and
+# itself, in the 'options' method.
+# The options method can also be used to define if a property is 'optional' or
+# 'fixed' (only settable on config entity-creation), for example:
+#
+# ````
+# sub options {
+# return {
+# 'some-optional-property' => { optional => 1 },
+# 'a-fixed-property' => { fixed => 1 },
+# 'a-required-but-not-fixed-property' => {},
+# };
+# }
+# ```
+#
+# 'fixed' options can be set on create, but not changed afterwards.
+#
+# To actually use it, you have to first register all the plugins and then init
+# the 'base' plugin, like so:
+#
+# ```
+# use PVE::Dummy::Plugin1;
+# use PVE::Dummy::Plugin2;
+# use PVE::Dummy::BasePlugin;
+#
+# PVE::Dummy::Plugin1->register();
+# PVE::Dummy::Plugin2->register();
+# PVE::Dummy::BasePlugin->init();
+# ```
+#
+# There are two modes for how properties are exposed, the default 'unified'
+# mode and the 'isolated' mode.
+# In the default unified mode, there is only a global list of properties
+# which the plugins can use, so you cannot define the same property name twice
+# in different plugins. The reason for this is to force the use of identical
+# properties for multiple plugins.
+#
+# The second way is to use the 'isolated' mode, which can be achieved by
+# calling init with `1` as its parameter like this:
+#
+# ```
+# PVE::Dummy::BasePlugin->init(property_isolation => 1);
+# ```
+#
+# With this, each plugin get's their own isolated list of properties which it
+# can use. Note that in this mode, you only have to specify the property in the
+# options method when it is either 'fixed' or comes from the global list of
+# properties. All locally defined ones get automatically added to the schema
+# for that plugin.
my $defaultData = {
options => {},
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;
+
+ $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);
+ }
+ }
- foreach my $t (keys %$plugins) {
- my $opts = $pdata->{options}->{$t} || {};
- next if !defined($opts->{$p});
- $modifyable = 1 if !$opts->{$p}->{fixed};
+ 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;
}
sub lookup {
my ($class, $type) = @_;
+ croak "cannot lookup undefined type!" if !defined($type);
+
my $pdata = $class->private();
my $plugin = $pdata->{plugins}->{$type};
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) = @_;
+
+ # NOTE: this is not complete, but enough for our needs. normally all
+ # characters which are not alpha-numerical, '.' or '_' would need escaping
+ $val =~ s/\-/\\x2d/g;
+
+ if ($is_path) {
+ $val =~ s/^\///g;
+ $val =~ s/\/$//g;
+ }
+ $val =~ s/\//-/g;
+
+ return $val;
+}
+
+sub unescape_unit {
+ my ($val) = @_;
+
+ $val =~ s/-/\//g;
+ $val =~ s/\\x([a-fA-F0-9]{2})/chr(hex($1))/eg;
+
+ return $val;
+}
+
# $code should take the parameters ($interface, $reactor, $finish_callback).
#
# $finish_callback can be used by dbus-signal-handlers to stop the reactor.
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 URI::Escape;
+use base 'Exporter';
+
use PVE::Syscall;
# avoid warning when parsing long hex values with hex()
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,
CLONE_NEWNET => 0x40000000};
use constant {O_PATH => 0x00200000,
- O_TMPFILE => 0x00410000}; # This includes O_DIRECTORY
+ O_CLOEXEC => 0x00080000,
+ 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;
sub safe_read_from {
my ($fh, $max, $oneline, $filename) = @_;
- $max = 32768 if !$max;
+ # pmxcfs file size limit
+ $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);
if ($h eq $reader) {
if ($outfunc || $logfunc) {
eval {
- $outlog .= $buf;
- while ($outlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
- my $line = $1;
+ while ($buf =~ s/^([^\010\r\n]*)(?:\n|(?:\010)+|\r\n?)//) {
+ my $line = $outlog . $1;
+ $outlog = '';
&$outfunc($line) if $outfunc;
&$logfunc($line) if $logfunc;
}
+ $outlog .= $buf;
};
my $err = $@;
if ($err) {
} elsif ($h eq $error) {
if ($errfunc || $logfunc) {
eval {
- $errlog .= $buf;
- while ($errlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
- my $line = $1;
+ while ($buf =~ s/^([^\010\r\n]*)(?:\n|(?:\010)+|\r\n?)//) {
+ my $line = $errlog . $1;
+ $errlog = '';
&$errfunc($line) if $errfunc;
&$logfunc($line) if $logfunc;
}
+ $errlog .= $buf;
};
my $err = $@;
if ($err) {
}
}
- 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) = @_;
return next_unused_port(5900, 6000, $family, $address);
}
+sub spice_port_range {
+ return (61000, 61999);
+}
+
sub next_spice_port {
my ($family, $address) = @_;
- return next_unused_port(61000, 61099, $family, $address);
+ return next_unused_port(spice_port_range(), $family, $address);
}
sub must_stringify {
$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;
-
- my $fh = IO::File->new($filename, "r");
- if (!$fh) {
- $count++;
- push @$lines, { n => $count, t => "unable to open file - $!"};
- return ($count, $lines);
- }
+sub dump_logfile_by_filehandle {
+ my ($fh, $filter, $state) = @_;
- $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 {
my ($path) = @_;
- sysopen my $fd, $path, O_PATH or die "failed to open $path: $!\n";
- my $result = syncfs(fileno($fd));
+ sysopen my $fd, $path, O_RDONLY|O_CLOEXEC or die "failed to open $path: $!\n";
+ my $syncfs_err;
+ if (!syncfs(fileno($fd))) {
+ $syncfs_err = "$!";
+ }
close($fd);
- return $result;
+ 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';
- $author = $author || 'Proxmox VE';
+ open (my $mail, "|-", "sendmail", "-B", "8BITMIME", "-f", $from_quoted, "--", $to_quoted->@*)
+ or die "unable to open 'sendmail' - $!";
- open (MAIL, "|-", "sendmail", "-B", "8BITMIME", "-f", $mailfrom, @$mailto) ||
- 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:]]/;
- print MAIL "Content-Type: multipart/alternative;\n";
- print MAIL "\tboundary=\"$boundary\"\n";
- print MAIL "MIME-Version: 1.0\n";
+ print $mail "MIME-Version: 1.0\n" if $subject =~ /[^[:ascii:]]/ || $is_multipart;
- print MAIL "FROM: $author <$mailfrom>\n";
- print MAIL "TO: $rcvrtxt\n";
- print MAIL "SUBJECT: $subject\n";
- print MAIL "\n";
- print MAIL "This is a multi-part message in MIME format.\n\n";
- print MAIL "--$boundary\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";
+ }
if (defined($text)) {
- print MAIL "Content-Type: text/plain;\n";
- print MAIL "\tcharset=\"UTF8\"\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";
+ print $mail "\n--$boundary\n" if $is_multipart;
}
if (defined($html)) {
- print MAIL "Content-Type: text/html;\n";
- print MAIL "\tcharset=\"UTF8\"\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";
+ 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 0 if !defined($left) && !defined($right);
+ return -1 if !defined($left);
+ return 1 if !defined($right);
+ 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 Carp;
use POSIX;
use IO::Handle;
+use Storable qw(dclone);
+use JSON; # allows simple debug-dumping of variables `print to_json($foo, {pretty => 1}) ."\n"`
use PVE::INotify;
# Turn the current network config into a string.
sub w() {
- return PVE::INotify::__write_etc_network_interfaces($config);
+ # 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, 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;
-my $ip = '10.0.0.2';
-my $nm = '255.255.255.0';
+my $ip = '10.0.0.2/24';
my $gw = '10.0.0.1';
-my $ip6 = 'fc05::1:2';
-my $nm6 = '112';
+my $ip6 = 'fc05::1:2/112';
my $gw6 = 'fc05::1:1';
r(load('base'));
update_iface('vmbr0',
[ { family => 'inet',
address => $ip,
- netmask => $nm,
gateway => $gw } ],
autostart => 0);
expect load('base') . <<"EOF";
iface vmbr0 inet static
- address $ip
- netmask $nm
- gateway $gw
+ address $ip
+ gateway $gw
bridge-ports eth0
bridge-stp off
bridge-fd 0
update_iface('vmbr0',
[ { family => 'inet6',
address => $ip6,
- netmask => $nm6,
gateway => $gw6 } ]);
expect load('with-ipv4') . <<"EOF";
iface vmbr0 inet6 static
- address $ip6
- netmask $nm6
- gateway $gw6
+ address $ip6
+ gateway $gw6
EOF
# bridge ports must now appear in the inet6 block
expect load('base') . <<"EOF";
iface vmbr0 inet6 static
- address $ip6
- netmask $nm6
- gateway $gw6
+ address $ip6
+ gateway $gw6
bridge-ports eth0
bridge-stp off
bridge-fd 0
+++ /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;
eth1:
eth2:
eth3:
+eth4:
+eth5:
/proc/net/dev
r(load('brbase'));
# Variables used for the various interfaces:
#
-my $ip = '192.168.0.2';
-my $nm = '255.255.255.0';
+my $ip = '192.168.0.2/24';
my $gw = '192.168.0.1';
my $svcnodeip = '239.192.105.237';
my $physdev = 'eth0';
my $vmbr0_part = <<"PART";
auto vmbr0
iface vmbr0 inet static
- address 10.0.0.2
- netmask 255.255.255.0
- gateway 10.0.0.1
+ address 10.0.0.2/24
+ gateway 10.0.0.1
bridge-ports eth0
bridge-stp off
bridge-fd 0
type => 'eth',
method => 'static',
address => $ip,
- netmask => $nm,
gateway => $gw,
families => ['inet'],
autostart => 1
my $eth1_part = <<"PART";
auto eth1
iface eth1 inet static
- address $ip
- netmask $nm
- gateway $gw
+ address $ip
+ gateway $gw
PART
chomp $eth1_part;
iface eth3 inet manual
+iface eth4 inet manual
+
+iface eth5 inet manual
+
$vmbr0_part
CHECK
$eth1_part
+auto eth2
iface eth2 inet manual
+auto eth3
iface eth3 inet manual
+iface eth4 inet manual
+
+iface eth5 inet manual
+
$bond0_part
$vmbr0_part
$eth1_part
+auto eth2
iface eth2 inet manual
+auto eth3
iface eth3 inet manual
+iface eth4 inet manual
+
+iface eth5 inet manual
+
$bond0_part
$vmbr0_part
families => ['inet'],
bridge_stp => 'off',
bridge_fd => 0,
- bridge_ports => 'vxlan3.50',
+ bridge_ports => 'vxlan3',
bridge_vlan_aware => 'yes',
bridge_vids => '2-10',
autostart => 1
auto vmbr3
iface vmbr3 inet manual
- bridge-ports vxlan3.50
+ bridge-ports vxlan3
bridge-stp off
bridge-fd 0
bridge-vlan-aware yes
$eth1_part
+auto eth2
iface eth2 inet manual
+auto eth3
iface eth3 inet manual
+iface eth4 inet manual
+
+iface eth5 inet manual
+
$bond0_part
$vmbr0_part
autostart => 1
};
+$config->{ifaces}->{'vmbr4'} = {
+ mtu => 1200,
+ type => 'bridge',
+ method => 'manual',
+ families => ['inet'],
+ bridge_stp => 'off',
+ bridge_fd => 0,
+ bridge_ports => 'bond0.100',
+ autostart => 1
+};
+
+$config->{ifaces}->{'vmbr5'} = {
+ mtu => 1100,
+ type => 'bridge',
+ method => 'manual',
+ families => ['inet'],
+ bridge_stp => 'off',
+ bridge_fd => 0,
+ bridge_ports => 'vmbr4.99',
+ autostart => 1
+};
+
+$config->{ifaces}->{vmbr6} = {
+ ovs_mtu => 1400,
+ type => 'OVSBridge',
+ ovs_ports => 'bond1 ovsintvlan',
+ method => 'manual',
+ families => ['inet'],
+ autostart => 1
+};
+
+$config->{ifaces}->{bond1} = {
+ ovs_mtu => 1300,
+ type => 'OVSBond',
+ ovs_bridge => 'vmbr6',
+ ovs_bonds => 'eth4 eth5',
+ ovs_options => 'bond_mode=active-backup',
+ method => 'manual',
+ families => ['inet'],
+ autostart => 1
+};
+
+$config->{ifaces}->{ovsintvlan} = {
+ ovs_mtu => 1300,
+ type => 'OVSIntPort',
+ ovs_bridge => 'vmbr6',
+ ovs_options => 'tag=14',
+ method => 'manual',
+ families => ['inet'],
+ autostart => 1
+};
+
expect load('loopback') . <<"CHECK";
source-directory interfaces.d
$eth1_part
+auto eth2
iface eth2 inet manual
+auto eth3
iface eth3 inet manual
+auto eth4
+iface eth4 inet manual
+
+auto eth5
+iface eth5 inet manual
+
auto eth1.100
iface eth1.100 inet manual
mtu 1400
+auto ovsintvlan
+iface ovsintvlan inet manual
+ ovs_type OVSIntPort
+ ovs_bridge vmbr6
+ ovs_mtu 1300
+ ovs_options tag=14
+
$bond0_part
+auto bond1
+iface bond1 inet manual
+ ovs_bonds eth4 eth5
+ ovs_type OVSBond
+ ovs_bridge vmbr6
+ ovs_mtu 1300
+ ovs_options bond_mode=active-backup
+
auto bond0.100
iface bond0.100 inet manual
mtu 1300
$vmbr123_part
+auto vmbr4
+iface vmbr4 inet manual
+ bridge-ports bond0.100
+ bridge-stp off
+ bridge-fd 0
+ mtu 1200
+
+auto vmbr5
+iface vmbr5 inet manual
+ bridge-ports vmbr4.99
+ bridge-stp off
+ bridge-fd 0
+ mtu 1100
+
+auto vmbr6
+iface vmbr6 inet manual
+ ovs_type OVSBridge
+ ovs_ports bond1 ovsintvlan
+ ovs_mtu 1400
+
auto vmbr1.100
iface vmbr1.100 inet manual
mtu 1300
auto eth1
iface eth1 inet6 static
- address $ip
- netmask $nm
- gateway $gw
+ address $ip/$nm
+ gateway $gw
iface eth2 inet manual
iface eth3 inet manual
+iface eth4 inet manual
+
+iface eth5 inet manual
+
auto vmbr0
iface vmbr0 inet static
- address 10.0.0.2
- netmask 255.255.255.0
- gateway 10.0.0.1
+ address 10.0.0.2/24
+ gateway 10.0.0.1
bridge-ports eth0
bridge-stp off
bridge-fd 0
--- /dev/null
+my $ip = '10.0.0.2/24';
+my $gw = '10.0.0.1';
+my $ip6 = 'fc05::1:2/112';
+my $gw6 = 'fc05::1:1';
+
+r(load('base') . <<"EOF");
+auto vmbr1
+iface vmbr1
+ address 1.2.3.4/24
+ address fccc::a:1/64
+ gateway 1.2.3.1
+ gateway fccc::1
+ bridge-ports eth0
+ bridge-stp off
+ bridge-fd 0
+# Comment
+
+EOF
+
+my $run = 'first';
+my $ifaces = $config->{ifaces};
+
+my $ck = sub {
+ my ($i, $v, $e) = @_;
+ $ifaces->{$i}->{$v} eq $e
+ or die "$run run: $i variable $v: got \"$ifaces->{$i}->{$v}\", expected: $e\n";
+};
+
+my $check_config = sub {
+ $ck->('vmbr1', type => 'bridge');
+ $ck->('vmbr1', cidr => '1.2.3.4/24');
+ $ck->('vmbr1', gateway => '1.2.3.1');
+ $ck->('vmbr1', cidr6 => 'fccc::a:1/64');
+ $ck->('vmbr1', gateway6 => 'fccc::1');
+};
+
+$check_config->();
+
+# idempotency
+save('idem', w());
+r(load('idem'));
+expect load('idem');
+
+$run = 'second';
+$check_config->();
+
+1;
/proc/net/dev
my %wanted = (
- vmbr0 => { address => '192.168.1.2',
- netmask => '255.255.255.0',
- gateway => '192.168.1.1',
- address6 => 'fc05::1:1',
- netmask6 => '112' },
- vmbr1 => { address => '10.0.0.5',
- netmask => '255.255.255.0' }
+ vmbr0 => {
+ address => '192.168.1.2',
+ netmask => '24',
+ cidr => '192.168.1.2/24',
+ gateway => '192.168.1.1',
+ address6 => 'fc05::1:1',
+ netmask6 => '112',
+ cidr6 => 'fc05::1:1/112',
+ },
+ vmbr1 => {
+ address => '10.0.0.5',
+ netmask => '24',
+ cidr => '10.0.0.5/24',
+ },
+ eth2 => {
+ address => '172.16.0.1',
+ netmask => '24',
+ cidr => '172.16.0.1/24',
+ address6 => 'fc05::1:2',
+ netmask6 => '112',
+ cidr6 => 'fc05::1:2/112',
+ },
);
save('interfaces', <<"/etc/network/interfaces");
iface eth0 inet manual
+iface eth2 inet static
+ address $wanted{eth2}->{cidr}
+
+iface eth2 inet6 static
+ address $wanted{eth2}->{cidr6}
+
allow-vmbr1 eth100
iface eth100 inet manual
ovs_type OVSPort
use strict;
-my $ip = '192.168.0.100';
-my $nm = '255.255.255.0';
+my $ip = '192.168.0.100/24';
my $gw = '192.168.0.1';
# replace proc_net_dev with one with a bunch of interfaces
new_iface('vmbr0', 'OVSBridge',
[ { family => 'inet',
address => $ip,
- netmask => $nm,
gateway => $gw } ],
autostart => 1);
iface eth3 inet manual
-allow-ovs vmbr0
+auto vmbr0
iface vmbr0 inet static
- address $ip
- netmask $nm
- gateway $gw
+ address $ip
+ gateway $gw
ovs_type OVSBridge
/etc/network/interfaces
auto eth0
iface eth0 inet manual
-allow-vmbr0 eth1
+auto eth1
iface eth1 inet manual
ovs_type OVSPort
ovs_bridge vmbr0
-allow-vmbr0 eth2
+auto eth2
iface eth2 inet manual
ovs_type OVSPort
ovs_bridge vmbr0
iface eth3 inet manual
-allow-ovs vmbr0
+auto vmbr0
iface vmbr0 inet static
- address $ip
- netmask $nm
- gateway $gw
+ address $ip
+ gateway $gw
ovs_type OVSBridge
ovs_ports eth1 eth2
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
- netmask $nm
- gateway $gw
+ address $ip
+ gateway $gw
ovs_type OVSBridge
ovs_ports eth1
auto vmbr0
iface vmbr0 inet static
- address 10.0.0.2
- netmask 255.255.255.0
- gateway 10.0.0.1
+ address 10.0.0.2/24
+ gateway 10.0.0.1
bridge-ports eth0
bridge-stp off
bridge-fd 0
sub wanted($) {
my ($ip) = @_;
return $base . <<"IFACES";
+auto eth0
iface eth0 inet manual
+auto eth1
iface eth1 inet manual
+auto eth2
iface eth2 inet manual
+auto eth3
iface eth3 inet manual
+auto eth4
iface eth4 inet manual
+auto eth5
iface eth5 inet manual
iface eth6 inet manual
auto bond1
iface bond1 inet static
- address 10.10.10.$ip
- netmask 255.255.255.0
+ address 10.10.10.$ip/24
bond-slaves eth2 eth3
bond-miimon 100
bond-mode balance-alb
bond-mode balance-alb
# Private networking
-iface vlan3 inet static
- address 0.0.0.0
- netmask 0.0.0.0
- vlan-raw-device bond2
+iface unknown3 inet static
+ address 0.0.0.0
-iface vlan4 inet static
- address 0.0.0.0
- netmask 0.0.0.0
- vlan-raw-device bond2
+iface unknown4 inet static
+ address 0.0.0.0
-iface vlan5 inet static
- address 0.0.0.0
- netmask 0.0.0.0
- vlan-raw-device bond2
+iface unknown5 inet static
+ address 0.0.0.0
auto vmbr0
iface vmbr0 inet static
- address 192.168.100.13
- netmask 255.255.255.0
- gateway 192.168.100.1
+ address 192.168.100.13/24
+ gateway 192.168.100.1
bridge-ports bond0
bridge-stp off
bridge-fd 0
-auto vlan6
-iface vlan6 inet static
- address 10.10.11.13
- netmask 255.255.255.0
- vlan_raw_device bond0
- network 10.10.11.0
+auto unknown6
+iface unknown6 inet static
+ address 10.10.11.13/24
pre-up ifconfig bond0 up
auto vmbr3
iface vmbr3 inet manual
- bridge-ports vlan3
+ bridge-ports unknown3
bridge-stp off
bridge-fd 0
- pre-up ifup vlan3
+ pre-up ifup unknown3
auto vmbr4
iface vmbr4 inet manual
- bridge-ports vlan4
+ bridge-ports unknown4
bridge-stp off
bridge-fd 0
- pre-up ifup vlan4
+ pre-up ifup unknown4
auto vmbr5
iface vmbr5 inet manual
- bridge-ports vlan5
+ bridge-ports unknown5
bridge-stp off
bridge-fd 0
- pre-up ifup vlan5
+ pre-up ifup unknown5
IFACES
}
r(wanted(13));
-update_iface('bond1', [ { family => 'inet', address => '10.10.10.11' } ]);
+update_iface('bond1', [ { family => 'inet', address => '10.10.10.11/24' } ]);
expect wanted(11);
1;
eth1:
/proc/net/dev
-my $ip = '192.168.0.2';
-my $nm = '255.255.255.0';
+my $ip = '192.168.0.2/24';
my $gw = '192.168.0.1';
-my $ip6 = 'fc05::2';
-my $nm6 = '112';
+my $ip6 = 'fc05::2/112';
my $gw6 = 'fc05::1';
# Load
type => 'eth',
method => 'static',
address => $ip,
- netmask => $nm,
gateway => $gw,
families => ['inet'],
autostart => 1
auto eth1
iface eth1 inet static
- address $ip
- netmask $nm
- gateway $gw
+ address $ip
+ gateway $gw
auto vmbr0
iface vmbr0 inet static
- address 10.0.0.2
- netmask 255.255.255.0
- gateway 10.0.0.1
+ address 10.0.0.2/24
+ gateway 10.0.0.1
bridge-ports eth0
bridge-stp off
bridge-fd 0
auto eth1
iface eth1 inet static
- address $ip
- netmask $nm
- gateway $gw
+ address $ip
+ gateway $gw
iface eth1 inet6 static
- address $ip6
- netmask $nm6
- gateway $gw6
+ address $ip6
+ gateway $gw6
auto vmbr0
iface vmbr0 inet static
- address 10.0.0.2
- netmask 255.255.255.0
- gateway 10.0.0.1
+ address 10.0.0.2/24
+ gateway 10.0.0.1
bridge-ports eth0
bridge-stp off
bridge-fd 0
--- /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;