-VERSION=6.0
-PKGREL=1
+include /usr/share/dpkg/pkg-info.mk
PACKAGE=libpve-common-perl
ARCH=all
-BUILDDIR ?= ${PACKAGE}-${VERSION}
+BUILDDIR ?= $(PACKAGE)-$(DEB_VERSION_UPSTREAM)
-DEB=${PACKAGE}_${VERSION}-${PKGREL}_${ARCH}.deb
-DSC=${PACKAGE}_${VERSION}-${PKGREL}.dsc
-TARGZ=${PACKAGE}_${VERSION}-${PKGREL}.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
= Install build prerequisites for development environment =
-NOTE: this is a huge list intended to be able to build (almost) all packages,
-from the UI/API components to backend components to our Linux Kernel.
-If you only want to hack on specific topics you won't need most of those.
-We try to have a complete list of build dependencies in each source
-repositories 'debian/control' file. If you run `make deb` dpkg-buildpackage will
-stop and tell you if you miss some required packages.
+NOTE: this is a huge and probably outdated list intended to be able to build
+(almost) all packages, from the UI/API components to backend components to our
+Linux Kernel. If you only want to hack on specific topics you won't need most
+of those.
+Instead we try to have a complete list of build dependencies in each source
+repositories 'debian/control' file. If you run `make deb` dpkg-buildpackage
+will stop and tell you if you miss some required packages.
12. For installing the most important, always needed, ones run:
Additionally, for quickly installing (almost) all build dependencies run:
+WARNING: this list is almost for sure outdated! Use the build-deps definitions
+defined in each package! You could install `devscripts` (huge package, but nice
+helpers) and use:
+# mk-build-deps --install
+in the top-level directory of a git repository.
+
apt-get install autotools-dev autogen dh-autoreconf dkms doxygen check pkg-config \
groff quilt dpatch automake autoconf libtool lintian libdevel-cycle-perl \
libjson-perl libcommon-sense-perl liblinux-inotify2-perl libio-stringy-perl \
python-pyparsing libfilesys-df-perl libcrypt-ssleay-perl \
libfile-readbackwards-perl libanyevent-perl libanyevent-http-perl \
unzip liblocale-po-perl libfile-sync-perl cstream \
-lzop dtach apt-transport-https hdparm gdisk parted ttf-dejavu-core \
-liblzma-dev dosfstools mtools libxen-dev libfuse-dev corosync-dev \
-libcpg-dev libquorum-dev libcmap-dev libuuid-perl \
-libqb-dev libapparmor-dev docbook2x libcap-dev dh-apparmor \
-graphviz libseccomp-dev libglib-perl libgtk3-perl libnss3-dev libdlm-dev \
-libudev-dev asciidoc-dblatex source-highlight libiscsi-dev libiscsi7 \
-librsvg2-bin libarchive-dev libgpgme-dev libcurl4-gnutls-dev \
+lzop dtach hdparm gdisk parted ttf-dejavu-core \
+liblzma-dev dosfstools mtools libxen-dev libfuse-dev libcpg-dev libquorum-dev \
+libcmap-dev libuuid-perl libqb-dev libapparmor-dev docbook2x libcap-dev \
+dh-apparmor graphviz libseccomp-dev libglib-perl libgtk3-perl libnss3-dev \
+libdlm-dev libudev-dev asciidoc-dblatex source-highlight libiscsi-dev \
+libiscsi7 librsvg2-bin libarchive-dev libgpgme-dev libcurl4-gnutls-dev \
libtest-mockmodule-perl libjemalloc-dev libjpeg-dev
+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
+
+ * INotify: allow vlan tagged bridge interface on non-vlanaware bridge
+
+ * INotify: forbid ip address on bridged interface.
+
+ * generate_csr: allow to set CN explicitly
+
+ -- Proxmox Support Team <support@proxmox.com> Mon, 13 Jan 2020 17:51:58 +0100
+
+libpve-common-perl (6.0-9) pve pmg; urgency=medium
+
+ * add kernel_version helper to ProcFSTools
+
+ -- Proxmox Support Team <support@proxmox.com> Sat, 23 Nov 2019 16:15:10 +0100
+
+libpve-common-perl (6.0-8) pve pmg; urgency=medium
+
+ * fix Tools::df for big storage usage values
+
+ * ProcFSTools: include ppid in read_proc_pid_stat
+
+ * add new Kernel mount API wrappers and constants
+
+ * ysFSTools: do not assume PCI domain 0000
+
+ -- Proxmox Support Team <support@proxmox.com> Wed, 20 Nov 2019 18:43:05 +0100
+
+libpve-common-perl (6.0-7) pve pmg; urgency=medium
+
+ * cert: add fingerprint helper
+
+ * JSONSchema: add pve-tag format
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 08 Nov 2019 12:48:29 +0100
+
+libpve-common-perl (6.0-6) pve pmg; urgency=medium
+
+ * fix #2433: add new TFA-secret format and support longer secrets
+
+ -- Proxmox Support Team <support@proxmox.com> Tue, 29 Oct 2019 08:07:29 +0100
+
+libpve-common-perl (6.0-5) pve pmg; urgency=medium
+
+ * fix #2339: Handle multiple blank lines correctly in SectionConfig
+
+ * add postinst hook to fix /etc/aliases whitespace error~
+
+ * network: add uplink-id option
+
+ * network: use 'allow-ovs' instead of 'auto' for OVSBridge to fix race
+ with the then generated systemd ifup@.service on startup
+
+ * network: handle autostart setting for OVS interfaces
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 20 Sep 2019 16:38:39 +0200
+
+libpve-common-perl (6.0-4) pve pmg; urgency=medium
+
+ * fix #2303: detect IPs of p2p interfaces
+
+ * CLIHandler: consider all valid prefixes again for completion
+
+ * Tools: add fchownat syscall
+
+ -- Proxmox Support Team <support@proxmox.com> Sat, 17 Aug 2019 11:31:24 +0200
+
+libpve-common-perl (6.0-3) pve pmg; urgency=medium
+
+ * cert: add public key type and size to info and JSON schema
+
+ * include all available CPU flags in read_cpuinfo
+
+ * add array_intersect method
+
+ -- Proxmox Support Team <support@proxmox.com> Tue, 23 Jul 2019 09:14:58 +0200
+
+libpve-common-perl (6.0-2) pve pmg; urgency=medium
+
+ * systemd: add wait_for_unit_removed helper
+
+ * add fallback for CSRF token recognition
+
+ * use hmac_sha256 when assembling CSRF token
+
+ -- Proxmox Support Team <support@proxmox.com> Mon, 24 Jun 2019 17:16:28 +0200
+
libpve-common-perl (6.0-1) pve pmg; urgency=medium
* print defaulttxt as sprintf parameter
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 (<< 1.0-93),
- 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>
--- /dev/null
+#!/bin/sh
+
+set -e
+
+#DEBHELPER#
+
+case "$1" in
+ configure)
+ if test -n "$2"; then
+
+ # TODO: remove once PVE 7.0 is released
+ 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
+ ;;
+
+esac
+
+exit 0
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 = encode(tojs($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 to order URL
-# Expects a '200 OK' reply
-# returns order object
-sub get_order {
- my ($self, $order_url) = @_;
- my $r = $self->do(GET => $order_url);
- my $return = eval { __get_result($r, 200); };
- $self->fatal("GET of '$order_url' failed - $@", $r) if $@;
- return $return;
-}
-
-# Gets authorization object
-# GET 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(GET => $auth_url);
- my $return = eval { __get_result($r, 200); };
- $self->fatal("GET 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 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(GET => $order->{certificate});
- my $return = eval { __get_result($r, 200, 1); };
- $self->fatal("GET 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 $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_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) . "-+";
+ $border->{m} .= "+-" . ('-' x $cutoff) . "-+";
+ $border->{h} .= "+=" . ('=' x $cutoff) . '=';
}
} elsif ($i == 0) {
if ($utf8) {
$formatstring .= "│ %$alignstr${cutoff}s ";
- $borderstring_t .= "┌─" . ('─' 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) . '-';
+ $border->{m} .= "+-" . ('-' x $cutoff) . '-';
+ $border->{h} .= "+=" . ('=' x $cutoff) . '=';
}
} elsif ($i == ($column_count - 1)) {
if ($utf8) {
$formatstring .= "│ %$alignstr${cutoff}s │";
- $borderstring_t .= "┬─" . ('─' 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) . "-+";
+ $border->{m} .= "+-" . ('-' x $cutoff) . "-+";
+ $border->{h} .= "+=" . ('=' x $cutoff) . "=+";
}
} else {
if ($utf8) {
$formatstring .= "│ %$alignstr${cutoff}s ";
- $borderstring_t .= "┬─" . ('─' 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) . '-';
+ $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;
- if ($header) {
+ if ($show_header) {
my $text = sprintf $formatstring, map { $colopts->{$_}->{title} } @$props_to_print;
$writeln->($text);
+ $border->{sep} = $border->{h};
+ } else {
+ $border->{sep} = $border->{m};
}
for (my $i = 0; $i < scalar(@$tabledata); $i++) {
my $coldata = $tabledata->[$i];
- $writeln->($borderstring_m) if $border && ($i != 0 || $header);
+ 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);
use strict;
use warnings;
+
use JSON;
+use Scalar::Util qw(weaken);
use PVE::SafeSyslog;
use PVE::Exception qw(raise raise_param_exc);
+use PVE::JSONSchema;
use PVE::RESTHandler;
use PVE::PTY;
use PVE::INotify;
};
my $expand_command_name = sub {
- my ($def, $cmd) = @_;
+ my ($def, $cmd, $enforce_exact) = @_;
return $cmd if exists $def->{$cmd}; # command is already complete
my $is_alias = sub { ref($_[0]) eq 'HASH' && exists($_[0]->{alias}) };
my @expanded = grep { /^\Q$cmd\E/ && !$is_alias->($def->{$_}) } keys %$def;
+ return @expanded if !$enforce_exact;
+
return $expanded[0] if scalar(@expanded) == 1; # enforce exact match
return undef;
my $last_arg_id = scalar(@$argv) - 1;
for my $i (0..$last_arg_id) {
- $cmd = $expand_command_name->($def, $argv->[$i]);
+ $cmd = $expand_command_name->($def, $argv->[$i], 1);
if (defined($cmd)) {
# If the argument was expanded (or was already complete) and it
# is the final argument, tell our caller about it:
$expanded_last_arg = $cmd if $i == $last_arg_id;
} else {
# Otherwise continue with the unexpanded version of it.
- $cmd = $argv->[$i];
+ $cmd = $argv->[$i];
}
$cmdstr .= " $cmd";
+ if (!defined($def->{$cmd})) {
+ # $cmd still could be a valid prefix for bash_completion
+ # in that case keep $def as it is, else set it to undef
+ $def = undef if !$expand_command_name->($def, $cmd);
+ last;
+ }
$def = $def->{$cmd};
- last if !defined($def);
if (ref($def) eq 'ARRAY') {
# could expand to a real command, rest of $argv are its arguments
my $param_cb = $gen_param_mapping_func->($cli_handler_class);
my ($subcmd, $def, undef, undef, $cmdstr) = resolve_cmd($cmd);
- $abort->("unknown command '$cmdstr'") if !defined($def) && ref($cmd) eq 'ARRAY';
- my $generate;
- $generate = sub {
+ my $generate_weak;
+ $generate_weak = sub {
my ($indent, $separator, $def, $prefix) = @_;
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 {
next if $def->{$cmd}->{alias};
- my $substr = $generate->($indent, '', $def->{$cmd}, "$prefix $cmd");
+ my $substr = $generate_weak->($indent, '', $def->{$cmd}, "$prefix $cmd");
if ($substr) {
$substr .= $separator if $substr !~ /\Q$separator\E{2}/;
$str .= $substr;
}
} 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);
}
return $str;
};
+ my $generate = $generate_weak;
+ weaken($generate_weak);
return $generate->($indent, $separator, $def, $cmdstr);
}
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;
format => 'pem-certificate',
optional => 1,
},
+ 'public-key-type' => {
+ type => 'string',
+ description => 'Certificate\'s public key algorithm',
+ optional => 1,
+ },
+ 'public-key-bits' => {
+ type => 'integer',
+ description => 'Certificate\'s public key size',
+ optional => 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);
}
+sub get_certificate_fingerprint {
+ my ($cert_path) = @_;
+
+ my $cert = $read_certificate->($cert_path);
+
+ my $fp = Net::SSLeay::X509_get_fingerprint($cert, 'sha256');
+ Net::SSLeay::X509_free($cert);
+
+ die "unable to get fingerprint for '$cert_path' - got empty value\n"
+ if !defined($fp) || $fp eq '';
+
+ 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);
}
$info->{san} = $parse_san->(Net::SSLeay::X509_get_subjectAltNames($cert));
$info->{pem} = Net::SSLeay::PEM_get_string_X509($cert);
+ my $pub_key = eval { Net::SSLeay::X509_get_pubkey($cert) };
+ warn $@ if $@;
+ if ($pub_key) {
+ $info->{'public-key-type'} = Net::SSLeay::OBJ_nid2sn(Net::SSLeay::EVP_PKEY_id($pub_key));
+ $info->{'public-key-bits'} = Net::SSLeay::EVP_PKEY_bits($pub_key);
+ Net::SSLeay::EVP_PKEY_free($pub_key);
+ }
+
Net::SSLeay::X509_free($cert);
$cert_path =~ s!^.*/!!g;
my $san = [ map { $_->{value} } grep { $_->{type} eq 'dns' } @$identifiers ];
die "DNS identifiers are required to generate a CSR.\n" if !scalar @$san;
+ # optional
+ my $common_name = delete($attr{common_name}) // $san->[0];
+
my $md = eval { Net::SSLeay::EVP_get_digestbyname($dig_alg) };
die "Invalid digest algorithm '$dig_alg'\n" if !$md;
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', @$san[0]);
+ $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 $members = $cpuset->{members};
+ my ($count, $members) = parse_cpuset($set_text);
+
+ 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";
my ($self, @members) = @_;
my $count = 0;
-
+
foreach my $cpu (@members) {
next if $self->{members}->{$cpu};
$self->{members}->{$cpu} = 1;
my ($self, @members) = @_;
my $count = 0;
-
+
foreach my $cpu (@members) {
next if !$self->{members}->{$cpu};
delete $self->{members}->{$cpu};
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 ($self) = @_;
foreach my $id (keys %$members2) {
return 0 if !$members1->{$id};
}
-
+
return 1;
}
# * allow to restart while workers are still runningl
# (option 'leave_children_open_on_reload')
# * run as different user using setuid/setgid
-
+
use strict;
use warnings;
use English;
for my $sig (qw(CHLD HUP INT TERM QUIT)) {
$SIG{$sig} = 'DEFAULT'; # restore default handler
- # AnyEvent signals only works if $SIG{XX} is
+ # AnyEvent signals only works if $SIG{XX} is
# undefined (perl event loop)
delete $SIG{$sig}; # so that we can handle events with AnyEvent
}
if (my $fd = $self->{env_pve_lock_fd}) {
$self->{daemon_lock_fh} = IO::Handle->new_from_fd($fd, "a");
-
+
} else {
$waittime = 5;
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) {
syslog('info' , "starting server");
}
- POSIX::setsid();
+ POSIX::setsid();
open STDERR, '>&STDOUT' || die "can't close STDERR\n";
}
};
- eval {
+ eval {
if ($self->{max_workers}) {
my $old_sig_chld = $SIG{CHLD};
local $SIG{CHLD} = sub {
};
# now loop forever (until we receive terminate signal)
- for (;;) {
+ for (;;) {
&$start_workers($self);
sleep(5);
&$terminate_old_workers($self);
} else {
$self->run();
- }
+ }
};
my $err = $@;
eval {
my $class = ref($this) || $this;
- $self = bless {
+ $self = bless {
name => $name,
pidfile => "/var/run/${name}.pid",
workers => {},
die "unknown daemon option '$opt'\n";
}
}
-
+
# untaint
$self->{cmdline} = [map { /^(.*)$/ } @$cmdline];
return 0 if !$pid_str;
return 0 if $pid_str !~ m/^(\d+)$/; # untaint
-
+
my $pid = int($1);
return $pid;
# checks if the process was started by systemd
my $init_ppid = sub {
-
if (getppid() == 1) {
return 1;
} else {
return 0;
}
-};
+};
sub running {
my ($self) = @_;
}
return undef;
- }});
+ }});
}
my $reload_daemon = sub {
if ($self->{env_restart_pve_daemon}) {
$self->start();
} else {
- my ($running, $pid) = $self->running();
+ my ($running, $pid) = $self->running();
if (!$running) {
$self->start();
} else {
}
return undef;
- }});
+ }});
}
sub register_reload_command {
&$reload_daemon($self, 1);
return undef;
- }});
+ }});
}
sub register_stop_command {
code => sub {
my ($param) = @_;
-
+
if (&$init_ppid()) {
$self->stop();
} else {
}
return undef;
- }});
+ }});
}
sub register_status_command {
additionalProperties => 0,
properties => {},
},
- returns => {
+ returns => {
type => 'string',
enum => ['stopped', 'running'],
},
# some useful helper
sub create_reusable_socket {
- my ($self, $port, $host, $family) = @_;
+ my ($self, $port, $host) = @_;
die "no port specifed" if !$port;
if (defined($sockfd = $ENV{"PVE_DAEMON_SOCKET_$port"}) &&
$self->{env_restart_pve_daemon}) {
- die "unable to parse socket fd '$sockfd'\n"
+ die "unable to parse socket fd '$sockfd'\n"
if $sockfd !~ m/^(\d+)$/;
$sockfd = $1; # untaint
$socket = IO::Socket::IP->new;
- $socket->fdopen($sockfd, 'w') ||
+ $socket->fdopen($sockfd, 'w') ||
die "cannot fdopen file descriptor '$sockfd' - $!\n";
$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 {
my ($a, $b) = @_;
- local $@;
+ local $@;
return "$a" cmp "$b"; # compare as string
};
};
foreach my $p (keys %param) {
- next if defined($self->{$p});
+ next if defined($self->{$p});
my $v = $param{$p};
$self->{$p} = ref($v) ? dclone($v) : $v;
}
- return bless $self;
+ return bless $self, $class;
}
sub raise {
my $exc = PVE::Exception->new(@_);
-
+
my ($pkg, $filename, $line) = caller;
$exc->{filename} = $filename;
my $param = { code => HTTP_FORBIDDEN };
my $msg = "Permission check failed";
-
+
$msg .= " ($what)" if $what;
my $exc = PVE::Exception->new("$msg\n", %$param);
-
+
my ($pkg, $filename, $line) = caller;
$exc->{filename} = $filename;
$param->{usage} = $usage if $usage;
my $exc = PVE::Exception->new("Parameter verification failed.\n", %$param);
-
+
my ($pkg, $filename, $line) = caller;
$exc->{filename} = $filename;
sub stringify {
my $self = shift;
-
+
my $msg = $self->{code} ? "$self->{code} $self->{msg}" : $self->{msg};
if ($msg !~ m/\n$/) {
sub PROPAGATE {
my ($self, $file, $line) = @_;
- push @{$self->{propagate}}, [$file, $line];
+ push @{$self->{propagate}}, [$file, $line];
return $self;
}
--- /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;
$cp->{$k} = $v;
}
$ccache->{$filename} = $cp;
- }
+ }
return ($ccache->{$filename}, $filename);
}
}
-
+
$filename = $ccachemap->{$filename} if defined ($ccachemap->{$filename});
die "file '$filename' not added :ERROR" if !defined ($ccache->{$filename});
-
+
return ($ccache->{$filename}, $filename);
}
if (!rename($tmpname, $realname)) {
my $msg = "close (rename) atomic file '$filename' failed: $!\n";
unlink $tmpname;
- die $msg;
+ die $msg;
}
my $diff;
my $code = sub {
$fd = IO::File->new ($filename, "r");
-
+
my $new = &$update($filename, $fd, $data, @args);
if (defined($new)) {
my $parser;
my ($ccinfo, $filename) = ccache_info($fileid);
-
+
$parser = $ccinfo->{parser};
-
+
my $fd;
my $shadow;
if (!$fd) {
$ccinfo->{version} = undef;
- $ccinfo->{data} = undef;
+ $ccinfo->{data} = undef;
$ccinfo->{diff} = undef;
return undef if !$acp;
}
$ret->{data} = $ccinfo->{data};
}
$ret->{changes} = $ccinfo->{diff};
-
+
return $full ? $ret : $ret->{data};
}
$ret->{changes} = $ccinfo->{diff};
return $full ? $ret : $ret->{data};
-}
+}
sub parse_ccache_options {
my ($ccinfo, %options) = @_;
# noclone flag for large read-only data chunks like aplinfo
$ccinfo->{$opt} = $v;
} elsif ($opt eq 'always_call_parser') {
- # when set, we call parser even when the file does not exists.
+ # when set, we call parser even when the file does not exist.
# this allows the parser to return some default
$ccinfo->{$opt} = $v;
} else {
$ccinfo->{update} = $update;
parse_ccache_options($ccinfo, %options);
-
+
if ($options{shadow}) {
$shadowfiles->{$filename} = $options{shadow};
}
my $uid = "$dir/$regex";
die "regular expression '$uid' already added :ERROR" if defined ($ccacheregex->{$uid});
-
+
my $ccinfo = {};
$ccinfo->{dir} = $dir;
foreach my $uid (keys %$ccacheregex) {
my $ccinfo = $ccacheregex->{$uid};
- $dirhash->{$ccinfo->{dir}}->{_regex} = 1;
+ $dirhash->{$ccinfo->{dir}}->{_regex} = 1;
}
$inotify_pid = $$;
syslog ('err', "got 'unmount' event on '$name' - disabling inotify");
$inotify = undef;
}
- if ($e->IN_IGNORED) {
+ if ($e->IN_IGNORED) {
syslog ('err', "got 'ignored' event on '$name' - disabling inotify");
$inotify = undef;
}
next if $dir ne $ccinfo->{dir};
my $re = $ccinfo->{regex};
if (my $fd = IO::Dir->new ($dir)) {
- while (defined(my $de = $fd->read)) {
+ while (defined(my $de = $fd->read)) {
if ($de =~ m/^$re$/) {
my $fn = "$dir/$de";
$versions->{$fn}++; # init with version
}
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;
return $hostname;
}
-register_file('hostname', "/etc/hostname",
- \&read_etc_hostname,
+register_file('hostname', "/etc/hostname",
+ \&read_etc_hostname,
\&write_etc_hostname);
sub read_etc_hosts {
next if $line =~ m/^(search|domain|nameserver)\s+/;
$data .= $line
}
-
+
return $data;
}
-register_file('resolvconf', "/etc/resolv.conf",
- \&read_etc_resolv_conf, undef,
+register_file('resolvconf', "/etc/resolv.conf",
+ \&read_etc_resolv_conf, undef,
\&update_etc_resolv_conf);
sub read_etc_timezone {
}
-register_file('timezone', "/etc/timezone",
- \&read_etc_timezone,
+register_file('timezone', "/etc/timezone",
+ \&read_etc_timezone,
\&write_etc_timezone);
sub read_active_workers {
return [] if !$fh;
- my $res = [];
+ my $res = [];
while (defined (my $line = <$fh>)) {
if ($line =~ m/^(\S+)\s(0|1)(\s([0-9A-Za-z]{8})(\s(\s*\S.*))?)?$/) {
my $upid = $1;
PVE::Tools::safe_print($filename, $fh, $raw) if $raw;
}
-register_file('active', "/var/log/pve/tasks/active",
+register_file('active', "/var/log/pve/tasks/active",
\&read_active_workers,
\&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,
'balance-slb' => 1,
'lacp-balance-slb' => 1,
- 'lacp-balance-tcp' => 1,
+ 'lacp-balance-tcp' => 1,
};
#sub get_bond_modes {
my $options = $config->{options} = [];
my $options_alternatives = {
+ 'ovs_mtu' => 'mtu',
'bond-slaves' => 'slaves',
'bond_slaves' => 'slaves',
'bond-xmit-hash-policy' => 'bond_xmit_hash_policy',
'bridge-fd' => 'bridge_fd',
'bridge-stp' => 'bridge_stp',
'bridge-ports' => 'bridge_ports',
- 'bridge-vids' => 'bridge_vids'
+ 'bridge-vids' => 'bridge_vids',
};
my $line;
}
# we try to keep order inside the file
- my $priority = 2; # 1 is reserved for lo
+ my $priority = 2; # 1 is reserved for lo
SECTION: while (defined ($line = <$fh>)) {
chomp ($line);
next if $line =~ m/^\s*#/;
-
- if ($line =~ m/^\s*auto\s+(.*)$/) {
- my @aa = split (/\s+/, $1);
- foreach my $a (@aa) {
- $ifaces->{$a}->{autostart} = 1;
- }
+ if ($line =~ m/^\s*(allow-auto|auto|allow-ovs)\s+(.*)$/) {
+
+ $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'];
}
# from the {options} hash for them to be removed correctly.
@$options = grep {defined($_)} map {
my ($pri, $line) = @$_;
- if ($line =~ /^allow-(\S+)\s+(.*)$/) {
+ if ($line =~ /^allow-ovs\s+(.*)$/) {
+ undef;
+ } elsif ($line =~ /^allow-(\S+)\s+(.*)$/) {
my $bridge = $1;
my @ports = split(/\s+/, $2);
if (defined(my $br = $ifaces->{$bridge})) {
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";
+ }
- 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 };
+ $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, 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') {
$d->{slaves} =~ s/[;,\s]+/ /g;
$raw .= "\tbond-xmit-hash-policy $d->{'bond_xmit_hash_policy'}\n";
}
$done->{'bond_xmit_hash_policy'} = 1;
+
+ if ($d->{'bond_mode'} && $d->{'bond_mode'} eq 'active-backup' && $d->{'bond-primary'}) {
+ $raw .= "\tbond-primary $d->{'bond-primary'}\n";
+ }
+ $done->{'bond-primary'} = 1;
+
+ $raw .= "\tmtu $d->{mtu}\n" if $d->{mtu};
+ $done->{mtu} = 1;
+
} elsif ($d->{type} eq 'vlan') {
- die "$iface: wrong vlan-protocol $d->{'vlan-protocol'}\n"
+ die "$iface: wrong vlan-protocol $d->{'vlan-protocol'}\n"
if $d->{'vlan-protocol'} && $d->{'vlan-protocol'} ne '802.1ad' && $d->{'vlan-protocol'} ne '802.1q';
-
+
} elsif ($d->{type} eq 'vxlan') {
foreach my $k (qw(vxlan-id vxlan-svcnodeip vxlan-physdev vxlan-local-tunnelip)) {
}
$done->{'vxlan-remoteip'} = 1;
}
+
+ $raw .= "\tmtu $d->{mtu}\n" if $d->{mtu};
+ $done->{mtu} = 1;
+
} elsif ($d->{type} eq 'OVSBridge') {
$raw .= "\tovs_type $d->{type}\n";
$raw .= "\tovs_ports $d->{ovs_ports}\n" if $d->{ovs_ports};
$done->{ovs_ports} = 1;
- } elsif ($d->{type} eq 'OVSPort' || $d->{type} eq 'OVSIntPort' ||
- $d->{type} eq 'OVSBond') {
+
+ $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') {
$d->{autostart} = 0; # started by the bridge
$raw .= "\tovs_type $d->{type}\n";
$done->{ovs_type} = 1;
- if ($d->{ovs_bridge}) {
-
+ if (my $bridge = $d->{ovs_bridge}) {
if ($ifupdown2) {
$raw = "auto $iface\n$raw";
} else {
- $raw = "allow-$d->{ovs_bridge} $iface\n$raw";
+ $raw = "allow-$bridge $iface\n$raw";
}
- $raw .= "\tovs_bridge $d->{ovs_bridge}\n";
+ $raw .= "\tovs_bridge $bridge\n";
$done->{ovs_bridge} = 1;
}
+
+ $raw .= "\tovs_mtu $d->{mtu}\n" if $d->{mtu};
+ $done->{mtu} = 1;
}
if ($first_block) {
}
}
- 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}) {
- 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);
- }
+ 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;
- if ($n->{type} eq 'bridge' && !$n->{bridge_vlan_aware}) {
- die "vlan '$iface' - bridge vlan aware is not enabled on parent '$p'\n";
- } elsif ($n->{type} ne 'eth' && $n->{type} ne 'bridge' && $n->{type} ne 'bond' && $n->{type} ne 'vlan') {
+ if ($n->{type} ne 'eth' && $n->{type} ne 'bridge' && $n->{type} ne 'bond' && $n->{type} ne 'vlan') {
die "vlan '$iface' - wrong interface type on parent '$p' " .
"('$n->{type}' != 'eth|bond|bridge|vlan' )\n";
}
}
}
+ # check uplink
+ my $uplinks = {};
+ foreach my $iface (keys %$ifaces) {
+ my $d = $ifaces->{$iface};
+ if (my $uplinkid = $d->{'uplink-id'}) {
+ die "iface '$iface' - uplink-id $uplinkid is only allowed on physical and linux bond interfaces\n"
+ if $d->{type} ne 'eth' && $d->{type} ne 'bond';
+
+ die "iface '$iface' - uplink-id $uplinkid is already assigned on '$uplinks->{$uplinkid}'\n"
+ if $uplinks->{$uplinkid};
+
+ $uplinks->{$uplinkid} = $iface;
+ }
+ }
+
# 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};
- die "bridge '$iface' - unable to find bridge port '$p'\n"
- if !$n;
- &$check_mtu($ifaces, $iface, $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} && $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 {
return $a cmp $b;
} keys %$ifaces) {
next if $printed->{$iface};
-
my $d = $ifaces->{$iface};
my $pri = $d->{priority} // 0;
if (@options && $options[0]->[0] < $pri) {
}
$printed->{$iface} = 1;
- $raw .= "auto $iface\n" if $d->{autostart};
+ if ($d->{autostart}) {
+ if ($d->{type} eq 'OVSBridge' && !$ifupdown2) {
+ # cannot use 'auto' for OVS, would add race with systemd ifup@.service
+ $raw .= "allow-ovs $iface\n";
+ } else {
+ $raw .= "auto $iface\n";
+ }
+ }
+
+ # 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}};
}
return 'undefined';
}
-register_file('initiatorname', "/etc/iscsi/initiatorname.iscsi",
+register_file('initiatorname', "/etc/iscsi/initiatorname.iscsi",
\&read_iscsi_initiatorname);
-sub read_apt_auth {
- my ($filename, $fd) = @_;
-
- local $/;
-
- my $raw = defined($fd) ? <$fd> : '';
-
- $raw =~ s/^\s+//;
-
-
- my @tokens = split(/\s+/, $raw);
-
- my $data = {};
-
- my $machine;
- while (defined(my $tok = shift @tokens)) {
-
- $machine = shift @tokens if $tok eq 'machine';
- next if !$machine;
- $data->{$machine} = {} if !$data->{$machine};
-
- $data->{$machine}->{login} = shift @tokens if $tok eq 'login';
- $data->{$machine}->{password} = shift @tokens if $tok eq 'password';
- };
-
- return $data;
-}
-
-my $format_apt_auth_data = sub {
- my $data = shift;
-
- my $raw = '';
-
- foreach my $machine (sort keys %$data) {
- my $d = $data->{$machine};
- $raw .= "machine $machine\n";
- $raw .= " login $d->{login}\n" if $d->{login};
- $raw .= " password $d->{password}\n" if $d->{password};
- $raw .= "\n";
- }
-
- return $raw;
-};
-
-sub write_apt_auth {
- my ($filename, $fh, $data) = @_;
-
- my $raw = &$format_apt_auth_data($data);
-
- die "write failed: $!" unless print $fh "$raw\n";
-
- return $data;
-}
-
-sub update_apt_auth {
- my ($filename, $fh, $data) = @_;
-
- my $orig = read_apt_auth($filename, $fh);
-
- foreach my $machine (keys %$data) {
- $orig->{$machine} = $data->{$machine};
- }
-
- return &$format_apt_auth_data($orig);
-}
-
-register_file('apt-auth', "/etc/apt/auth.conf",
- \&read_apt_auth, \&write_apt_auth,
- \&update_apt_auth, perm => 0640);
-
1;
use PVE::Tools qw(split_list $IPV6RE $IPV4RE);
use PVE::Exception qw(raise);
use HTTP::Status qw(:constants);
+use JSON;
use Net::IP qw(:PROC);
use Data::Dumper;
use base 'Exporter';
our @EXPORT_OK = qw(
-register_standard_option
+register_standard_option
get_standard_option
+parse_property_string
+print_property_string
);
-# Note: This class implements something similar to JSON schema, but it is not 100% complete.
+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/
sub register_standard_option {
my ($name, $schema) = @_;
- die "standard option '$name' already registered\n"
+ die "standard option '$name' already registered\n"
if $standard_options->{$name};
$standard_options->{$name} = $schema;
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 = {};
register_format('pve-configid', \&pve_verify_configid);
sub pve_verify_configid {
my ($id, $noerr) = @_;
-
- if ($id !~ m/^[a-z][a-z0-9_]+$/i) {
+
+ if ($id !~ m/^$CONFIGID_RE$/) {
return undef if $noerr;
- die "invalid configuration ID '$id'\n";
+ die "invalid configuration ID '$id'\n";
}
return $id;
}
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 {
my ($id, $noerr) = @_;
-
+
if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
return undef if $noerr;
- die "invalid network interface name '$id'\n";
+ die "invalid network interface name '$id'\n";
}
return $id;
}
register_standard_option('spice-proxy', {
description => "SPICE proxy server. This can be used by the client to specify the proxy server. All nodes in a cluster runs 'spiceproxy', so it is up to the client to choose one. By default, we return the node where the VM is currently running. As reasonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).",
type => 'string', format => 'address',
-});
+});
register_standard_option('remote-viewer-config', {
description => "Returned values can be directly passed to the 'remote-viewer' application.",
};
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/^${PVE_TAG_RE}$/i;
+
+ return undef if $noerr;
+
+ die "invalid characters in tag\n";
+}
+
sub pve_parse_startup_order {
my ($value) = @_;
typetext => '[[order=]\d+] [,up=\d+] [,down=\d+] ',
});
-sub check_format {
- my ($format, $value, $path) = @_;
+register_format('pve-tfa-secret', \&pve_verify_tfa_secret);
+sub pve_verify_tfa_secret {
+ my ($key, $noerr) = @_;
- return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
- return if $format eq 'regex';
+ # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
+ # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
+ # format to support arbitrary lengths properly:
+ if ($key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
+ $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
+ $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/) # and the old pattern copy&pasted
+ {
+ return $key;
+ }
- if ($format =~ m/^(.*)-a?list$/) {
-
- my $code = $format_list->{$1};
+ return undef if $noerr;
- die "undefined format '$format'\n" if !$code;
+ die "unable to decode TFA secret\n";
+}
- # Note: we allow empty lists
- foreach my $v (split_list($value)) {
- &$code($v);
- }
- } elsif ($format =~ m/^(.*)-opt$/) {
+PVE::JSONSchema::register_format('pve-task-status-type', \&verify_task_status_type);
+sub verify_task_status_type {
+ my ($value, $noerr) = @_;
- my $code = $format_list->{$1};
+ return $value if $value =~ m/^(ok|error|warning|unknown)$/i;
- die "undefined format '$format'\n" if !$code;
+ return undef if $noerr;
- return if !$value; # allow empty string
+ die "invalid status '$value'\n";
+}
- &$code($value);
+sub check_format {
+ my ($format, $value, $path) = @_;
- } else {
+ if (ref($format) eq 'HASH') {
+ # hash ref cannot have validator/list/opt handling attached
+ return parse_property_string($format, $value, $path);
+ }
- my $code = $format_list->{$format};
+ if (ref($format) eq 'CODE') {
+ # we are the (sole, old-style) validator
+ return $format->($value);
+ }
- die "undefined format '$format'\n" if !$code;
+ return if $format eq 'regex';
+
+ 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 "'-$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 {
my ($value) = @_;
$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;
}
my ($errors, $path, $msg) = @_;
$path = '_root' if !$path;
-
+
if ($errors->{$path}) {
$errors->{$path} = join ('\n', $errors->{$path}, $msg);
} else {
my $value = shift;
# see 'man perlretut'
- return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
+ return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
}
sub is_integer {
if (!defined($value)) {
return 1 if $type eq 'null';
- die "internal error"
+ die "internal error"
}
if (my $tt = ref($type)) {
foreach my $t (@$type) {
my $tmperr = {};
check_type($path, $t, $value, $tmperr);
- return 1 if !scalar(%$tmperr);
+ return 1 if !scalar(%$tmperr);
}
my $ttext = join ('|', @$type);
- add_error($errors, $path, "type check ('$ttext') failed");
+ add_error($errors, $path, "type check ('$ttext') failed");
return undef;
} elsif ($tt eq 'HASH') {
my $tmperr = {};
check_prop($value, $type, $path, $tmperr);
- return 1 if !scalar(%$tmperr);
- add_error($errors, $path, "type check failed");
+ return 1 if !scalar(%$tmperr);
+ add_error($errors, $path, "type check failed");
return undef;
} else {
die "internal error - got reference type '$tt'";
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;
}
}
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) {
#print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
check_prop($value, $requires, $path, $errors);
} elsif (!defined($value->{$requires})) {
- add_error($errors, $path ? "$path.$requires" : $requires,
+ add_error($errors, $path ? "$path.$requires" : $requires,
"missing property - '$newpath' requires this property");
}
}
- 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;
}
}
}
- return;
+ return;
} elsif ($schema->{properties} || $schema->{additionalProperties}) {
check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
$value, $schema->{additionalProperties}, $errors);
return;
}
}
-
+
if (is_number($value)) {
if (defined (my $max = $schema->{maximum})) {
- if ($value > $max) {
+ if ($value > $max) {
add_error($errors, $path, "value must have a maximum value of $max");
return;
}
}
if (defined (my $min = $schema->{minimum})) {
- if ($value < $min) {
+ if ($value < $min) {
add_error($errors, $path, "value must have a minimum value of $min");
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) {
check_prop($instance, $schema, '', $errors);
}
-
+
if (scalar(%$errors)) {
raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
}
},
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.",
optional => 1,
minimum => 0,
default => 0,
- },
+ },
maxLength => {
type => "integer",
description => "When the instance value is a string, this indicates maximum length of the string.",
description => "For CLI context, this defines the maximal width to print before truncating",
optional => 1,
},
- }
+ }
};
my $default_schema = Storable::dclone($default_schema_noref);
$default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
$default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{oneOf}->{items}->{properties} = $default_schema->{properties};
$default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
$default_schema->{properties}->{items}->{additionalProperties} = 0;
path => {},
parameters => {},
returns => {},
- }
+ }
},
},
method => {
},
protected => {
type => 'boolean',
- description => "Method needs special privileges - only pvedaemon can execute it",
+ 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 => 1,
},
user => {
- description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
- type => 'string',
+ description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
+ type => 'string',
enum => ['all', 'world'],
optional => 1,
},
check => {
description => "Array of permission checks (prefix notation).",
- type => 'array',
- optional => 1
+ type => 'array',
+ optional => 1
},
},
},
match_name => {},
match_re => {},
fragmentDelimiter => { optional => 1 }
- }
+ }
},
- },
+ },
},
};
sub validate_schema {
- my ($schema) = @_;
+ my ($schema) = @_;
my $errmsg = "internal error - unable to verify schema\n";
validate($schema, $default_schema, $errmsg);
my $errmsg = "internal error - unable to verify method info\n";
validate($info, $method_schema, $errmsg);
-
+
validate_schema($info->{parameters}) if $info->{parameters};
validate_schema($info->{returns}) if $info->{returns};
}
# run a self test on load
-# make sure we can verify the default schema
+# make sure we can verify the default schema
validate_schema($default_schema_noref);
validate_schema($method_schema);
return $found;
}
-# a way to parse command line parameters, using a
+# a way to parse command line parameters, using a
# schema to configure Getopt::Long
sub get_options {
my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
# 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";
- }
}
}
- }
+ }
}
foreach my $p (keys %$fixed_param) {
}
# 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} ||
+ die "got strange schema" if !$schema->{type} ||
!$schema->{properties} || $schema->{type} ne 'object';
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;
my $value = $2;
- if ($schema->{properties}->{$key} &&
+ if ($schema->{properties}->{$key} &&
$schema->{properties}->{$key}->{type} eq 'boolean') {
$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);
foreach my $k (keys %$errors) {
warn "parse error in '$filename' - '$k': $errors->{$k}\n";
delete $cfg->{$k};
- }
+ }
return $cfg;
}
my ($schema, $filename, $cfg) = @_;
# do fast check (avoid validate_schema($schema))
- die "got strange schema" if !$schema->{type} ||
+ die "got strange schema" if !$schema->{type} ||
!$schema->{properties} || $schema->{type} ne 'object';
validate($cfg, $schema, "validation error in '$filename'\n");
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 strict;
use warnings;
-use PVE::Tools qw(run_command lock_file);
-use PVE::ProcFSTools;
+
use PVE::INotify;
+use PVE::ProcFSTools;
+use PVE::Tools qw(run_command lock_file);
+
use File::Basename;
use IO::Socket::IP;
-use Socket qw(NI_NUMERICHOST NI_NUMERICSERV);
-use POSIX qw(ECONNREFUSED);
-
+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) = @_;
- system("/sbin/ip link set $iface up") == 0 ||
- die "can't activate interface '$iface'\n";
+ my $cmd = ['/sbin/ip', 'link', 'set', $iface, 'up'];
+ push @$cmd, ('mtu', $mtu) if $mtu;
+
+ eval { run_command($cmd) };
+ die "can't activate interface '$iface' - $@\n" if $@;
};
+sub add_bridge_fdb {
+ my ($iface, $mac) = @_;
+
+ my $learning = PVE::Tools::file_read_firstline("/sys/class/net/$iface/brport/learning");
+ return if !defined($learning) || $learning == 1;
+
+ my ($vmid, $devid) = &$parse_tap_device_name($iface, 1);
+ return if !defined($vmid);
+
+ run_command(['/sbin/bridge', 'fdb', 'append', $mac, 'dev', $iface, 'master', 'static']);
+
+ my ($fwbr, $vethfw, $vethfwpeer, $ovsintport) = &$compute_fwbr_names($vmid, $devid);
+
+ if (-d "/sys/class/net/$vethfwpeer") {
+ run_command(['/sbin/bridge', 'fdb', 'append', $mac, 'dev', $vethfwpeer, 'master', 'static']);
+ }
+
+ return;
+}
+
+sub del_bridge_fdb {
+ my ($iface, $mac) = @_;
+
+ my $learning = PVE::Tools::file_read_firstline("/sys/class/net/$iface/brport/learning");
+ return if !defined($learning) || $learning == 1;
+
+ my ($vmid, $devid) = &$parse_tap_device_name($iface, 1);
+ return if !defined($vmid);
+
+ run_command(['/sbin/bridge', 'fdb', 'del', $mac, 'dev', $iface, 'master', 'static']);
+
+ my ($fwbr, $vethfw, $vethfwpeer, $ovsintport) = &$compute_fwbr_names($vmid, $devid);
+
+ if (-d "/sys/class/net/$vethfwpeer") {
+ run_command(['/sbin/bridge', 'fdb', 'del', $mac, 'dev', $vethfwpeer, 'master', 'static']);
+ }
+
+ return;
+}
+
sub tap_create {
my ($iface, $bridge) = @_;
die "unable to get bridge setting\n" if !$bridge;
- my $bridgemtu = &$read_bridge_mtu($bridge);
+ my $bridgemtu = read_bridge_mtu($bridge);
- eval {
+ 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);
+ &$activate_interface($ovsintport, $bridgemtu);
- # set the same mtu for ovs int port
- PVE::Tools::run_command(['/sbin/ip', 'link', 'set', $ovsintport, 'mtu', $bridgemtu]);
-
&$bridge_add_interface($fwbr, $ovsintport);
+ &$bridge_disable_interface_learning($ovsintport) if $no_learning;
};
my $cleanup_firewall_bridge = sub {
my ($iface) = @_;
my ($vmid, $devid) = &$parse_tap_device_name($iface, 1);
- return if !defined($vmid);
+ return if !defined($vmid);
my ($fwbr, $vethfw, $vethfwpeer, $ovsintport) = &$compute_fwbr_names($vmid, $devid);
# cleanup old port config from any openvswitch bridge
};
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;
iface_set_master($iface, undef);
}
-
+
&$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 {
my ($bridgevlan, $iface, $tag) = @_;
my $ifacevlan = "${iface}.$tag";
-
+
# 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;
- return $cidr_obj->overlaps($ip_obj) == $Net::IP::IP_B_IN_A_OVERLAP;
+ my $overlap = $cidr_obj->overlaps($ip_obj);
+ return if !defined($overlap);
+
+ return $overlap == $Net::IP::IP_B_IN_A_OVERLAP || $overlap == $Net::IP::IP_IDENTICAL;
}
+# get all currently configured addresses that have a global scope, i.e., are reachable from the
+# outside of the host and thus are neither loopback nor link-local ones
+# returns an array ref of: { addr => "IP", cidr => "IP/PREFIXLEN", family => "inet|inet6" }
+sub get_reachable_networks {
+ my $raw = '';
+ run_command([qw(ip -j addr show up scope global)], outfunc => sub { $raw .= shift });
+ my $decoded = decode_json($raw);
+
+ my $addrs = []; # filter/transform first so that we can sort correctly more easily below
+ for my $e ($decoded->@*) {
+ next if !$e->{addr_info} || grep { $_ eq 'LOOPBACK' } $e->{flags}->@*;
+ push $addrs->@*, grep { scalar(keys $_->%*) } $e->{addr_info}->@*
+ }
+ my $res = [];
+ for my $info (sort { $a->{family} cmp $b->{family} || $a->{local} cmp $b->{local} } $addrs->@*) {
+ push $res->@*, {
+ addr => $info->{local},
+ cidr => "$info->{local}/$info->{prefixlen}",
+ family => $info->{family},
+ };
+ }
-sub get_local_ip_from_cidr {
- my ($cidr) = @_;
+ 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) };
- my $cmd = ['/sbin/ip', 'address', 'show', 'to', $cidr, 'up'];
+ return $resolved_host if defined($resolved_host) && !$param{all};
- my $IPs = [];
+ my $all = { v4 => {}, v6 => {} }; # hash to avoid duplicates and group by type
- my $code = sub {
- my $line = shift;
+ 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});
- if ($line =~ m!^\s*inet(?:6)?\s+($PVE::Tools::IPRE)/\d+!) {
- push @$IPs, $1;
+ 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
- PVE::Tools::run_command($cmd, outfunc => $code);
+ 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 $IPs;
+ return $res;
+}
+
+sub get_local_ip_from_cidr {
+ my ($cidr) = @_;
+
+ 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+)!) {
+ $IPs->{$1} = $i++ if !exists($IPs->{$1});
+ }
+ });
+
+ 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;
foreach my $k (PVE::Tools::split_list($keys)) {
# Note: we generate 3 values to allow small time drift
my $binkey;
- if ($k =~ /^[A-Z2-7=]{16}$/) {
+ if ($k =~ /^v2-0x([0-9a-fA-F]+)$/) {
+ # v2, hex
+ $binkey = pack('H*', $1);
+ } elsif ($k =~ /^v2-([A-Z2-7=]+)$/) {
+ # v2, base32
+ $binkey = MIME::Base32::decode_rfc3548($1);
+ } elsif ($k =~ /^[A-Z2-7=]{16}$/) {
$binkey = MIME::Base32::decode_rfc3548($k);
} elsif ($k =~ /^[A-Fa-f0-9]{40}$/) {
$binkey = pack('H*', $k);
--- /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;
mhz => 0,
cpus => 1,
sockets => 1,
+ flags => '',
};
my $fh = IO::File->new ($fn, "r");
return $res if !$fh;
+ my $cpuid = 0;
my $idhash = {};
my $count = 0;
while (defined(my $line = <$fh>)) {
$res->{model} = $1 if $res->{model} eq 'unknown';
} elsif ($line =~ m/^cpu\s+MHz\s*:\s*(\d+\.\d+)\s*$/i) {
$res->{mhz} = $1 if !$res->{mhz};
- } elsif ($line =~ m/^flags\s*:.*(vmx|svm)/) {
- $res->{hvm} = 1; # Hardware Virtual Machine (Intel VT / AMD-V)
+ } 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});
}
}
+ # Hardware Virtual Machine (Intel VT / AMD-V)
+ $res->{hvm} = $res->{flags} =~ m/\s(vmx|svm)\s/;
+
$res->{sockets} = scalar(keys %$idhash) || 1;
+ $res->{cores} = sum(values %$idhash) || 1;
+
$res->{cpus} = $count;
$fh->close;
-
+
$cpuinfo = $res;
return $res;
return (0, 0);
}
+sub kernel_version {
+ my $line = PVE::Tools::file_read_firstline("/proc/version");
+
+ if ($line && $line =~ m|^Linux\sversion\s((\d+(?:\.\d+)+)-?(\S+)?)|) {
+ my ($fullversion, $version_numbers, $extra) = ($1, $2, $3);
+
+ # variable names are the one from the Linux kernel Makefile
+ my ($version, $patchlevel, $sublevel) = split(/\./, $version_numbers);
+
+ return wantarray
+ ? (int($version), int($patchlevel), int($sublevel), $extra, $fullversion)
+ : $fullversion;
+ }
+
+ 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 {
$res->{cpu} = $last_proc_stat->{cpu};
if ($statstr && $statstr =~ m/^$pid \(.*\) (\S) (-?\d+) -?\d+ -?\d+ -?\d+ -?\d+ \d+ \d+ \d+ \d+ \d+ (\d+) (\d+) (-?\d+) (-?\d+) -?\d+ -?\d+ -?\d+ 0 (\d+) (\d+) (-?\d+) \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ -?\d+ -?\d+ \d+ \d+ \d+/) {
return {
status => $1,
+ ppid => $2,
utime => $3,
stime => $4,
starttime => $7,
# for processes spanned by other processes.
# kill(0, pid) return succes for zombies.
# So we read the status form /proc/$pid/stat instead
-
+
my $info = read_proc_pid_stat($pid);
-
+
return $info && (!$pstart || ($info->{starttime} eq $pstart)) && ($info->{status} ne 'Z') ? $info : undef;
}
swaptotal => 0,
swapfree => 0,
swapused => 0,
+ arcsize => 0,
};
my $fh = IO::File->new ("/proc/meminfo", "r");
while (my $line = <$fh>) {
if ($line =~ m/^(\S+):\s+(\d+)\s*kB/i) {
$d->{lc ($1)} = $2 * 1024;
- }
+ }
}
close($fh);
$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)) {
$data->{$k} = ref($d) ? clone($d) : $d;
}
}
- }
+ }
$res->{info}->{$info->{method}} = $data;
};
}
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});
my $path_lookup = $method_path_lookup->{$self};
die "$errprefix no path" if !defined($info->{path});
-
+
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 {
}
if ($regex) {
- $path_lookup->{regex} = {} if !defined($path_lookup->{regex});
+ $path_lookup->{regex} = {} if !defined($path_lookup->{regex});
my $old_name = $path_lookup->{regex}->{match_name};
die "$errprefix found changed regex match name\n"
if defined($old_re) && ($old_re ne $regex);
$path_lookup->{regex}->{match_name} = $name;
$path_lookup->{regex}->{match_re} = $regex;
-
+
die "$errprefix path match error - regex and fixed items\n"
if defined($path_lookup->{folders});
$path_lookup = $path_lookup->{regex};
-
+
} else {
- $path_lookup->{folders}->{$name} = {} if !defined($path_lookup->{folders}->{$name});
+ $path_lookup->{folders}->{$name} = {} if !defined($path_lookup->{folders}->{$name});
die "$errprefix path match error - regex and fixed items\n"
if defined($path_lookup->{regex});
}
}
- die "$errprefix duplicate method definition\n"
+ die "$errprefix duplicate method definition\n"
if defined($path_lookup->{$method});
if ($method eq 'SUBCLASS') {
my ($this) = @_;
# also see "man perldiag"
-
+
my $sub = $AUTOLOAD;
(my $method = $sub) =~ s/.*:://;
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;
}
} else {
die "internal error";
}
-
+
return undef if !$path_lookup;
if (my $info = $path_lookup->{SUBCLASS}) {
if (defined($fd)) {
# we only support the empty string '' (match whole URI)
- die "unsupported fragmentDelimiter '$fd'"
+ die "unsupported fragmentDelimiter '$fd'"
if $fd ne '';
$stack = [ join ('/', @$stack) ] if scalar(@$stack) > 1;
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) {
- ($param->{$key}) = $val =~ /^(.*)$/s;
- }
- $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}) {
#
# $info ... method info
# $prefix ... usually something like "$exename $cmd" ('pvesm add')
-# $arg_param ... list of parameters we want to get as ordered arguments
+# $arg_param ... list of parameters we want to get as ordered arguments
# on the command line (or single parameter name for lists)
# $fixed_param ... do not generate and info about those parameters
# $format:
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>"
}
- }
+ }
if ($format eq 'asciidoc') {
$out .= "*${prefix}*";
$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;
}
my $raw = '';
$style //= 'config';
-
+
my $idx_param = {}; # -vlan\d+ -scsi\d+
foreach my $k (sort keys %$prop) {
}
}
- $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';
next if !(ref($prop_fmt) && (ref($prop_fmt) eq 'HASH'));
$raw .= dump_properties($prop_fmt, $format, 'config-sub')
-
+
}
return $raw;
$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);
die $err if !$ec || $ec ne "PVE::Exception" || !$err->is_param_exc();
-
+
$err->{usage} = $self->usage_str($name, $prefix, $arg_param, $fixed_param, 'short', $param_cb, $formatter_properties);
die $err;
our @EXPORT = qw(syslog initlog);
my $log_tag = "unknown";
-
+
# never log to console - thats too slow, and
# 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 {
my ($tag, $facility) = @_;
- if ($tag) {
+ if ($tag) {
$tag = basename($tag);
$tag = encode("ascii", decode_utf8($tag));
use strict;
use warnings;
+
+use Carp;
use Digest::SHA;
+
use PVE::Exception qw(raise_param_exc);
use PVE::JSONSchema qw(get_standard_option);
-
-use Data::Dumper;
+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 => {},
sub options {
return {};
-}
+}
sub plugindata {
return {};
-}
+}
+
+sub has_isolated_properties {
+ my ($class) = @_;
+
+ my $isolatedPropertyList = $class->private()->{isolatedPropertyList};
+
+ return defined($isolatedPropertyList) && scalar(keys $isolatedPropertyList->%*) > 0;
+}
+
+my sub compare_property {
+ my ($a, $b, $skip_opts) = @_;
+
+ my $merged = {$a->%*, $b->%*};
+ delete $merged->{$_} for $skip_opts->@*;
+
+ for my $opt (keys $merged->%*) {
+ return 0 if !PVE::Tools::is_deeply($a->{$opt}, $b->{$opt});
+ }
+
+ return 1;
+};
+
+my sub add_property {
+ my ($props, $key, $prop, $type) = @_;
+
+ if (!defined($props->{$key})) {
+ $props->{$key} = $prop;
+ return;
+ }
+
+ if (!defined($props->{$key}->{oneOf})) {
+ if (compare_property($props->{$key}, $prop, ['instance-types'])) {
+ push $props->{$key}->{'instance-types'}->@*, $type;
+ } else {
+ my $new_prop = delete $props->{$key};
+ delete $new_prop->{'type-property'};
+ delete $prop->{'type-property'};
+ $props->{$key} = {
+ 'type-property' => 'type',
+ oneOf => [
+ $new_prop,
+ $prop,
+ ],
+ };
+ }
+ } else {
+ for my $existing_prop ($props->{$key}->{oneOf}->@*) {
+ if (compare_property($existing_prop, $prop, ['instance-types', 'type-property'])) {
+ push $existing_prop->{'instance-types'}->@*, $type;
+ return;
+ }
+ }
+
+ push $props->{$key}->{oneOf}->@*, $prop;
+ }
+};
sub createSchema {
- my ($class, $skip_type) = @_;
+ my ($class, $skip_type, $base) = @_;
my $pdata = $class->private();
my $propertyList = $pdata->{propertyList};
my $plugins = $pdata->{plugins};
- my $props = {};
+ my $props = $base || {};
- my $copy_property = sub {
- my ($src) = @_;
+ if (!$class->has_isolated_properties()) {
+ foreach my $p (keys %$propertyList) {
+ next if $skip_type && $p eq 'type';
- my $res = {};
- foreach my $k (keys %$src) {
- $res->{$k} = $src->{$k};
- }
-
- return $res;
- };
-
- 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};
my ($class) = @_;
my $pdata = $class->private();
-
+
return [ sort keys %{$pdata->{plugins}} ];
}
return $value if $key eq 'type' && $type eq $value;
my $opts = $pdata->{options}->{$type};
- die "unknown section type '$type'\n" if !$opts;
+ die "unknown section type '$type'\n" if !$opts;
die "unexpected property '$key'\n" if !defined($opts->{$key});
- my $schema = $pdata->{propertyList}->{$key};
+ my $schema = $class->get_property_schema($type, $key);
die "unknown property type\n" if !$schema;
my $ct = $schema->{type};
if (!$skipSchemaCheck) {
my $errors = {};
- PVE::JSONSchema::check_prop($value, $schema, '', $errors);
+
+ my $checkschema = $schema;
+
+ if ($ct eq 'array') {
+ die "no item schema for array" if !defined($schema->{items});
+ $checkschema = $schema->{items};
+ }
+
+ PVE::JSONSchema::check_prop($value, $checkschema, '', $errors);
if (scalar(keys %$errors)) {
die "$errors->{$key}\n" if $errors->{$key};
die "$errors->{_root}\n" if $errors->{_root};
return "$type: $sectionId\n";
}
+sub get_property_schema {
+ my ($class, $type, $key) = @_;
+
+ my $pdata = $class->private();
+ my $opts = $pdata->{options}->{$type};
+
+ my $schema;
+ if ($class->has_isolated_properties()) {
+ $schema = $pdata->{isolatedPropertyList}->{$type}->{$key};
+ }
+ $schema //= $pdata->{propertyList}->{$key};
+
+ return $schema;
+}
sub parse_config {
- my ($class, $filename, $raw) = @_;
+ my ($class, $filename, $raw, $allow_unknown) = @_;
my $pdata = $class->private();
$raw = '' if !defined($raw);
my $digest = Digest::SHA::sha1_hex($raw);
-
+
my $pri = 1;
my $lineno = 0;
my @lines = split(/\n/, $raw);
my $nextline = sub {
- while (my $line = shift @lines) {
+ while (defined(my $line = shift @lines)) {
$lineno++;
- return $line if $line !~ /^\s*(?:#|$)/;
+ return $line if ($line !~ /^\s*#/);
}
};
- while (my $line = &$nextline()) {
+ 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 $errprefix = "file $filename line $lineno";
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
+ while ($line = $nextline->()) {
+ next if $skip; # skip
$errprefix = "file $filename line $lineno";
if ($line =~ m/^\s+(\S+)(\s+(.*\S))?\s*$/) {
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 $maxpri = 0;
foreach my $sectionId (keys %$ids) {
- my $pri = $order->{$sectionId};
+ my $pri = $order->{$sectionId};
$maxpri = $pri if $pri && $pri > $maxpri;
}
foreach my $sectionId (keys %$ids) {
if (!defined ($order->{$sectionId})) {
$order->{$sectionId} = ++$maxpri;
- }
+ }
}
foreach my $sectionId (sort {$order->{$a} <=> $order->{$b}} keys %$ids) {
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)
dir_glob_foreach("$pcisysfs/devices", $pciregex, sub {
my ($fullid, $domain, $bus, $slot, $function) = @_;
- my $id = "$bus:$slot.$function";
+ my $id = "$domain:$bus:$slot.$function";
- if (defined($filter) && !ref($filter) && $id !~ m/^\Q$filter\E/) {
+ if (defined($filter) && !ref($filter) && $id !~ m/^(0000:)?\Q$filter\E/) {
return; # filter ids early
}
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 = normalize_pci_id($pciid);
+
# get IOMMU group devices
- opendir(my $D, "$pcisysfs/devices/0000:$pciid/iommu_group/devices/") || die "Cannot open iommu_group: $!\n";
- my @devs = grep /^0000:/, readdir($D);
+ opendir(my $D, "$pcisysfs/devices/$pciid/iommu_group/devices/") || die "Cannot open iommu_group: $!\n";
+ my @devs = grep /^${domainregex}:/, readdir($D);
closedir($D);
foreach my $pciid (@devs) {
- $pciid =~ m/^([:\.\da-f]+)$/ or die "PCI ID $pciid not valid!\n";
+ $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) = @_;
- my $basedir = "$pcisysfs/devices/0000:$pciid";
+ $pciid = normalize_pci_id($pciid);
+
+ my $basedir = "$pcisysfs/devices/$pciid";
my $mdev_dir = "$basedir/mdev_supported_types";
die "pci device '$pciid' does not support mediated devices \n"
return undef;
}
-sub pci_cleanup_mdev_device {
- my ($pciid, $uuid) = @_;
-
- my $basedir = "$pcisysfs/devices/0000:$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 {
die "syscall.ph can only be required once!\n" if $INC{'syscall.ph'};
require("syscall.ph");
openat => &SYS_openat,
close => &SYS_close,
mkdirat => &SYS_mkdirat,
+ mknod => &SYS_mknod,
faccessat => &SYS_faccessat,
setresuid => &SYS_setresuid,
+ fchownat => &SYS_fchownat,
+ mount => &SYS_mount,
+ 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 = (
+ OPEN_TREE_CLONE => 0x0000_0001,
+ OPEN_TREE_CLOEXEC => 000200_0000, # octal!
+
+ MOVE_MOUNT_F_SYMLINKS => 0x0000_0001,
+ MOVE_MOUNT_F_AUTOMOUNTS => 0x0000_0002,
+ MOVE_MOUNT_F_EMPTY_PATH => 0x0000_0004,
+ MOVE_MOUNT_F_MASK => 0x0000_0007,
+
+ MOVE_MOUNT_T_SYMLINKS => 0x0000_0010,
+ MOVE_MOUNT_T_AUTOMOUNTS => 0x0000_0020,
+ MOVE_MOUNT_T_EMPTY_PATH => 0x0000_0040,
+ MOVE_MOUNT_T_MASK => 0x0000_0070,
+
+ FSMOUNT_CLOEXEC => 0x0000_0001,
+
+ FSOPEN_CLOEXEC => 0x0000_0001,
+
+ MOUNT_ATTR_RDONLY => 0x0000_0001,
+ MOUNT_ATTR_NOSUID => 0x0000_0002,
+ MOUNT_ATTR_NODEV => 0x0000_0004,
+ MOUNT_ATTR_NOEXEC => 0x0000_0008,
+ MOUNT_ATTR_RELATIME => 0x0000_0000,
+ MOUNT_ATTR_NOATIME => 0x0000_0010,
+ MOUNT_ATTR_STRICTATIME => 0x0000_0020,
+ MOUNT_ATTR_NODIRATIME => 0x0000_0080,
+
+ FSPICK_CLOEXEC => 0x0000_0001,
+ FSPICK_SYMLINK_NOFOLLOW => 0x0000_0002,
+ FSPICK_NO_AUTOMOUNT => 0x0000_0004,
+ FSPICK_EMPTY_PATH => 0x0000_0008,
+
+ FSCONFIG_SET_FLAG => 0,
+ FSCONFIG_SET_STRING => 1,
+ FSCONFIG_SET_BINARY => 2,
+ FSCONFIG_SET_PATH => 3,
+ FSCONFIG_SET_PATH_EMPTY => 4,
+ FSCONFIG_SET_FD => 5,
+ FSCONFIG_CMD_CREATE => 6,
+ FSCONFIG_CMD_RECONFIGURE => 7,
);
};
use constant \%syscalls;
+use constant \%fsmount_constants;
use base 'Exporter';
-our @EXPORT_OK = keys(%syscalls);
+our @EXPORT_OK = (keys(%syscalls), keys(%fsmount_constants), 'file_handle_result');
+our %EXPORT_TAGS = (fsmount => [keys(%fsmount_constants)]);
+
+# Create a file handle from a numeric file descriptor (to make sure it's close()d when it goes out
+# of scope).
+sub file_handle_result($) {
+ my ($fd_num) = @_;
+ return undef if $fd_num < 0;
+
+ open(my $fh, '<&=', $fd_num)
+ or return undef;
+
+ return $fh;
+}
+
+1;
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
O_TMPFILE
+AT_EMPTY_PATH
+AT_FDCWD
+CLONE_NEWNS
+CLONE_NEWUTS
+CLONE_NEWIPC
+CLONE_NEWUSER
+CLONE_NEWPID
+CLONE_NEWNET
+MS_RDONLY
+MS_NOSUID
+MS_NODEV
+MS_NOEXEC
+MS_SYNCHRONOUS
+MS_REMOUNT
+MS_MANDLOCK
+MS_DIRSYNC
+MS_NOSYMFOLLOW
+MS_NOATIME
+MS_NODIRATIME
+MS_BIND
+MS_MOVE
+MS_REC
);
my $pvelogdir = "/var/log/pve";
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 {
my $res = eval { run_fork_with_timeout($timeout, $df) } // {};
warn $@ if $@;
- # untaint the values
- my ($blocks, $used, $bavail) = map { defined($_) ? (/^(\d+)$/) : 0 }
+ # untaint, but be flexible: PB usage can result in scientific notation
+ my ($blocks, $used, $bavail) = map { defined($_) ? (/^([\d\.e\-+]+)$/) : 0 }
$res->@{qw(blocks used bavail)};
return {
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) = @_;
+sub dump_logfile_by_filehandle {
+ my ($fh, $filter, $state) = @_;
- 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);
- }
-
- $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,
+ int($dirfd),
+ $pathname,
+ int($owner),
+ int($group),
+ int($flags),
+ ) == 0;
}
my $salt_starter = time();
return $line;
}
+my $host_arch;
sub get_host_arch {
-
- my @uname = POSIX::uname();
- my $machine = $uname[4];
-
- if ($machine eq 'x86_64') {
- return 'amd64';
- } elsif ($machine eq 'aarch64') {
- return 'arm64';
- } else {
- die "unsupported host architecture '$machine'\n";
- }
+ $host_arch = (POSIX::uname())[4] if !$host_arch;
+ return $host_arch;
}
# Devices are: [ (12 bits minor) (12 bits major) (8 bits minor) ]
return (($dev_t >> 12) & 0xfff00) | ($dev_t & 0xff);
}
+# Given an array of array refs [ \[a b c], \[a b b], \[e b a] ]
+# Returns the intersection of elements as a single array [a b]
+sub array_intersect {
+ my ($arrays) = @_;
+
+ if (!ref($arrays->[0])) {
+ $arrays = [ grep { ref($_) eq 'ARRAY' } @_ ];
+ }
+
+ return [] if scalar(@$arrays) == 0;
+ return $arrays->[0] if scalar(@$arrays) == 1;
+
+ my $array_unique = sub {
+ my %seen = ();
+ return grep { ! $seen{ $_ }++ } @_;
+ };
+
+ # base idea is to get all unique members from the first array, then
+ # check the common elements with the next (uniquely made) one, only keep
+ # those. Repeat for every array and at the end we only have those left
+ # which exist in all arrays
+ my $return_arr = [ $array_unique->(@{$arrays->[0]}) ];
+ for my $i (1 .. $#$arrays) {
+ my %count = ();
+ # $return_arr is already unique, explicit at before the loop, implicit below.
+ foreach my $element (@$return_arr, $array_unique->(@{$arrays->[$i]})) {
+ $count{$element}++;
+ }
+ $return_arr = [];
+ foreach my $element (keys %count) {
+ push @$return_arr, $element if $count{$element} > 1;
+ }
+ last if scalar(@$return_arr) == 0; # empty intersection, early exit
+ }
+
+ return $return_arr;
+}
+
+sub open_tree($$$) {
+ my ($dfd, $pathname, $flags) = @_;
+ return PVE::Syscall::file_handle_result(syscall(
+ &PVE::Syscall::open_tree,
+ int($dfd),
+ $pathname,
+ int($flags),
+ ));
+}
+
+sub move_mount($$$$$) {
+ my ($from_dirfd, $from_pathname, $to_dirfd, $to_pathname, $flags) = @_;
+ return 0 == syscall(
+ &PVE::Syscall::move_mount,
+ int($from_dirfd),
+ $from_pathname,
+ int($to_dirfd),
+ $to_pathname,
+ int($flags),
+ );
+}
+
+sub fsopen($$) {
+ my ($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,
+ int($fd),
+ int($flags),
+ int($mount_attrs),
+ ));
+}
+
+sub fspick($$$) {
+ my ($dirfd, $pathname, $flags) = @_;
+ return PVE::Syscall::file_handle_result(syscall(
+ &PVE::Syscall::fspick,
+ int($dirfd),
+ $pathname,
+ int($flags),
+ ));
+}
+
+sub fsconfig($$$$$) {
+ my ($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).
+# use for lower level stuff such as bind/remount/... or simple tmpfs mounts
+sub mount($$$$$) {
+ my ($source, $target, $filesystemtype, $mountflags, $data) = @_;
+ return 0 == syscall(
+ &PVE::Syscall::mount,
+ $source,
+ $target,
+ $filesystemtype,
+ 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:
.PHONY: check install clean distclean
-check:
+export PERLLIB=../src
+
+check: $(TESTS)
for d in $(SUBDIRS); do $(MAKE) -C $$d check; done
- ./lock_file.pl
- ./calendar_event_test.pl
- ./convert_size_test.pl
-install: check
+%.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
source-directory before-ovs.d
-auto vmbr1
+allow-ovs vmbr1
iface vmbr1 inet static
address $wanted{vmbr1}->{address}
netmask $wanted{vmbr1}->{netmask}
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);
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
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
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();
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib '../src';
+
+use Test::More;
+use Test::MockModule;
+
+use PVE::Tools;
+use PVE::ProcFSTools;
+
+# the proc "state"
+my $proc = {
+ version => '',
+};
+
+my $pve_common_tools;
+$pve_common_tools = Test::MockModule->new('PVE::Tools');
+$pve_common_tools->mock(
+ file_read_firstline => sub {
+ my ($filename) = @_;
+
+ $filename =~ s!^/proc/!!;
+
+ my $res = $proc->{$filename};
+
+ if (ref($res) eq 'CODE') {
+ $res = $res->();
+ }
+
+ chomp $res;
+ return $res;
+ },
+);
+
+
+# version tests
+
+my @kernel_versions = (
+{
+ version => 'Linux version 5.3.10-1-pve (build@pve) (gcc version 8.3.0 (Debian 8.3.0-6)) #1 SMP PVE 5.3.10-1 (Thu, 14 Nov 2019 10:43:13 +0100)',
+ expect => [5, 3, 10, '1-pve', '5.3.10-1-pve'],
+},
+{
+ version => 'Linux version 5.0.21-5-pve (build@pve) (gcc version 8.3.0 (Debian 8.3.0-6)) #1 SMP PVE 5.0.21-10 (Wed, 13 Nov 2019 08:27:10 +0100)',
+ expect => [5, 0, 21, '5-pve', '5.0.21-5-pve'],
+},
+{
+ version => 'Linux version 5.0.21+ (build@pve) (gcc version 8.3.0 (Debian 8.3.0-6)) #27 SMP Tue Nov 12 10:30:36 CET 2019',
+ expect => [5, 0, 21, '+', '5.0.21+'],
+},
+{
+ version => 'Linu$ version 2 (build@pve) (gcc version 8.3.0 (Debian 8.3.0-6)) #27 SMP Tue Nov 12 10:30:36 CET 2019',
+ expect => [0, 0, 0, '', ''],
+},
+);
+
+subtest 'test kernel_version parser' => sub {
+ for my $test (@kernel_versions) {
+ $proc->{version} = $test->{version};
+
+ my $res = [ PVE::ProcFSTools::kernel_version() ];
+
+ is_deeply($res, $test->{expect}, "got version <". $res->[4] ."> same as expected");
+ }
+};
+
+
+done_testing();
--- /dev/null
+#!/usr/bin/perl
+
+use lib '../src';
+
+package Conf;
+use strict;
+use warnings;
+
+use Test::More;
+
+use base qw(PVE::SectionConfig);
+
+my $defaultData = {
+ propertyList => {
+ type => { description => "Section type." },
+ id => {
+ description => "ID",
+ type => 'string',
+ format => 'pve-configid',
+ maxLength => 64,
+ },
+ common => {
+ type => 'string',
+ description => 'common value',
+ maxLength => 512,
+ },
+ },
+};
+
+sub private {
+ return $defaultData;
+}
+
+sub expect_success {
+ my ($class, $filename, $expected, $raw, $allow_unknown) = @_;
+
+ my $res = $class->parse_config($filename, $raw, $allow_unknown);
+ delete $res->{digest};
+
+ is_deeply($res, $expected, $filename);
+
+ my $written = $class->write_config($filename, $res, $allow_unknown);
+ my $res2 = $class->parse_config($filename, $written, $allow_unknown);
+ delete $res2->{digest};
+
+ is_deeply($res, $res2, "$filename - verify rewritten data");
+}
+
+sub expect_fail {
+ my ($class, $filename, $expected, $raw) = @_;
+
+ eval { $class->parse_config($filename, $raw) };
+ die "test '$filename' succeeded unexpectedly\n" if !$@;
+ ok(1, "$filename should fail to parse");
+}
+
+package Conf::One;
+use strict;
+use warnings;
+
+use base 'Conf';
+
+sub type {
+ return 'one';
+}
+
+sub properties {
+ return {
+ field1 => {
+ description => 'Field One',
+ type => 'integer',
+ minimum => 3,
+ maximum => 9,
+ },
+ field2 => {
+ description => 'Field Two',
+ type => 'integer',
+ minimum => 10,
+ maximum => 19,
+ },
+ another => {
+ description => 'Another field',
+ type => 'string',
+ optional => 1,
+ },
+ arrayfield => {
+ description => "Array Field with property string",
+ optional => 1,
+ type => 'array',
+ items => {
+ type => 'string',
+ description => 'a property string',
+ format => {
+ subfield1 => {
+ type => 'string',
+ description => 'first subfield'
+ },
+ subfield2 => {
+ type => 'integer',
+ minimum => 0,
+ optional => 1,
+ },
+ },
+ },
+ },
+ };
+}
+
+sub options {
+ return {
+ common => { optional => 1 },
+ };
+}
+
+package Conf::Two;
+use strict;
+use warnings;
+
+use base 'Conf';
+
+sub type {
+ return 'two';
+}
+
+sub properties {
+ return {
+ field2 => {
+ description => 'Field Two but different',
+ type => 'integer',
+ minimum => 3,
+ maximum => 9,
+ },
+ another => {
+ description => 'Another field',
+ type => 'string',
+ },
+ arrayfield => {
+ optional => 1,
+ description => "Array Field with property string",
+ type => 'array',
+ items => {
+ type => 'string',
+ description => 'a property string',
+ format => {
+ subfield1 => {
+ type => 'string',
+ description => 'first subfield'
+ },
+ subfield2 => {
+ type => 'integer',
+ minimum => 0,
+ optional => 1,
+ },
+ },
+ },
+ },
+ };
+}
+
+sub options {
+ return {
+ common => { optional => 1 },
+ };
+}
+
+package main;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+Conf::One->register();
+Conf::Two->register();
+Conf->init(property_isolation => 1);
+
+# FIXME: allow development debug warnings?!
+local $SIG{__WARN__} = sub { die @_; };
+
+my sub enum {
+ my $n = 1;
+ return { map { $_ => $n++ } @_ };
+}
+
+Conf->expect_success(
+ 'property-isolation-test1',
+ {
+ ids => {
+ t1 => {
+ type => 'one',
+ common => 'foo',
+ field1 => 3,
+ field2 => 10,
+ arrayfield => [ 'subfield1=test' ],
+ },
+ t2 => {
+ type => 'one',
+ common => 'foo2',
+ field1 => 4,
+ field2 => 15,
+ another => 'more-text',
+ },
+ t3 => {
+ type => 'two',
+ field2 => 5,
+ another => 'even more text',
+ },
+ },
+ order => { t1 => 1, t2 => 2, t3 => 3 },
+ },
+ <<"EOF");
+one: t1
+ common foo
+ field1 3
+ field2 10
+ arrayfield subfield1=test
+
+one: t2
+ common foo2
+ field1 4
+ field2 15
+ another more-text
+
+two: t3
+ field2 5
+ another even more text
+EOF
+
+my $with_unknown_data = {
+ ids => {
+ t1 => {
+ type => 'one',
+ common => 'foo',
+ field1 => 3,
+ field2 => 10,
+ },
+ t2 => {
+ type => 'one',
+ common => 'foo2',
+ field1 => 4,
+ field2 => 15,
+ another => 'more-text',
+ },
+ t3 => {
+ type => 'two',
+ field2 => 5,
+ another => 'even more text',
+ arrayfield => [
+ 'subfield1=test,subfield2=2',
+ 'subfield1=test2',
+ ],
+ },
+ invalid => {
+ type => 'bad',
+ common => 'omg',
+ unknownfield => 'shouldnotbehere',
+ unknownarray => ['entry1', 'entry2'],
+ },
+ },
+ order => enum(qw(t1 t2 invalid t3)),
+};
+my $with_unknown_text = <<"EOF";
+one: t1
+ common foo
+ field1 3
+ field2 10
+
+one: t2
+ common foo2
+ field1 4
+ field2 15
+ another more-text
+
+bad: invalid
+ common omg
+ unknownfield shouldnotbehere
+ unknownarray entry1
+ unknownarray entry2
+
+two: t3
+ field2 5
+ another even more text
+ arrayfield subfield1=test,subfield2=2
+ arrayfield subfield1=test2
+EOF
+
+my $wrong_field_schema_data = {
+ ids => {
+ t1 => {
+ type => 'one',
+ common => 'foo',
+ field1 => 3,
+ field2 => 5, # this should fail
+ },
+ },
+ order => enum(qw(t1)),
+};
+
+my $wrong_field_schema_text = <<"EOF";
+one: t1
+ common foo
+ field1 3
+ field2 5
+EOF
+
+Conf->expect_fail('property-isolation-wrong-field-schema', $wrong_field_schema_data, $wrong_field_schema_text);
+Conf->expect_fail('property-isolation-unknown-forbidden', $with_unknown_data, $with_unknown_text);
+Conf->expect_success('property-isolation-unknown-allowed', $with_unknown_data, $with_unknown_text, 1);
+
+# schema tests
+my $create_schema = Conf->createSchema();
+my $expected_create_schema = {
+ additionalProperties => 0,
+ type => 'object',
+ properties => {
+ id => {
+ description => "ID",
+ type => 'string',
+ format => 'pve-configid',
+ maxLength => 64,
+ },
+ type => {
+ description => 'Section type.',
+ enum => [ 'one', 'two' ],
+ type => 'string'
+ },
+ common => {
+ maxLength => 512,
+ optional => 1,
+ type => 'string',
+ description => 'common value'
+ },
+ field1 => {
+ type => 'integer',
+ 'type-property' => 'type',
+ 'instance-types' => [ 'one' ],
+ maximum => 9,
+ optional => 1,
+ minimum => 3,
+ description => 'Field One'
+ },
+ field2 => {
+ oneOf => [
+ {
+ description => 'Field Two',
+ optional => 1,
+ minimum => 10,
+ 'instance-types' => [ 'one' ],
+ type => 'integer',
+ maximum => 19
+ },
+ {
+ optional => 1,
+ minimum => 3,
+ description => 'Field Two but different',
+ type => 'integer',
+ 'instance-types' => [ 'two' ],
+ maximum => 9
+ }
+ ],
+ 'type-property' => 'type'
+ },
+ arrayfield => {
+ items => {
+ type => 'string',
+ format => {
+ subfield1 => {
+ description => 'first subfield',
+ type => 'string'
+ },
+ subfield2 => {
+ minimum => 0,
+ type => 'integer',
+ optional => 1
+ }
+ },
+ description => 'a property string'
+ },
+ description => 'Array Field with property string',
+ type => 'array',
+ optional => 1
+ },
+ another => {
+ optional => 1,
+ type => 'string',
+ description => 'Another field'
+ },
+ },
+};
+
+is_deeply($create_schema, $expected_create_schema, "property-isolation create schema test");
+
+my $update_schema = Conf->updateSchema();
+my $expected_update_schema = {
+ additionalProperties => 0,
+ type => 'object',
+ properties => {
+ id => {
+ description => "ID",
+ type => 'string',
+ format => 'pve-configid',
+ maxLength => 64,
+ },
+ type => {
+ type => 'string',
+ enum => [ 'one', 'two' ],
+ description => 'Section type.'
+ },
+ digest => {
+ optional => 1,
+ type => 'string',
+ description => 'Prevent changes if current configuration file has a different digest. This can be used to prevent concurrent modifications.',
+ maxLength => 64
+ },
+ delete => {
+ description => 'A list of settings you want to delete.',
+ maxLength => 4096,
+ format => 'pve-configid-list',
+ optional => 1,
+ type => 'string'
+ },
+ common => {
+ maxLength => 512,
+ description => 'common value',
+ type => 'string',
+ optional => 1
+ },
+ field1 => {
+ description => 'Field One',
+ maximum => 9,
+ 'instance-types' => [ 'one' ],
+ 'type-property' => 'type',
+ minimum => 3,
+ optional => 1,
+ type => 'integer'
+ },
+ field2 => {
+ 'type-property' => 'type',
+ oneOf => [
+ {
+ type => 'integer',
+ minimum => 10,
+ optional => 1,
+ maximum => 19,
+ 'instance-types' => [ 'one' ],
+ description => 'Field Two'
+ },
+ {
+ description => 'Field Two but different',
+ maximum => 9,
+ 'instance-types' => [ 'two' ],
+ minimum => 3,
+ optional => 1,
+ type => 'integer'
+ }
+ ]
+ },
+ arrayfield => {
+ type => 'array',
+ optional => 1,
+ items => {
+ description => 'a property string',
+ type => 'string',
+ format => {
+ subfield2 => {
+ type => 'integer',
+ minimum => 0,
+ optional => 1
+ },
+ subfield1 => {
+ description => 'first subfield',
+ type => 'string'
+ }
+ }
+ },
+ description => 'Array Field with property string'
+ },
+ another => {
+ description => 'Another field',
+ optional => 1,
+ type => 'string'
+ },
+ }
+};
+is_deeply($update_schema, $expected_update_schema, "property-isolation update schema test");
+
+done_testing();
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+use lib '../src';
+
+package Conf;
+use strict;
+use warnings;
+
+use Test::More;
+
+use base qw(PVE::SectionConfig);
+
+my $defaultData = {
+ propertyList => {
+ type => { description => "Section type." },
+ id => {
+ description => "ID",
+ type => 'string',
+ format => 'pve-configid',
+ maxLength => 64,
+ },
+ common => {
+ type => 'string',
+ description => 'common value',
+ maxLength => 512,
+ },
+ },
+};
+
+sub private {
+ return $defaultData;
+}
+
+sub expect_success {
+ my ($class, $filename, $expected, $raw, $allow_unknown) = @_;
+
+ my $res = $class->parse_config($filename, $raw, $allow_unknown);
+ delete $res->{digest};
+
+ is_deeply($res, $expected, $filename);
+
+ my $written = $class->write_config($filename, $res, $allow_unknown);
+ my $res2 = $class->parse_config($filename, $written, $allow_unknown);
+ delete $res2->{digest};
+
+ is_deeply($res, $res2, "$filename - verify rewritten data");
+}
+
+sub expect_fail {
+ my ($class, $filename, $expected, $raw) = @_;
+
+ eval { $class->parse_config($filename, $raw) };
+ die "test '$filename' succeeded unexpectedly\n" if !$@;
+ ok(1, "$filename should fail to parse");
+}
+
+package Conf::One;
+use strict;
+use warnings;
+
+use base 'Conf';
+
+sub type {
+ return 'one';
+}
+
+sub properties {
+ return {
+ field1 => {
+ description => 'Field One',
+ type => 'integer',
+ minimum => 3,
+ maximum => 9,
+ },
+ another => {
+ description => 'Another field',
+ type => 'string',
+ },
+ };
+}
+
+sub options {
+ return {
+ common => { optional => 1 },
+ field1 => {},
+ another => { optional => 1 },
+ };
+}
+
+package Conf::Two;
+use strict;
+use warnings;
+
+use base 'Conf';
+
+sub type {
+ return 'two';
+}
+
+sub properties {
+ return {
+ field2 => {
+ description => 'Field Two',
+ type => 'integer',
+ minimum => 3,
+ maximum => 9,
+ },
+ arrayfield => {
+ description => "Array Field with property string",
+ type => 'array',
+ items => {
+ type => 'string',
+ description => 'a property string',
+ format => {
+ subfield1 => {
+ type => 'string',
+ description => 'first subfield'
+ },
+ subfield2 => {
+ type => 'integer',
+ minimum => 0,
+ optional => 1,
+ },
+ },
+ },
+ },
+ };
+}
+
+sub options {
+ return {
+ common => { optional => 1 },
+ field2 => {},
+ another => {},
+ arrayfield => { optional => 1 },
+ };
+}
+
+package main;
+
+use strict;
+use warnings;
+
+use Test::More;
+use PVE::JSONSchema;
+
+Conf::One->register();
+Conf::Two->register();
+Conf->init();
+
+# FIXME: allow development debug warnings?!
+local $SIG{__WARN__} = sub { die @_; };
+
+my sub enum {
+ my $n = 1;
+ return { map { $_ => $n++ } @_ };
+}
+
+Conf->expect_success(
+ 'test1',
+ {
+ ids => {
+ t1 => {
+ type => 'one',
+ common => 'foo',
+ field1 => 3,
+ },
+ t2 => {
+ type => 'one',
+ common => 'foo2',
+ field1 => 4,
+ another => 'more-text',
+ },
+ t3 => {
+ type => 'two',
+ field2 => 5,
+ another => 'even more text',
+ },
+ },
+ order => { t1 => 1, t2 => 2, t3 => 3 },
+ },
+ <<"EOF");
+one: t1
+ common foo
+ field1 3
+
+one: t2
+ common foo2
+ field1 4
+ another more-text
+
+two: t3
+ field2 5
+ another even more text
+EOF
+
+my $with_unknown_data = {
+ ids => {
+ t1 => {
+ type => 'one',
+ common => 'foo',
+ field1 => 3,
+ },
+ t2 => {
+ type => 'one',
+ common => 'foo2',
+ field1 => 4,
+ another => 'more-text',
+ },
+ t3 => {
+ type => 'two',
+ field2 => 5,
+ another => 'even more text',
+ arrayfield => [
+ 'subfield1=test,subfield2=2',
+ 'subfield1=test2',
+ ],
+ },
+ invalid => {
+ type => 'bad',
+ common => 'omg',
+ unknownfield => 'shouldnotbehere',
+ unknownarray => ['entry1', 'entry2'],
+ },
+ },
+ order => enum(qw(t1 t2 invalid t3)),
+};
+my $with_unknown_text = <<"EOF";
+one: t1
+ common foo
+ field1 3
+
+one: t2
+ common foo2
+ field1 4
+ another more-text
+
+bad: invalid
+ common omg
+ unknownfield shouldnotbehere
+ unknownarray entry1
+ unknownarray entry2
+
+two: t3
+ field2 5
+ another even more text
+ arrayfield subfield1=test,subfield2=2
+ arrayfield subfield1=test2
+EOF
+
+Conf->expect_fail('unknown-forbidden', $with_unknown_data, $with_unknown_text);
+Conf->expect_success('unknown-allowed', $with_unknown_data, $with_unknown_text, 1);
+
+# schema tests
+my $create_schema = Conf->createSchema();
+my $expected_create_schema = {
+ additionalProperties => 0,
+ type => 'object',
+ properties => {
+ id => {
+ description => 'ID',
+ format => 'pve-configid',
+ maxLength => 64,
+ type => 'string',
+ },
+ type => {
+ description => 'Section type.',
+ enum => ['one', 'two'],
+ type => 'string',
+ },
+ common => {
+ type => 'string',
+ description => 'common value',
+ maxLength => 512,
+ },
+ field1 => {
+ description => 'Field One',
+ maximum => 9,
+ minimum => 3,
+ optional => 1,
+ type => 'integer',
+
+ },
+ 'field2'=> {
+ 'description'=> 'Field Two',
+ 'maximum'=> 9,
+ 'minimum'=> 3,
+ 'optional'=> 1,
+ 'type'=> 'integer',
+ },
+ 'arrayfield'=> {
+ 'description'=> 'Array Field with property string',
+ 'items'=> {
+ 'description'=> 'a property string',
+ 'format'=> {
+ 'subfield2'=> {
+ 'optional'=> 1,
+ 'type'=> 'integer',
+ 'minimum'=> 0
+ },
+ 'subfield1'=> {
+ 'description'=> 'first subfield',
+ 'type'=> 'string',
+ },
+ },
+ 'type'=> 'string'
+ },
+ 'optional'=> 1,
+ 'type'=> 'array',
+ },
+ 'another'=> {
+ 'description'=> 'Another field',
+ 'optional'=> 1,
+ 'type'=> 'string',
+ },
+ },
+};
+
+is_deeply($create_schema, $expected_create_schema, "create schema test");
+
+my $update_schema = Conf->updateSchema();
+my $expected_update_schema = {
+ additionalProperties => 0,
+ type => 'object',
+ properties => {
+ id => {
+ description => 'ID',
+ format => 'pve-configid',
+ maxLength => 64,
+ type => 'string',
+ },
+ delete => {
+ type => 'string', format => 'pve-configid-list',
+ description => "A list of settings you want to delete.",
+ maxLength => 4096,
+ optional => 1,
+ },
+ digest => PVE::JSONSchema::get_standard_option('pve-config-digest'),
+ common => {
+ description => 'common value',
+ maxLength => 512,
+ type => 'string',
+ },
+ field1 => {
+ description => 'Field One',
+ maximum => 9,
+ minimum => 3,
+ optional => 1,
+ type => 'integer'
+ },
+ field2 => {
+ description => 'Field Two',
+ maximum => 9,
+ minimum => 3,
+ optional => 1,
+ type => 'integer',
+ },
+ arrayfield => {
+ description => 'Array Field with property string',
+ items => {
+ type => 'string',
+ description => 'a property string',
+ format => {
+ subfield2 => {
+ type => 'integer',
+ minimum => 0,
+ optional => 1
+ },
+ subfield1 => {
+ description => 'first subfield',
+ type => 'string'
+ }
+ }
+ },
+ optional => 1,
+ type => 'array',
+ },
+ another => {
+ description => 'Another field',
+ optional => 1,
+ type => 'string',
+ },
+ },
+};
+is_deeply($update_schema, $expected_update_schema, "update schema test");
+
+done_testing();
+
+1;
projects / pve-common.git / commitdiff