diff --git a/.github/workflows/generate-and-build-sdks.yml b/.github/workflows/generate-and-build-sdks.yml index cf306219a58..87046d45d17 100644 --- a/.github/workflows/generate-and-build-sdks.yml +++ b/.github/workflows/generate-and-build-sdks.yml @@ -73,7 +73,7 @@ jobs: # isn't using UTC - name: Set Timezone to Tokyo for datetime tests run: | - sudo timedatectl set-timezone Asia/Tokyo + sudo ln -sf /usr/share/zoneinfo/Asia/Tokyo /etc/localtime - name: Run CI for SDKs uses: ./.github/workflows/sdk-ci @@ -139,7 +139,7 @@ jobs: # isn't using UTC - name: Set Timezone to Tokyo for datetime tests run: | - sudo timedatectl set-timezone Asia/Tokyo + sudo ln -sf /usr/share/zoneinfo/Asia/Tokyo /etc/localtime - name: Build Java SDK shell: bash diff --git a/Makefile b/Makefile index 810c812d9ec..ab12d9a1570 100644 --- a/Makefile +++ b/Makefile @@ -138,7 +138,6 @@ install-extra: install -D ./ocaml/xenopsd/scripts/xen-backend.rules $(DESTDIR)/$(ETCDIR)/udev/rules.d/xen-backend.rules install -D ./ocaml/xenopsd/scripts/qemu-wrapper $(DESTDIR)/$(QEMU_WRAPPER_DIR)/qemu-wrapper install -D ./ocaml/xenopsd/scripts/swtpm-wrapper $(DESTDIR)/$(QEMU_WRAPPER_DIR)/swtpm-wrapper - install -D ./ocaml/xenopsd/scripts/pygrub-wrapper $(DESTDIR)/$(QEMU_WRAPPER_DIR)/pygrub-wrapper DESTDIR=$(DESTDIR) SBINDIR=$(SBINDIR) QEMU_WRAPPER_DIR=$(QEMU_WRAPPER_DIR) XENOPSD_LIBEXECDIR=$(XENOPSD_LIBEXECDIR) ETCDIR=$(ETCDIR) ./ocaml/xenopsd/scripts/make-custom-xenopsd.conf # common flags and packages for 'dune install' and 'dune uninstall' @@ -182,7 +181,7 @@ install: chmod +x $(DESTDIR)$(DOCDIR)/doc-convert.sh # backward compat with existing specfile, to be removed after it is updated find $(DESTDIR) -name '*.cmxs' -delete - for pkg in xapi-debug xapi xe xapi-tools xapi-sdk vhd-tool qcow-stream-tool; do for f in CHANGELOG LICENSE README.markdown; do rm $(DESTDIR)$(OPTDIR)/doc/$$pkg/$$f $(DESTDIR)$(PREFIX)/doc/$$pkg/$$f -f; done; for f in META dune-package opam; do rm $(DESTDIR)$(LIBDIR)/$$pkg/$$f -f; done; done; + for pkg in xapi-debug xapi xe xapi-tools xapi-sdk vhd-tool qcow-stream-tool; do for f in CHANGELOG LICENSE README.md; do rm $(DESTDIR)$(OPTDIR)/doc/$$pkg/$$f $(DESTDIR)$(PREFIX)/doc/$$pkg/$$f -f; done; for f in META dune-package opam; do rm $(DESTDIR)$(LIBDIR)/$$pkg/$$f -f; done; done; uninstall: diff --git a/README.markdown b/README.md similarity index 66% rename from README.markdown rename to README.md index 9f795d85506..26d76b2c300 100644 --- a/README.markdown +++ b/README.md @@ -7,7 +7,7 @@ Xen API (or xapi) is a management stack that configures and controls Xen-enabled hosts and resource pools, and coordinates resources within the pool. Xapi exposes the Xen API interface for many languages and is a component of the XenServer project. -Xen API is written mostly in [OCaml](http://caml.inria.fr/ocaml/) +Xen API is written mostly in [OCaml](https://ocaml.org) 4.07. Xapi is the main component produced by the Linux Foundation's @@ -59,6 +59,10 @@ To build xen-api from source, we recommend using [opam](https://opam.ocaml.org/d ```bash opam install xs-toolstack + + # Install developer tools (utop, ocamlformat, ocaml-lsp-server, etc.) + opam install dev-tools + # Update the current switch. (You're already on the correct one, just refresh it). eval $(opam env) ``` @@ -73,6 +77,46 @@ To build xen-api from source, we recommend using [opam](https://opam.ocaml.org/d The binaries should now be in `./_build/install/default/bin`! +Working With Several Branches +----------------------------- + +When working on this repository as a regular contributor, one generally +has to work with several branches: the master branch and +lifecycle-management (LCM) branches. The following two recommendations +make such workflows easier: + +- Create one Opam switch per branch you work on. This is because + different branches of this repository may have different dependencies. + In particular, this means that different branches may have to get + their dependencies from different branches of the xs-opam repository. + As repository definitions are global to Opam rather than local to a + given switch, if a branch of this repository needs to get its + dependencies from a branch other than master in xs-opam, then that + other branch will have to be added with a different repository name + (see example below). + +- Use `git worktree` to make sure that different branches are checked + out at different locations on your file system. This is because + pinning makes it so that Opam expects certain dependencies to be + available at certain paths. When not using work trees, the same path + can refer to different versions of a same file as the checked out + branch changes. + +For instance, assuming the `26.1-lcm` branch, which takes its +dependencies from the 6.99-lcm branch of the xs-opam repository, has +been checked out in a Git work tree somewhere on your file system, here +is how to proceed to create an Opam switch that will work for this +branch: + +``` +export OCAML_VERSION_FULL="4.14.2" +opam switch create xen-api-26.1-lcm ocaml-base-compiler.$OCAML_VERSION_FULL +eval $(opam env --switch=xen-api-26.1-lcm --set-switch) +opam repo add xs-opam-6.99-lcm "https://github.com/xapi-project/xs-opam.git#6.99-lcm" +opam repo remove default +opam install xs-toolstack +``` + Working From a Fork ------------------- If you are working from within a clone of a fork of this repository, you will diff --git a/doc/content/design/external-auth-ldaps.md b/doc/content/design/external-auth-ldaps.md index cfdef048727..7e5f7db22df 100644 --- a/doc/content/design/external-auth-ldaps.md +++ b/doc/content/design/external-auth-ldaps.md @@ -91,9 +91,11 @@ Given `ldaps` default to `false`, this feature is **NOT** enabled until explicit #### 3.1.2 Error code Following new error codes added to indicate ldaps enable related error -- POOL_AUTH_ENABLE_FAILED_NO_CERTS, no certs can be used for ldaps, refer to 4.1.2 for certs finding. -- POOL_AUTH_ENABLE_FAILED_INVALID_CERTS, found certs, but none of the certs can be used to connect to DC -**Note**: Current error code handing infrustrucure requires the error code prefix with POOL_AUTH_ENABLE_FAILED +- `POOL_AUTH_ENABLE_FAILED_NO_TRUSTED_CERTS`: no trusted certs can be used for ldaps, refer to 4.1.2 for trusted certs finding. +- `POOL_AUTH_ENABLE_FAILED_INVALID_TRUSTED_CERTS`: found trusted certs, but none of the trusted certs can be used to connect to DC. +- `POOL_AUTH_ENABLE_FAILED_SETUP_TLS_CONNECTION`: failed to set up TLS connection to DC (e.g. GnuTLS handshake failure such as `tstream_tls_sync_setup: GNUTLS ERROR`). The error message contains the underlying details reported by winbind. + +**Note**: Current error code handling infrastructure requires the error code prefix with `POOL_AUTH_ENABLE_FAILED`. ### 3.2 Set/Get Pool LDAPS Status @@ -135,10 +137,11 @@ xe pool-external-auth-set-ldaps uuid= ldaps= #### 3.2.1.2 Error code This API may raise following errors -- AUTH_NO_CERTS, no certs found to enable ldaps, refer to 4.1.2 for certs finding -- AUTH_INVALID_CERTS, found certs, but none of the certs can be used to connect to DC -- AUTH_IS_DISABLED, AD is not enabled -- AUTH_SET_LDAPS_FAILED, Failed to set ldaps, the error message contains the details like ldap query on domain failed +- `AUTH_NO_TRUSTED_CERTS`: no trusted certs found to enable ldaps, refer to 4.1.2 for trusted certs finding. +- `AUTH_INVALID_TRUSTED_CERTS`: found trusted certs, but none of the trusted certs can be used to connect to DC. +- `AUTH_SETUP_TLS_CONNECTION`: failed to set up TLS CONNECTION to DC (e.g. GnuTLS handshake failure such as `tstream_tls_sync_setup: GNUTLS ERROR`). The error message contains the underlying details reported by winbind. +- `AUTH_IS_DISABLED`: AD is not enabled. +- `AUTH_SET_LDAPS_FAILED`: Failed to set ldaps, the error message contains the details like ldap query on domain failed. #### 3.2.2 Get Pool LDAPS Status @@ -268,10 +271,10 @@ alt precheck failed client-->>user: precheck failed end -Note over client,coor: sync all ldaps certs -client->>coor: pool.download_trusted_certificate -coor-->>client: -client->>join: pool.install_trusted_certificate +Note over client,coor: sync trusted CA certs from coordinator to joining host +client->>join: pool.sync_trusted_certificates_from +join->>coor: pool.exchange_trusted_certificates_on_join +coor-->>join: join-->>client: user->>client: join domain username/password @@ -289,15 +292,11 @@ client-->>user: pool.join succeed **Detailed Steps:** -1. Client find proper `ldaps certs` from pool coordinator as `certs_pool` - - a. find all certs `ldaps in purpose` - - b. if no LDAPS certs, find all `general` certs -2. Client find all certs in joining host as `certs_joining_host` -3. Client identify the certs needs to be synced to joining host as `certs_to_sync = certs_pool - certs_joining_host` (certs in `certs_pool`, but not in `certs_joining_host`), the certs fingerprint should be used to identify the certs -4. Client download all `certs_to_sync`, `pool.download_trusted_certificate` from coordinator -5. Client upload all certs to joining pool, `pool.install_trusted_certificate` to joining pool, with the same purpose -6. Client trigger `pool.join` again with domain username and password -7. After pool.join: +1. Client calls `pool.sync_trusted_certificates_from` to joiner host. The call will + - a. download all trusted certificates from the pool, and + - b. install the trusted certificates into the joiner host. +2. Client trigger `pool.join` again with domain username and password +3. After pool.join: - If pool.join failed, Client call `pool.uninstall_trusted_certificate` on joining host to revert the certs - If pool.join succeed, do nothing as pool.join would sync the certs anyway diff --git a/doc/content/design/migration-tls.md b/doc/content/design/migration-tls.md new file mode 100644 index 00000000000..04167ce971c --- /dev/null +++ b/doc/content/design/migration-tls.md @@ -0,0 +1,265 @@ +--- +title: Migration Stream Encryption with kernel TLS (kTLS) +layout: default +design_doc: true +revision: 1 +status: proposed +--- +# Migration Stream Encryption with kernel TLS (kTLS) + +VM-migrate sends the guest memory over a TLS connection so the data is +encrypted on the wire. Today that TLS is provided by stunnel, an external +process. This document describes an alternative that keeps the same TLS +security but removes stunnel from the sender's data path, using the kernel's +own TLS (kTLS), and so makes vm-migrate and host-evacuate faster. + +## Existing transport: stunnel + +stunnel is an external process that terminates TLS for the xenguest migration +stream. As it is a separate process from xenguest, the dom0 kernel has to pipe +the plaintext between the two, so every byte of guest RAM is copied through an +extra userspace hop and encrypted in userspace. That wastes dom0 cpu and memory +throughput, so the result is a slower vm-migrate, and therefore a slower +host-evacuate for the user. The slowdown is worst exactly when dom0 cpu is the +bottleneck. + +stunnel cannot be removed by linking it into xenguest, as it is not a library: +it is a configuration wrapper around OpenSSL. + +## Solution: kTLS on the sender + +The data pipe between xenguest and stunnel disappears if the kernel does the +bulk TLS encryption in place, on the same socket xenguest already writes to. +Linux 6.6 supports this through kTLS: once the symmetric key is installed on a +socket with `setsockopt(SOL_TLS, ...)`, the kernel encrypts/decrypts every +subsequent `read`/`write` transparently, using AES-NI, producing the same +byte stream stunnel produces today. + +Phase 1 changes only the sender host and already provides the speed-up (see +Performance), while proving the kTLS sender interoperates with the unchanged +stunnel receiver on the destination. Benefits: + +* significant speed-up: host-evacuate is around 1.5x faster for 10 parallel + VMs, for less dom0 cpu (see Performance). +* xenguest is unmodified: no libssl in xenguest, so no extra xen-devel + upstreaming, maintenance or security reviews on xenguest/libxenguest. +* same TLS security as stunnel: a small `ktls-helper` does the OpenSSL + handshake with the same key size, cipher, certificate and verification stunnel + uses, then asks the kernel to take over the bulk encryption. +* backwards-compatible & conservative: stunnel stays the default; kTLS is an + option, introduced gradually until it is proven in the field. + +## Principles + +* P1. kernel data pipes between userspace processes add latency and cut data + throughput in dom0. +* P2. keep the existing security guarantees. +* P3. backwards-compatibility. +* P4. guarded new features. + +## Use cases + +* U1. Admin configuration: + * U1.1. a new `migration_ktls` option selects the faster datapath for + vm-migrate and host-evacuate (P1, P2). + * U1.2. the option can be reverted to the original stunnel datapath (P3). +* U2. Admin usage when the option is selected: + * U2.1. vm-migrate is faster, or at least the same (P1). + * U2.2. host-evacuate is faster, or at least the same (P1). + * U2.3. vm-migrate and host-evacuate still work between hosts configured + with different options (P3). +* U3. Over time the option may graduate to become the default for vm-migrate + and host-evacuate (P4). + +## Requirements + +* R1. Admin configuration: + * R1.1.1. Host-level: `xe-enable-experimental-feature migration_ktls` sets + `/etc/xenserver/features.d/migration_ktls` to 1 on the host, enabling the + option there. + * R1.1.2. Pool-level: when every host has the entry, the matching + `restrict_migration_ktls` shown by `xe pool-list params=restrictions` + reads `false`. + * R1.1.3. Pool-level (future): a helper `xe pool-experimental-feature-set + name=migration_ktls` sets the entry on each host of the pool. +* R2. Admin usage: + * R2.1. vm-migrate: when the option is enabled, xenopsd uses + `ktls-helper` instead of stunnel to set up kTLS transport for + xenguest (see Design). + * R2.2. host-evacuate: the vm-migrate operations it drives inherit R2.1. +* R3. Future: once kTLS is the default, a XenAPI field + `pool.migration_transport` could expose `ktls` (default) or `stunnel`. + +Implementation note: R1.1.1 describes the intended activation. The current +implementation does not yet read `features.d/migration_ktls`; it selects the +transport per host from `xenopsd.conf` instead: + +``` +migration-tls = "ktls" # use the helper +migration-tls = "stunnel" # explicit default +migration-tls = "" # currently defaults to "stunnel" +``` + +Wiring `xe-enable-experimental-feature migration_ktls` to this `xenopsd.conf` +option (so the host flag drives R1.1.1/R1.1.2) is outstanding. + +## Design + +### Considered designs + +The goal is to remove the plaintext data pipe between stunnel and xenguest. + +| Design | Summary | Analysis | +| --- | --- | --- | +| A: TLS inside xenguest/libxenguest | link libssl into xenguest; xenguest does `SSL_connect`/`SSL_accept` and `SSL_read`/`SSL_write` directly. Needs an SNI dispatcher (eg. sniproxy) on the receiver to share port 443. | Removes the pipe, but embeds TLS in xenguest: lots of changes, lots of xen-devel upstreaming, and ongoing security-maintenance on xenguest/libxenguest. Too expensive to create and maintain. | +| B: xenguest as a stunnel SNI backend | use stunnel's SNI dispatch to route migration traffic to xenguest. | Easy (stunnel config only), but the plaintext pipe between stunnel and the backend remains, so it defeats the goal. | +| C: kTLS via a small TLS helper | `ktls-helper` does the OpenSSL handshake, asks OpenSSL to enable kTLS on the socket, and hands the kTLS socket fd to xenopsd over SCM_RIGHTS. xenguest then sees only plaintext; the kernel encrypts transparently. | xenguest is unmodified, stunnel leaves the sender data path, the helper reuses stunnel's OpenSSL config/keys/certificates, and kTLS can later be offloaded to hardware NICs. | + +Conclusion: design C (kTLS) seems superior, as it reaches the goal with fewer +changes, is toolstack-only (no xen-devel upstream loop, no future xenguest +security maintenance), is a small focused tool rather than a change to the +highly-complex xenguest, leaves the stunnel option in place, and opens the way +to kTLS hardware offload later. + +### kTLS sender + +Performance: the kernel encrypts the migration stream in the xenguest context, +so dom0 no longer copies the whole guest RAM between xenguest and stunnel. The +effect is largest where dom0 cpu, not the wire, is the bottleneck. + +Security: the helper uses OpenSSL exactly as stunnel does, so the bulk kTLS +stream is byte-identical to stunnel's and is accepted by the unchanged +destination stunnel. + +* same handshake: TLS 1.2, with the cipher list and ECDHE curve taken from the + pool TLS policy (`Stunnel.Openssl`, the same source the stunnel client reads), + renegotiation disabled, authenticated with `SSL_VERIFY_PEER` + against the destination's pool-internal certificate (CN = host uuid, + SNI = `pool`). +* single source of truth: the helper's verification is derived from the same + configuration the stunnel fallback would use, so `--cert-bundle-file`/`--sni` come from it + and `--no-verify` is sent only when verification is disabled pool-wide. SNI is + always sent, so the destination serves its pool-internal certificate either + way. +* the TLS 1.2 pin is necessary for kTLS, as a TLS 1.3 post-handshake + KeyUpdate cannot be carried by the kernel kTLS data path. +* no new security code in xenguest: after the handshake OpenSSL installs the + symmetric key in the kernel, and everything xenguest writes as plaintext is + encrypted transparently. +* the helper hands the socket over only after confirming the kernel actually + enabled kTLS in both directions (`BIO_get_ktls_send` and `BIO_get_ktls_recv`), + as the migration channel is bidirectional; otherwise it errors and the sender + falls back to stunnel. + +Backwards-compatibility: the new behaviour is hidden behind the per-host option, +and a kTLS sender works with a stunnel receiver, so the worst case is exactly +today's behaviour. + +### The helper + +`ktls-helper` does only what stunnel cannot, then gets out of the way: + +1. perform the TLS handshake with OpenSSL (same protocol/cipher/cert/verification + as stunnel). +2. ask OpenSSL to enable kTLS on the socket. +3. confirm the kernel took over send and receive (`BIO_get_ktls_send`/`_recv`); + if not, error so the sender falls back to stunnel. +4. hand the now-encrypting socket to xenopsd over SCM_RIGHTS, then exit. + +The helper is not a proxy and is not in the data path: it is a short-lived "set +up the encrypted socket, hand it over, get out of the way" step. xenopsd brokers +the fd to xenguest just as it brokers the stunnel fd today, and xenguest writes +the migration stream as plaintext while the kernel encrypts each `write` in +place. + +### Why stunnel cannot remove the data pipe + +stunnel is a general-purpose TLS proxy, and a proxy must receive plaintext on +one side to encrypt it on the other, so the xenguest -> stunnel plaintext hop is +structural and cannot be removed while stunnel is in the path. stunnel has no +pass-through mode and cannot hand its encrypted socket to another process, so its +bulk encryption stays in userspace. + +An alternative considered but rejected was to make stunnel use kTLS and then pull +its kernel-encrypting socket out of the stunnel process with `pidfd_getfd(2)`. +This has lots of issues: it needs ptrace-level privilege over stunnel and racy +fd-table scraping; there is no clean ownership handoff, as the TLS sequence +number and any partial record are per-socket and two writers corrupt the stream; +and nobody owns the TLS control path, so an inbound TLS 1.3 KeyUpdate stalls the +receive side. The safe form of "hand a kTLS socket to the datapath" is precisely +the dedicated helper above. + +## Performance + +Single host-evacuate, 10 VMs migrating in parallel, sender kTLS vs sender +stunnel, same host pair. The hosts have Intel Xeon Gold 6430 cpus (128 pCPU, +16 dom0 vCPUs) on a 25 GbE link, and each guest is Windows Server 2019 with +64 GB RAM and 12 vCPUs. The improvement grows with guest load, as a busier +guest has more memory to transmit and pushes dom0 cpu harder: + +| Guest load | stunnel | kTLS | Improvement | +| --- | --- | --- | --- | +| idle | 185s | 163s | 1.13x | +| medium (windows apps) | 249s | 171s | 1.46x | +| high (synthetic page thrasher) | 1341s | 835s | 1.60x | + +host-evacuate improvement is around 1.5x for 10 parallel VMs, for +lower dom0 cpu (eg. on the medium load, mean dom0 cpu drops from ~0.73 to ~0.53 +of the 16 dom0 vCPUs). The improvement is smaller for idle guests, as dom0 is +then not the bottleneck. + +## Implementation + +The sender path is in xenopsd. Outside the helper itself, the change is small: + +* `ocaml/ktls-helper/helper/` — the standalone C helper, with its + Makefile and README. It is built on its own (`make`) and deployed to + `/usr/libexec/xapi/ktls-helper`. +* `ocaml/xenopsd/lib/migrate_connect.ml` — a drop-in replacement for + `Open_uri.with_open_uri` that spawns the helper when `migration-tls = "ktls"` + and falls back to `Open_uri` otherwise. +* `ocaml/xenopsd/lib/xenops_server.ml` — the three migration fd call sites + (vm, mem, vgpu) in the `VM_migrate` branch go through `Migrate_connect`. +* `ocaml/xenopsd/lib/xenopsd.ml`, `ocaml/xenopsd/xc/xc_resources.ml`, + `ocaml/xenopsd/xenopsd.conf` — register the `migration-tls` option and the + `xenopsd-tls-helper` resource, and document them. + +Fallback: the sender falls back to stunnel only when the kTLS path fails to +produce the fd (helper spawn, TLS handshake, kTLS install or SCM_RIGHTS). It logs +a single warn line and uses stunnel for that one connection, so the migration +still proceeds. Once the fd is handed to the migration, any later exception is a +migration-layer failure and propagates unchanged, as silently retrying it over a +fresh stunnel socket would re-enter the in-progress receive on the destination +and corrupt its state. + +## Upgrade + +The kTLS sender produces the same TLS stream as stunnel and the receiver is +unchanged, so a kTLS-enabled host migrates to a stunnel host with no +coordination. xapi only permits migration from older to newer toolstacks, so a +newer kTLS sender is never required by an older receiver. The option is off by +default, so an upgrade changes nothing until an admin enables it. + +## Applicability + +Phase 1 covers the sender side of the guest-memory migration stream (the vm, +mem and vgpu fds in `VM_migrate`). It leaves the receiver and the other TLS +users unchanged: SMAPIv1 storage migration uses `sparse_dd` and SMAPIv3 uses +stunnel, both untouched, as are RRD and other stunnel traffic. Phase 2 (the +kTLS receiver) would extend the same treatment to the destination. + +## Outlook + +* Phase 2: a kTLS receiver, so the destination also drops stunnel from the data + path. It needs an SNI dispatcher (eg. sniproxy) to share port 443 between the + receiver and the existing stunnel endpoint. +* kTLS hardware-offload NICs (`CONFIG_TLS_DEVICE=y` in kernel) could move the bulk + encryption off the cpu. This depends on the NIC and the network topology: the + offload applies where the migration socket terminates in a TLS-capable NIC (for + example a raw or bonded NIC), but not where the traffic is bridged (kernel or Open + vSwitch). The gain grows with line rate: at 100 GbE and above, software AES-GCM + (even with AES-NI/AVX2 or VAES/AVX-512) becomes the bottleneck on a single core. +* `pool.migration_transport` (R3) once kTLS becomes the default. +* mutual TLS (client-certificate auth) and destination-hostname pinning exceed + the stunnel migration client and can be done with the Phase 2 receiver work. + diff --git a/doc/content/design/rate_limit.md b/doc/content/design/rate_limit.md index 69813b4ef66..e486d732ce8 100644 --- a/doc/content/design/rate_limit.md +++ b/doc/content/design/rate_limit.md @@ -2,8 +2,8 @@ title: Rate Limiting layout: default design_doc: true -revision: 2 -status: draft +revision: 3 +status: confirmed --- @@ -172,13 +172,21 @@ code by storing direct references to objects where possible. ### API functions We define the following API functions for the caller datamodel: -- `Caller.create(name_label, name_description, user_agent, client_ip)`: Create a new caller. -- `Caller.set_name_label(caller, name_label)`: Set name label on the caller -- `Caller.destroy(caller)`: Destroy the caller -- `Caller.add_group(caller, group)`: Add caller to group -- `Caller.remove_group(caller, group)`: Remove caller from group -- `Caller.query_usage(caller, time_period)`: Obtain usage statistics for an individual caller -- `Caller.query_group_usage(group, time_period)`: Obtain usage statistics for a group of callers +- `Caller.create`/`Caller.destroy`: Auto-generated constructor and destructor + for callers. +- `Caller.add_group(self, group)`: Add a caller to a group. +- `Caller.remove_group(self, group)`: Remove a caller from a group. +- `Caller.query_token_usage(self)`: Return tokens used by this caller since Xapi + startup. +- `Caller.query_call_count(self)`: Return number of calls made by this caller + since Xapi startup. +- `Caller.query_group_token_usage(group)`: Return tokens used since Xapi startup + by the callers in the named group. +- `Caller.query_group_call_count(group)`: Return number of calls made since Xapi + startup by the callers in the named group. +- `Caller.query_all_usage()`: Return per-caller usage (rows of `[uuid; + name_label; tokens; calls]`) for every known caller, sorted by token use + descending. And the following functions for the rate limiter datamodel: - `Rate_limit.create(name_label, callers, burst_size, fill_rate)`: Create a diff --git a/doc/content/design/snapshot-revert.md b/doc/content/design/snapshot-revert.md index e0144039535..78053aa845e 100644 --- a/doc/content/design/snapshot-revert.md +++ b/doc/content/design/snapshot-revert.md @@ -16,12 +16,12 @@ the contents of that disk and then use the new clone as the storage for the VM. Because `VDI.clone` creates new VDI refs and uuids, some problematic behaviours arise: -- Clients such as +- Clients such as [Apache CloudStack](http://cloudstack.apache.org) need to include complex logic to keep track of the disks they are actively managing - Because the snapshot is cloned and the original vdi is deleted, VDI references to the VDI become invalid, like `VDI.snapshot_of`. This means - that the database has to be combed through to change these references. + that the database has to be combed through to change these references. Because the database doesn't support transactions this operation is not atomic and can produce inconsistent database states. @@ -46,7 +46,7 @@ We will fix these problems by: ## Current VM.revert behaviour -The code that reverts the state of storage is located in +The code that reverts the state of storage is located in [update_vifs_vbds_vgpus_and_vusbs](https://github.com/xapi-project/xen-api/blob/bc0ba4e9dc8dc4b85b7cbdbf3e0ba5915b4ad76d/ocaml/xapi/xapi_vm_snapshot.ml#L211). The steps it does is: 1. destroys the VM's VBDs (both disks and CDs) @@ -94,9 +94,9 @@ The function `vdi_revert` is defined with the following arguments: - in: `sr_uuid`: the UUID of the SR containing both the VDI and the snapshot - in: `vdi_uuid`: the UUID of the snapshot whose contents must be duplicated -- in: `target_uuid`: the UUID of the target whose contents must be replaced +- in: `target_ref`: reference of the target VDI whose contents must be replaced -The function will replace the contents of the `target_uuid` VDI with the +The function will replace the contents of the `target_ref` VDI with the contents of the `vdi_uuid` VDI without changing the identify of the target (i.e. name-label, uuid and location are guaranteed to remain the same). The `vdi_uuid` is preserved by this operation. The operation is obvoiusly diff --git a/doc/content/xen-api/overview/index.md b/doc/content/xen-api/overview/index.md index 042ef6088b2..8c259a12ce8 100644 --- a/doc/content/xen-api/overview/index.md +++ b/doc/content/xen-api/overview/index.md @@ -40,21 +40,42 @@ The next step is to query the list of "templates" on the host. Templates are spe Now that we have a snapshot of all the VM objects' field values in the memory of our client application we can simply iterate through them and find the ones that have their "`is_a_template`" set to true. At this stage let's assume that our example application further iterates through the template objects and remembers the reference corresponding to the one that has its "`name_label`" set to "Debian Etch 4.0" (one of the default Linux templates supplied with XenServer). +### Choosing a Storage Repository for the VM's disks + +As mentioned above, templates generally embody software stored on +virtual disk images. Creating a VM from a template thus involves, in +particular, creating copies of the templates' disk images that will be +available for the VM to use. + +These copies need to be stored somewhere and, in Xen-API +terminology, a place where **Virtual Disk Images** (VDIs) are stored is +called a **Storage Repository**. + +Just as we had to list templates in order to choose one to use as a basis +for the VM, we need to list the available Storage Repositories and +pick one. We do so by calling `SR.get_all_records(session)`. + +Let's assume this call returns a non-empty list of Storage +Repositories and choose one of them, whose reference is stored in +`my_sr_ref`. This reference will be used in the next step when +specifying where to store the VM's VDIs by default. + ### Installing the VM based on a template -Continuing through our example, we must now install a new VM based on the template we selected. The installation process requires 4 API calls: +Continuing through our example, we now wanto to install a new VM based on the template we selected. The installation process requires 4 API calls: -- First we must now invoke the API call `VM.clone(session, t_ref, "my first VM")`. This tells the server to clone the VM object referenced by `t_ref` in order to make a new VM object. The return value of this call is the VM reference corresponding to the newly-created VM. Let's call this `new_vm_ref`. +- First we must invoke the API call `VM.clone(session, t_ref, "my first VM")`. This tells the server to clone the VM object referenced by `t_ref` in order to make a new VM object. The return value of this call is the VM reference corresponding to the newly-created VM. Let's call this `new_vm_ref`. -- Next, we need to specify the UUID of the Storage Repository where the VM's - disks will be instantiated. We have to put this in the `sr` attribute in +- Next, we need to specify the UUID of the Storage + Repository where the VM's disks will be stored by + default. We do so by putting `my_sr_ref` in the `sr` attribute in the disk provisioning XML stored under the "`disks`" key in the `other_config` map of the newly-created VM. This field can be updated by calling its getter (`other_config <- VM.get_other_config(session, new_vm_ref)`) and then its setter (`VM.set_other_config(session, new_vm_ref, other_config)`) with the modified `other_config` map. -- At this stage the object referred to by `new_vm_ref` is still a template (just like the VM object referred to by `t_ref`, from which it was cloned). To make `new_vm_ref` into a VM object we need to call `VM.provision(session, new_vm_ref)`. When this call returns the `new_vm_ref` object will have had its `is_a_template` field set to false, indicating that `new_vm_ref` now refers to a regular VM ready for starting. +- At this stage the object referred to by `new_vm_ref` is still a template (just like the VM object referred to by `t_ref`, from which it was cloned). To make `new_vm_ref` into a VM object we need to call `VM.provision(session, new_vm_ref)`. When this call returns, the `new_vm_ref` object will have had its `is_a_template` field set to false, indicating that `new_vm_ref` now refers to a regular VM ready for starting. > **Note** > @@ -94,6 +115,8 @@ We have seen how the API can be used to install a VM from a XenServer template a - One call to query the VM (and template) objects present on the XenServer installation: `VM.get_all_records()`. Recall that we used the information returned from this call to select a suitable template to install from. +- One call to list the Storage Repositories: `SR.get_all_records()`. + - Four calls to install a VM from our chosen template: `VM.clone()`, followed by the getter and setter of the `other_config` field to specify where to create the disk images of the template, and then `VM.provision()`. diff --git a/dune-project b/dune-project index 7fb1ad9fc89..31bb6812d5c 100644 --- a/dune-project +++ b/dune-project @@ -53,6 +53,23 @@ (synopsis "Thread group management library") (depends xapi-log xapi-stdext-unix)) +(package + (name xapi-rate-limit) + (synopsis "A simple token bucket-based rate limter for XAPI") + (depends + (ocaml (>= 4.12)) + (clock + (= :version)) + mtime + (xapi-log + (= :version)) + (xapi-stdext-threads + (= :version)) + (alcotest :with-test) + (fmt :with-test) + (qcheck-core :with-test) + (qcheck-alcotest :with-test))) + (package (name xml-light2)) @@ -177,6 +194,8 @@ (= :version)) (xapi-idl (= :version)) + (xapi-rate-limit + (= :version)) (xapi-types (= :version)) (xapi-stdext-zerocheck @@ -328,6 +347,7 @@ x509 xapi-log xapi-types + xapi-rate-limit xapi-stdext-pervasives xapi-stdext-unix xapi-stdext-zerocheck @@ -472,6 +492,8 @@ (= :version)) (xapi-log (= :version)) + (xapi-rate-limit + (= :version)) (xapi-stdext-pervasives (= :version)) (xapi-stdext-std diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index 9419ad74af1..96676b8ea83 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -3831,6 +3831,48 @@ module VIF = struct ] ~allowed_roles:_R_VM_OP () + let add_trunks = + call ~name:"add_trunks" ~lifecycle:[] + ~doc:"Associates a 802.1Q VLAN with this VIF" + ~params: + [ + ( Ref _vif + , "self" + , "The VIF which the 802.1Q VLAN will be associated with" + ) + ; (Int, "value", "The 802.1Q VLAN which will be associated with the VIF") + ] + ~allowed_roles:_R_VM_ADMIN () + + let remove_trunks = + call ~name:"remove_trunks" ~lifecycle:[] + ~doc:"Removes a 802.1Q VLAN from this VIF" + ~params: + [ + ( Ref _vif + , "self" + , "The VIF from which the 802.1Q VLAN will be removed" + ) + ; (Int, "value", "The 802.1Q VLAN which will be removed from the VIF") + ] + ~allowed_roles:_R_VM_ADMIN () + + let set_trunks = + call ~name:"set_trunks" ~lifecycle:[] + ~doc:"Set the 802.1Q VLANs to which traffic on this VIF can be restricted" + ~params: + [ + ( Ref _vif + , "self" + , "The VIF which the 802.1Q VLANs will be associated with" + ) + ; ( Set Int + , "value" + , "The 802.1Q VLANs which will be associated with the VIF" + ) + ] + ~allowed_roles:_R_VM_ADMIN () + (** A virtual network interface *) let t = create_obj ~in_db:true @@ -3854,6 +3896,9 @@ module VIF = struct ; remove_ipv6_allowed ; configure_ipv4 ; configure_ipv6 + ; add_trunks + ; remove_trunks + ; set_trunks ] ~contents: ([ @@ -4044,6 +4089,10 @@ module VIF = struct ~internal_only:true ~qualifier:DynamicRO "reserved_pci" "pci of network SR-IOV VF which is reserved for this vif" ~default_value:(Some (VRef null_ref)) + ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:(Set Int) + ~default_value:(Some (VSet [])) "trunks" + "the 802.1Q VLANs that this port trunks (if available) ; if it \ + is empty, then the port trunks all VLANs." ] ) () @@ -5371,6 +5420,10 @@ module VDI = struct , rel_inverness , "Online VDI resize is not supported by any of the storage backends." ) + ; ( Published + , "26.16.1-next" + , "Reintroduced to allow online resize of a VDI whose SR supports it" + ) ] ~params: [ @@ -10609,6 +10662,8 @@ let all_system = ; Datamodel_vm_group.t ; Datamodel_host_driver.t ; Datamodel_driver_variant.t + ; Datamodel_caller.t + ; Datamodel_rate_limit.t ] (* If the relation is one-to-many, the "many" nodes (one edge each) must come before the "one" node (many edges) *) @@ -10702,6 +10757,7 @@ let all_relations = ; ((_certificate, "host"), (_host, "certificates")) ; ((_vm, "groups"), (_vm_group, "VMs")) ; ((_driver_variant, "driver"), (_host_driver, "variants")) + ; ((_caller, "rate_limit"), (_rate_limit, "callers")) ] let update_lifecycles = @@ -10860,6 +10916,8 @@ let expose_get_all_messages_for = ; _observer ; _host_driver ; _driver_variant + ; _caller + ; _rate_limit ] let no_task_id_for = [_task; (* _alert; *) _event] @@ -11216,6 +11274,11 @@ let http_actions = ; ("put_bundle", (Put, Constants.put_bundle_uri, true, [], _R_POOL_OP, [])) ] +(* Actions that incorporate the rate limiter from Xapi_rate_limiting within + their handler - handlers not listed here get rate limited when accessed *) +let custom_rate_limit_http_actions = + ["post_root"; "post_RPC2"; "post_jsonrpc"; "post_cli"] + (* these public http actions will NOT be checked by RBAC *) (* they are meant to be used in exceptional cases where RBAC is already *) (* checked inside them, such as in the XMLRPC (API) calls *) diff --git a/ocaml/idl/datamodel_caller.ml b/ocaml/idl/datamodel_caller.ml new file mode 100644 index 00000000000..cf7dd897834 --- /dev/null +++ b/ocaml/idl/datamodel_caller.ml @@ -0,0 +1,131 @@ +(* + * Copyright (C) Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Datamodel_types +open Datamodel_common +open Datamodel_roles + +let lifecycle = [] + +let add_group = + call ~name:"add_group" ~doc:"Add a caller to a group" ~in_oss_since:None + ~lifecycle + ~params: + [ + (Ref _caller, "self", "The caller to update") + ; (String, "group", "Group the caller is being added to") + ] + ~allowed_roles:_R_POOL_OP () + +let remove_group = + call ~name:"remove_group" ~doc:"Remove a caller from a group" + ~in_oss_since:None ~lifecycle + ~params: + [ + (Ref _caller, "self", "The caller to update") + ; (String, "group", "Group the caller is removed from") + ] + ~allowed_roles:_R_POOL_OP () + +let query_token_usage = + call ~name:"query_token_usage" + ~doc:"Return tokens used by this caller since Xapi startup" + ~in_oss_since:None ~lifecycle + ~params:[(Ref _caller, "self", "The caller to query")] + ~result:(Float, "Tokens used by the caller since Xapi startup") + ~allowed_roles:_R_POOL_OP () + +let query_call_count = + call ~name:"query_call_count" + ~doc:"Return number of calls made by this caller since Xapi startup" + ~in_oss_since:None ~lifecycle + ~params:[(Ref _caller, "self", "The caller to query")] + ~result:(Int, "Calls made by the caller since Xapi startup") + ~allowed_roles:_R_POOL_OP () + +let query_group_token_usage = + call ~name:"query_group_token_usage" + ~doc: + "Return tokens used since Xapi startup by the callers in the named group." + ~in_oss_since:None ~lifecycle + ~params:[(String, "group", "Caller group to aggregate over")] + ~result:(Float, "Tokens used by the group since Xapi startup") + ~allowed_roles:_R_POOL_OP () + +let query_group_call_count = + call ~name:"query_group_call_count" + ~doc: + "Return number of calls made since Xapi startup by the callers in the \ + named group." + ~in_oss_since:None ~lifecycle + ~params:[(String, "group", "Caller group to aggregate over")] + ~result:(Int, "Number of calls made by the callers in the group") + ~allowed_roles:_R_POOL_OP () + +let query_all_usage = + call ~name:"query_all_usage" + ~doc: + "Return per-caller usage for every known caller, sorted by token use \ + descending." + ~in_oss_since:None ~lifecycle ~params:[] + ~result: + ( Set (Set String) + , "Rows of [uuid; name_label; tokens; calls], highest tokens first" + ) + ~allowed_roles:_R_POOL_OP () + +let t = + create_obj ~name:_caller ~descr:"XAPI caller description and rate limiting" + ~doccomments:[] ~gen_constructor_destructor:true ~gen_events:true + ~in_db:true ~lifecycle ~persist:PersistEverything ~in_oss_since:None + ~messages_default_allowed_roles:_R_POOL_ADMIN + ~contents: + [ + uid _caller ~lifecycle + ; namespace ~name:"name" ~contents:(names None RW ~lifecycle) () + ; field ~qualifier:StaticRO ~ty:String ~lifecycle "user_agent" + "User agent matching pattern. Empty string is a full wildcard; a \ + trailing '*' makes the field a prefix pattern; otherwise the field \ + is matched exactly." + ~default_value:(Some (VString "")) + ; field ~qualifier:StaticRO ~ty:String ~lifecycle "client_ip" + "Client IP matching pattern. Same wildcard semantics as user_agent." + ~default_value:(Some (VString "")) + ; field ~qualifier:DynamicRO ~ty:DateTime ~lifecycle "last_access" + "Last time a call was received from this caller" + ~default_value:(Some (VDateTime Date.epoch)) + ; field ~qualifier:DynamicRO ~ty:(Set String) ~lifecycle "groups" + "Groups to which this caller has been assigned" + ~default_value:(Some (VSet [])) + ; field ~qualifier:DynamicRO ~ty:(Ref _rate_limit) ~lifecycle "rate_limit" + "Rate limiter attached to this caller, if any. Populated via \ + Rate_limit.add_caller rather than set directly." + ~default_value:(Some (VRef null_ref)) + ; field ~qualifier:DynamicRO ~ty:Bool ~lifecycle "auto_registered" + "True if this caller was created automatically by the rate limiter \ + rather than by an administrator. Auto-registered callers are \ + subject to the max-auto-registered-callers cap." + ~default_value:(Some (VBool false)) + ] + ~messages: + [ + add_group + ; remove_group + ; query_token_usage + ; query_call_count + ; query_group_token_usage + ; query_group_call_count + ; query_all_usage + ] + () diff --git a/ocaml/idl/datamodel_certificate.ml b/ocaml/idl/datamodel_certificate.ml index c90e898d274..75d78bb9aa7 100644 --- a/ocaml/idl/datamodel_certificate.ml +++ b/ocaml/idl/datamodel_certificate.ml @@ -37,7 +37,13 @@ let certificate_type = let certificate_purpose = Enum ( "certificate_purpose" - , [("licensing", "Trusted certificates that are for licensing purpose.")] + , [ + ("licensing", "Trusted certificates that are for licensing purpose.") + ; ( "ldaps" + , "Trusted certificates that are for LDAPS connections to external \ + authentication services." + ) + ] ) let t = diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 30acd66f305..211fc92daed 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/ocaml/idl/datamodel_common.ml @@ -10,7 +10,7 @@ open Datamodel_roles to leave a gap for potential hotfixes needing to increment the schema version.*) let schema_major_vsn = 5 -let schema_minor_vsn = 906 +let schema_minor_vsn = 909 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 @@ -315,6 +315,10 @@ let _host_driver = "Host_driver" let _driver_variant = "Driver_variant" +let _caller = "Caller" + +let _rate_limit = "Rate_limit" + let update_guidances = Enum ( "update_guidances" diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 811c8d5da75..bcc8c4ed51e 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -230,6 +230,8 @@ let _ = ~doc:"The network is incompatible with bond" () ; error Api_errors.network_incompatible_with_tunnel ["network"] ~doc:"The network is incompatible with tunnel" () ; + error Api_errors.network_incompatible_with_trunks ["network"] + ~doc:"The network is incompatible with VIF using trunks." () ; error Api_errors.pool_joining_host_has_network_sriovs [] ~doc:"The host joining the pool must not have any network SR-IOVs." () ; @@ -392,8 +394,8 @@ let _ = error Api_errors.vlan_tag_invalid ["VLAN"] ~doc: - "You tried to create a VLAN, but the tag you gave was invalid -- it must \ - be between 0 and 4094. The parameter echoes the VLAN tag you gave." + "The VLAN tag you gave was invalid -- it must be between 0 and 4094. The \ + parameter echoes the VLAN tag you gave." () ; error Api_errors.network_contains_vif ["vifs"] ~doc:"The network contains active VIFs and cannot be deleted." () ; @@ -737,30 +739,64 @@ let _ = error Api_errors.auth_unknown_type ["type"] ~doc:"Unknown type of external authentication." () ; error Api_errors.auth_is_disabled [] - ~doc:"External authentication is disabled, unable to resolve subject name." + ~doc:"External authentication is disabled" () ; + error Api_errors.auth_invalid_trusted_certs ["message"] + ~doc: + "The trusted certificates are invalid to setup a TLS connection to \ + Active Directory." + () ; + error Api_errors.auth_no_trusted_certs ["message"] + ~doc: + "No trusted CA certificates found to setup a TLS connection to Active \ + Directory" () ; error Api_errors.auth_enable_failed ["message"] ~doc:"The host failed to enable external authentication." () ; error Api_errors.auth_enable_failed_wrong_credentials ["message"] - ~doc:"The host failed to enable external authentication." () ; + ~doc:"The host failed to enable external authentication, wrong credentials." + () ; error Api_errors.auth_enable_failed_permission_denied ["message"] - ~doc:"The host failed to enable external authentication." () ; + ~doc:"The host failed to enable external authentication, permission denied." + () ; error Api_errors.auth_enable_failed_domain_lookup_failed ["message"] ~doc:"The host failed to enable external authentication." () ; error Api_errors.auth_enable_failed_unavailable ["message"] ~doc:"The host failed to enable external authentication." () ; error Api_errors.auth_enable_failed_invalid_ou ["message"] - ~doc:"The host failed to enable external authentication." () ; + ~doc:"The host failed to enable external authentication, invalid OU." () ; error Api_errors.auth_enable_failed_invalid_account ["message"] - ~doc:"The host failed to enable external authentication." () ; + ~doc:"The host failed to enable external authentication, invalid account." + () ; + error Api_errors.auth_enable_failed_invalid_trusted_certs ["message"] + ~doc: + "The host failed to enable external authentication, invalid trusted \ + certificates." + () ; + error Api_errors.auth_enable_failed_no_trusted_certs ["message"] + ~doc: + "The host failed to enable external authentication, no trusted \ + certificates" + () ; error Api_errors.auth_disable_failed ["message"] ~doc:"The host failed to disable external authentication." () ; error Api_errors.auth_disable_failed_wrong_credentials ["message"] - ~doc:"The host failed to disable external authentication." () ; + ~doc: + "The host failed to disable external authentication, wrong credentials." + () ; error Api_errors.auth_disable_failed_permission_denied ["message"] - ~doc:"The host failed to disable external authentication." () ; + ~doc: + "The host failed to disable external authentication, permission denied." + () ; error Api_errors.host_evacuate_in_progress ["host"] ~doc:"This host is being evacuated." () ; + error Api_errors.host_evacuate_vm_not_ha_protected ["vm"] + ~doc: + "The host cannot be evacuated because HA is enabled on the pool and a VM \ + running on it is not HA-protected (its ha_restart_priority is not set \ + to 'restart'). Set the VM's ha_restart_priority to 'restart', shut down \ + or suspend the VM, or disable HA on the pool before evacuating the \ + host." + () ; (* Pool errors *) error Api_errors.pool_joining_host_cannot_contain_shared_SRs [] @@ -827,9 +863,11 @@ let _ = error Api_errors.pool_auth_enable_failed ["host"; "message"] ~doc:"The pool failed to enable external authentication." () ; error Api_errors.pool_auth_enable_failed_wrong_credentials ["host"; "message"] - ~doc:"The pool failed to enable external authentication." () ; + ~doc:"The pool failed to enable external authentication, wrong credentials." + () ; error Api_errors.pool_auth_enable_failed_permission_denied ["host"; "message"] - ~doc:"The pool failed to enable external authentication." () ; + ~doc:"The pool failed to enable external authentication, permission denied." + () ; error Api_errors.pool_auth_enable_failed_domain_lookup_failed ["host"; "message"] ~doc:"The pool failed to enable external authentication." () ; @@ -837,11 +875,42 @@ let _ = ~doc:"The pool failed to enable external authentication." () ; error Api_errors.pool_auth_enable_failed_duplicate_hostname ["host"; "message"] - ~doc:"The pool failed to enable external authentication." () ; + ~doc: + "The pool failed to enable external authentication, duplicate hostname." + () ; error Api_errors.pool_auth_enable_failed_invalid_ou ["host"; "message"] - ~doc:"The pool failed to enable external authentication." () ; + ~doc:"The pool failed to enable external authentication, invalid OU" () ; error Api_errors.pool_auth_enable_failed_invalid_account ["host"; "message"] - ~doc:"The pool failed to enable external authentication." () ; + ~doc:"The pool failed to enable external authentication, invalid account." + () ; + error Api_errors.pool_auth_enable_failed_invalid_trusted_certs + ["host"; "message"] + ~doc: + "The pool failed to enable external authentication, invalid trusted \ + certificates." + () ; + error Api_errors.pool_auth_enable_failed_no_trusted_certs ["host"; "message"] + ~doc: + "The pool failed to enable external authentication, no trusted \ + certificates." + () ; + error Api_errors.pool_auth_enable_failed_no_supp_encrypt_type + ["host"; "message"] + ~doc: + "The pool failed to enable external authentication: domain does not \ + support encryption type, make sure AES based encryption type is enabled \ + in kerberos authentication in AD and Administrator is not in use" + () ; + error Api_errors.pool_auth_enable_failed_setup_tls_connection + ["host"; "message"] + ~doc: + "The pool failed to enable external authentication, failed to set up TLS \ + connection." + () ; + error Api_errors.auth_setup_tls_connection ["message"] + ~doc:"Failed to set up TLS connection for external authentication." () ; + error Api_errors.auth_set_ldaps_failed ["host"; "message"] + ~doc:"The pool failed to set LDAPS configuration." () ; error Api_errors.pool_auth_disable_failed ["host"; "message"] ~doc: "The pool failed to disable the external authentication of at least one \ diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 016e59807bc..fa1d04729ea 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -2044,6 +2044,45 @@ let disable_external_auth = ~doc:"This call disables external authentication on the local host" ~allowed_roles:_R_POOL_ADMIN () +let external_auth_set_ldaps = + call ~flags:[`Session] ~name:"external_auth_set_ldaps" ~in_oss_since:None + ~lifecycle: + [ + ( Published + , "26.16.0" + , "This call enables or disables LDAPS for external authentication on \ + the host" + ) + ] + ~versioned_params: + [ + { + param_type= Ref _host + ; param_name= "host" + ; param_doc= "The host whose LDAPS configuration should be set" + ; param_release= numbered_release "26.16.0" + ; param_default= None + } + ; { + param_type= Bool + ; param_name= "ldaps" + ; param_doc= "Whether to enable or disable LDAPS" + ; param_release= numbered_release "26.16.0" + ; param_default= None + } + ; { + param_type= Bool + ; param_name= "force" + ; param_doc= "Force the operation even if already in the desired state" + ; param_release= numbered_release "26.16.0" + ; param_default= Some (VBool false) + } + ] + ~doc: + "This call enables or disables LDAPS for external authentication on the \ + host" + ~allowed_roles:_R_POOL_ADMIN () + let set_license_params = call ~name:"set_license_params" ~lifecycle: @@ -2829,6 +2868,7 @@ let t = ; disable_binary_storage ; enable_external_auth ; disable_external_auth + ; external_auth_set_ldaps ; retrieve_wlb_evacuate_recommendations ; install_ca_certificate ; uninstall_ca_certificate diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 23bb7239126..836c7ca1d9d 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -1,4 +1,8 @@ let prototyped_of_class = function + | "Rate_limit" -> + Some "26.17.0" + | "Caller" -> + Some "26.17.0" | "Driver_variant" -> Some "25.2.0" | "Host_driver" -> @@ -13,6 +17,36 @@ let prototyped_of_class = function None let prototyped_of_field = function + | "Rate_limit", "fill_rate" -> + Some "26.17.0" + | "Rate_limit", "burst_size" -> + Some "26.17.0" + | "Rate_limit", "callers" -> + Some "26.17.0" + | "Rate_limit", "name__description" -> + Some "26.17.0" + | "Rate_limit", "name__label" -> + Some "26.17.0" + | "Rate_limit", "uuid" -> + Some "26.17.0" + | "Caller", "auto_registered" -> + Some "26.17.0" + | "Caller", "rate_limit" -> + Some "26.17.0" + | "Caller", "groups" -> + Some "26.17.0" + | "Caller", "last_access" -> + Some "26.17.0" + | "Caller", "client_ip" -> + Some "26.17.0" + | "Caller", "user_agent" -> + Some "26.17.0" + | "Caller", "name__description" -> + Some "26.17.0" + | "Caller", "name__label" -> + Some "26.17.0" + | "Caller", "uuid" -> + Some "26.17.0" | "Driver_variant", "status" -> Some "25.2.0" | "Driver_variant", "priority" -> @@ -101,6 +135,8 @@ let prototyped_of_field = function Some "26.15.0" | "SM", "host_pending_features" -> Some "24.37.0" + | "VIF", "trunks" -> + Some "26.17.0" | "host", "timezone" -> Some "26.0.0" | "host", "ntp_custom_servers" -> @@ -159,6 +195,8 @@ let prototyped_of_field = function Some "23.18.0" | "VM", "actions__after_softreboot" -> Some "23.1.0" + | "pool", "auto_update_vm_secureboot_certificates" -> + Some "26.16.1" | "pool", "vm_console_idle_timeout" -> Some "26.1.0" | "pool", "limit_console_sessions" -> @@ -203,6 +241,28 @@ let prototyped_of_field = function None let prototyped_of_message = function + | "Rate_limit", "set_fill_rate" -> + Some "26.17.0" + | "Rate_limit", "set_burst_size" -> + Some "26.17.0" + | "Rate_limit", "remove_caller" -> + Some "26.17.0" + | "Rate_limit", "add_caller" -> + Some "26.17.0" + | "Caller", "query_all_usage" -> + Some "26.17.0" + | "Caller", "query_group_call_count" -> + Some "26.15.0" + | "Caller", "query_group_token_usage" -> + Some "26.15.0" + | "Caller", "query_call_count" -> + Some "26.15.0" + | "Caller", "query_token_usage" -> + Some "26.15.0" + | "Caller", "remove_group" -> + Some "26.17.0" + | "Caller", "add_group" -> + Some "26.17.0" | "Driver_variant", "select" -> Some "25.2.0" | "Host_driver", "rescan" -> @@ -252,7 +312,13 @@ let prototyped_of_message = function | "VTPM", "create" -> Some "22.26.0" | "VDI", "revert" -> - Some "26.15.0-next" + Some "26.16.0" + | "VIF", "set_trunks" -> + Some "26.17.0" + | "VIF", "remove_trunks" -> + Some "26.17.0" + | "VIF", "add_trunks" -> + Some "26.17.0" | "host", "set_servertime" -> Some "26.0.0" | "host", "get_ntp_synchronized" -> @@ -311,6 +377,8 @@ let prototyped_of_message = function Some "26.13.0" | "pool", "exchange_trusted_certificates_on_join" -> Some "26.13.0" + | "pool", "sync_trusted_certificates_from" -> + Some "26.16.0" | "pool", "uninstall_trusted_certificate" -> Some "26.13.0" | "pool", "install_trusted_certificate" -> diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index 26734a7846e..e9521e2cc88 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -660,6 +660,45 @@ let disable_external_auth = "This call disables external authentication on all the hosts of the pool" ~allowed_roles:_R_POOL_ADMIN () +let external_auth_set_ldaps = + call ~flags:[`Session] ~name:"external_auth_set_ldaps" ~in_oss_since:None + ~lifecycle: + [ + ( Published + , "26.16.0" + , "This call enables or disables LDAPS for external authentication on \ + all hosts in the pool" + ) + ] + ~versioned_params: + [ + { + param_type= Ref _pool + ; param_name= "pool" + ; param_doc= "The pool whose LDAPS configuration should be set" + ; param_release= numbered_release "26.16.0" + ; param_default= None + } + ; { + param_type= Bool + ; param_name= "ldaps" + ; param_doc= "Whether to enable or disable LDAPS" + ; param_release= numbered_release "26.16.0" + ; param_default= None + } + ; { + param_type= Bool + ; param_name= "force" + ; param_doc= "Force the operation even if already in the desired state" + ; param_release= numbered_release "26.16.0" + ; param_default= Some (VBool false) + } + ] + ~doc: + "This call enables or disables LDAPS for external authentication on all \ + hosts in the pool" + ~allowed_roles:_R_POOL_ADMIN () + let detect_nonhomogeneous_external_auth = call ~flags:[`Session] ~name:"detect_nonhomogeneous_external_auth" ~in_oss_since:None @@ -1663,6 +1702,36 @@ let uninstall_trusted_certificate = ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) ~lifecycle:[] () +let sync_trusted_certificates_from = + call ~name:"sync_trusted_certificates_from" + ~doc: + "Download trusted TLS certificates from a remote pool and install them \ + in this pool. Certificates already present locally (matched by \ + fingerprint and purpose) are skipped." + ~params: + [ + (Ref _pool, "self", "The pool") + ; ( String + , "remote_pool" + , "The hostname or IP address of the coordinator of the remote pool \ + from which the certificates are downloaded" + ) + ; ( Ref _session + , "remote_session" + , "A session obtained from the remote pool, used to authenticate the \ + download" + ) + ; ( String + , "remote_certificate" + , "The PEM-encoded TLS certificate of the remote pool's coordinator, \ + used to verify the TLS connection to the remote pool." + ) + ; (Bool, "ca", "true for 'ca' or false for 'pinned'") + ] + ~result:(Set (Ref _certificate), "The references of certificates synced.") + ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) + ~lifecycle:[] () + let trusted_certs = Map (String, Set String) let exchange_trusted_certificates_on_join = @@ -1752,6 +1821,7 @@ let t = ; disable_binary_storage ; enable_external_auth ; disable_external_auth + ; external_auth_set_ldaps ; detect_nonhomogeneous_external_auth ; initialize_wlb ; deconfigure_wlb @@ -1814,6 +1884,7 @@ let t = ; set_ssh_auto_mode ; install_trusted_certificate ; uninstall_trusted_certificate + ; sync_trusted_certificates_from ; exchange_trusted_certificates_on_join ; exchange_crls_on_join ] @@ -2358,6 +2429,19 @@ let t = means never timeout. This setting applies only to VM consoles; \ for host consoles, use the separate parameter \ 'host.console_idle_timeout'." + ; field ~writer_roles:_R_POOL_OP ~qualifier:RW ~lifecycle:[] ~ty:Bool + ~default_value:(Some (VBool false)) + "auto_update_vm_secureboot_certificates" + "When true, at VM.create time the pool automatically marks a newly \ + created VM whose Secure Boot certificates are due to expire by \ + setting VM.secureboot_certificates_state to update_on_boot (the \ + same effect as VM.update_secureboot_certificates_on_boot), so the \ + certificates are updated on the VM's next boot. This applies to \ + VMs created by VM.create, including those created by operations \ + that internally call it: the HTTP(s) PUT /import and \ + /import_metadata calls and disaster recovery (VM.recover and \ + VM_appliance.recover); it does not apply to VM.clone or VM.copy, \ + which inherit the source VM's state." ] ) () diff --git a/ocaml/idl/datamodel_rate_limit.ml b/ocaml/idl/datamodel_rate_limit.ml new file mode 100644 index 00000000000..5ef8672b537 --- /dev/null +++ b/ocaml/idl/datamodel_rate_limit.ml @@ -0,0 +1,85 @@ +(* + * Copyright (C) Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Datamodel_types +open Datamodel_common +open Datamodel_roles + +let lifecycle = [] + +let add_caller = + call ~name:"add_caller" + ~doc: + "Attach the given caller to this rate limiter. Replaces any rate limiter \ + previously attached to the caller." + ~in_oss_since:None ~lifecycle + ~params: + [ + (Ref _rate_limit, "self", "The rate limiter") + ; (Ref _caller, "caller", "The caller to attach") + ] + ~allowed_roles:_R_POOL_ADMIN () + +let remove_caller = + call ~name:"remove_caller" + ~doc:"Detach the given caller from this rate limiter" ~in_oss_since:None + ~lifecycle + ~params: + [ + (Ref _rate_limit, "self", "The rate limiter") + ; (Ref _caller, "caller", "The caller to detach") + ] + ~allowed_roles:_R_POOL_ADMIN () + +let set_burst_size = + call ~name:"set_burst_size" ~doc:"Set the burst size of the rate limiter" + ~in_oss_since:None ~lifecycle + ~params: + [ + (Ref _rate_limit, "self", "The rate limiter") + ; (Float, "value", "The new burst size, must be positive") + ] + ~allowed_roles:_R_POOL_ADMIN () + +let set_fill_rate = + call ~name:"set_fill_rate" ~doc:"Set the fill rate of the rate limiter" + ~in_oss_since:None ~lifecycle + ~params: + [ + (Ref _rate_limit, "self", "The rate limiter") + ; (Float, "value", "The new fill rate (tokens/second), must be positive") + ] + ~allowed_roles:_R_POOL_ADMIN () + +let t = + create_obj ~name:_rate_limit + ~descr:"A rate limiter associated with one or more callers" ~doccomments:[] + ~gen_constructor_destructor:true ~gen_events:true ~in_db:true ~lifecycle + ~persist:PersistEverything ~in_oss_since:None + ~messages_default_allowed_roles:_R_POOL_ADMIN + ~contents: + [ + uid _rate_limit ~lifecycle + ; namespace ~name:"name" ~contents:(names None RW ~lifecycle) () + ; field ~qualifier:DynamicRO ~ty:(Set (Ref _caller)) ~lifecycle "callers" + "The set of callers attached to this rate limiter" + ; field ~qualifier:StaticRO ~ty:Float ~lifecycle "burst_size" + "Maximum tokens that the bucket can hold" + ~default_value:(Some (VFloat 0.)) + ; field ~qualifier:StaticRO ~ty:Float ~lifecycle "fill_rate" + "Tokens added to the bucket per second" + ~default_value:(Some (VFloat 0.)) + ] + ~messages:[add_caller; remove_caller; set_burst_size; set_fill_rate] + () diff --git a/ocaml/idl/datamodel_types.ml b/ocaml/idl/datamodel_types.ml index 72b977b18b8..721d7db9dec 100644 --- a/ocaml/idl/datamodel_types.ml +++ b/ocaml/idl/datamodel_types.ml @@ -513,6 +513,7 @@ module Lifecycle = struct - The rest of the changes are not idempotent, they cannot be applied twice in a row - Objects can only be removed when are prototyped or deprecated + - A removed object can be published again, i.e. reintroduced *) let automaton = { @@ -528,7 +529,7 @@ module Lifecycle = struct ) | (Published as into), _, _ -> ( function - | Unreleased_s | Prototyped_s -> + | Unreleased_s | Prototyped_s | Removed_s -> Published_s | from -> raise_invalid_next ~from ~into diff --git a/ocaml/idl/dune b/ocaml/idl/dune index 6d49fa6f231..53f915eed31 100644 --- a/ocaml/idl/dune +++ b/ocaml/idl/dune @@ -7,7 +7,9 @@ datamodel_values datamodel_schema datamodel_certificate datamodel_diagnostics datamodel_repository datamodel_lifecycle datamodel_vtpm datamodel_observer datamodel_vm_group api_version - datamodel_host_driver datamodel_driver_variant) + datamodel_host_driver datamodel_driver_variant datamodel_caller + datamodel_rate_limit + ) (libraries rpclib.core sexplib0 diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index f0f1a8a1e3a..e559c758137 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "6147ef4f0f9c3bbbf0c2061e0a0d0010" +let last_known_schema_hash = "812a94da8125fe0f145561522cb309f2" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/ktls-helper/README.md b/ocaml/ktls-helper/README.md new file mode 100644 index 00000000000..95507e5e33e --- /dev/null +++ b/ocaml/ktls-helper/README.md @@ -0,0 +1,53 @@ +# ktls-helper + +Sender-side kTLS helper for VM live migration. It replaces the per-migration +stunnel client subprocess on the sender: it performs the TLS handshake in +userspace, installs the symmetric keys into the kernel via kTLS, and hands the +kTLS-enabled socket fd back to xenopsd via `SCM_RIGHTS`. + +Once xenopsd holds the fd, every subsequent `read()`/`write()` is +decrypted/encrypted by the kernel on the calling thread — no stunnel pipe, no +extra context switches, no extra copies. + +## Enabling + +Set the following in `/etc/xenopsd.conf` (or `/etc/xenopsd.conf.d/migration.conf`) +and restart xenopsd: + +``` +migration-tls = ktls +``` + +If the option is absent or set to `stunnel` (the default), xenopsd uses the +existing stunnel-based path. If the helper fails for any reason (binary missing, +TLS handshake error, kTLS install rejected by the kernel), xenopsd logs a `warn` +and transparently retries that single connection over stunnel, so the migration +still succeeds over TLS. + +## Invocation contract + +``` +ktls-helper \ + --host \ + --port \ + --send-fd \ + --ciphers \ + --curves \ + [--cert-bundle-file | --no-verify] \ + [--sni ] +``` + +- `--send-fd N` is the integer fd of a Unix-domain socket inherited from + xenopsd. After a successful handshake the helper confirms kTLS is installed in + both directions, then writes a single byte plus the kTLS-enabled socket fd + onto `N` via `SCM_RIGHTS` and exits 0 (the byte is a required carrier for the + `SCM_RIGHTS` fd; its value is ignored). On any failure it writes a single line + to stderr and exits 1. +- `--cert-bundle-file` is the PEM trust bundle used to verify the destination + (a CA bundle or a pinned peer certificate). `--no-verify` skips verification + when pool certificate verification is disabled. +- `--ciphers` and `--curves` are the OpenSSL cipher list and ECDHE curve the + helper must negotiate. They are mandatory and passed by xenopsd from the same + `Stunnel.Openssl` TLS policy the stunnel client uses, so the helper carries no + cipher policy of its own. The helper refuses to run if either is missing or + empty rather than fall back to OpenSSL's broad defaults. diff --git a/ocaml/ktls-helper/helper/Makefile b/ocaml/ktls-helper/helper/Makefile new file mode 100644 index 00000000000..ef8136421c4 --- /dev/null +++ b/ocaml/ktls-helper/helper/Makefile @@ -0,0 +1,21 @@ +# Standalone convenience Makefile for the ktls-helper. + +CC ?= gcc +CFLAGS ?= -O2 -Wall -Wextra -Werror -std=gnu99 +LDFLAGS ?= +LDLIBS ?= -lssl -lcrypto + +BIN := ktls-helper + +all: $(BIN) + +$(BIN): ktls-helper.c + $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $< $(LDLIBS) + +install: $(BIN) + install -D -m 0755 $(BIN) $(DESTDIR)/usr/libexec/xapi/$(BIN) + +clean: + rm -f $(BIN) + +.PHONY: all install clean diff --git a/ocaml/ktls-helper/helper/ktls-helper.c b/ocaml/ktls-helper/helper/ktls-helper.c new file mode 100644 index 00000000000..525ebf51f26 --- /dev/null +++ b/ocaml/ktls-helper/helper/ktls-helper.c @@ -0,0 +1,284 @@ +/* + * ktls-helper — sender-side kTLS helper for VM live migration. + * + * Steps: + * 1. open a TCP socket to the destination host:port + * 2. TLS handshake using the pool CA bundle (matching the stunnel migration + * client) + * 3. ask OpenSSL to install kTLS (SSL_OP_ENABLE_KTLS) and confirm the kernel + * installed kTLS for BOTH directions (TX and RX) — the migration channel + * is bidirectional + * 4. hand the kTLS-enabled socket fd back to xenopsd via SCM_RIGHTS on a + * unix-socket fd inherited from the parent + * 5. exit; xenopsd then read()s/write()s plaintext and the kernel + * decrypts/encrypts on the fly + * + * Build: see the Makefile. Installed at /usr/libexec/xapi/ktls-helper. + * + * Invocation: + * ktls-helper --host --port

--send-fd + * --ciphers --curves + * [--cert-bundle-file | --no-verify] [--sni ] + * + * Exit codes: + * 0 success (kTLS active in both directions, fd handed off) + * 1 any failure (TLS handshake, kTLS install, SCM_RIGHTS send, ...) + * stderr carries a single human-readable line for xenopsd to log. + */ + +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include + +#include +#include +#include + +static void die(const char *fmt, ...) __attribute__((noreturn, format(printf, 1, 2))); + +static void die(const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + fputs("ktls-helper: ", stderr); + vfprintf(stderr, fmt, ap); + fputc('\n', stderr); + va_end(ap); + exit(1); +} + +static const char *ossl_err(void) { + unsigned long e = ERR_peek_last_error(); + return e ? ERR_reason_error_string(e) : "(no OpenSSL error)"; +} + +static int send_fd(int sock, int fd) { + char dummy = 'x'; + struct iovec io = { .iov_base = &dummy, .iov_len = 1 }; + union { + struct cmsghdr cm; + char buf[CMSG_SPACE(sizeof(int))]; + } u; + memset(&u, 0, sizeof(u)); + struct msghdr msg = {0}; + msg.msg_iov = &io; + msg.msg_iovlen = 1; + msg.msg_control = u.buf; + msg.msg_controllen = sizeof(u.buf); + struct cmsghdr *cmsg = CMSG_FIRSTHDR(&msg); + cmsg->cmsg_level = SOL_SOCKET; + cmsg->cmsg_type = SCM_RIGHTS; + cmsg->cmsg_len = CMSG_LEN(sizeof(int)); + memcpy(CMSG_DATA(cmsg), &fd, sizeof(int)); + ssize_t n; + do { + n = sendmsg(sock, &msg, 0); + } while (n < 0 && errno == EINTR); + return (int) n; +} + +static int tcp_connect(const char *host, const char *port) { + struct addrinfo hints = {0}; + hints.ai_family = AF_UNSPEC; + hints.ai_socktype = SOCK_STREAM; + struct addrinfo *res = NULL; + int rc = getaddrinfo(host, port, &hints, &res); + if (rc != 0) + die("getaddrinfo(%s, %s): %s", host, port, gai_strerror(rc)); + int fd = -1; + int last_errno = 0; + for (struct addrinfo *ai = res; ai; ai = ai->ai_next) { + fd = socket(ai->ai_family, ai->ai_socktype, ai->ai_protocol); + if (fd < 0) { last_errno = errno; continue; } + if (connect(fd, ai->ai_addr, ai->ai_addrlen) == 0) break; + last_errno = errno; + close(fd); + fd = -1; + } + freeaddrinfo(res); + if (fd < 0) + die("connect %s:%s: %s", host, port, strerror(last_errno)); + int one = 1; + (void) setsockopt(fd, IPPROTO_TCP, TCP_NODELAY, &one, sizeof(one)); + (void) setsockopt(fd, SOL_SOCKET, SO_KEEPALIVE, &one, sizeof(one)); + return fd; +} + +int main(int argc, char **argv) { + const char *host = NULL; + const char *port = NULL; + const char *bundle = NULL; + const char *ciphers = NULL; + const char *curves = NULL; + const char *sni = NULL; + int send_fd_num = -1; + int no_verify = 0; + + static struct option long_opts[] = { + {"host", required_argument, 0, 'h'}, + {"port", required_argument, 0, 'p'}, + {"cert-bundle-file", required_argument, 0, 'c'}, + {"ciphers", required_argument, 0, 'C'}, + {"curves", required_argument, 0, 'g'}, + {"sni", required_argument, 0, 's'}, + {"send-fd", required_argument, 0, 'f'}, + {"no-verify", no_argument, 0, 'n'}, + {0, 0, 0, 0} + }; + int idx; + int c; + while ((c = getopt_long(argc, argv, "", long_opts, &idx)) != -1) { + switch (c) { + case 'h': host = optarg; break; + case 'p': port = optarg; break; + case 'c': bundle = optarg; break; + case 'C': ciphers = optarg; break; + case 'g': curves = optarg; break; + case 's': sni = optarg; break; + case 'n': no_verify = 1; break; + case 'f': { + /* --send-fd is a Forkhelpers placeholder rewritten to an + integer fd before exec; validate it strictly anyway. */ + char *end = NULL; + errno = 0; + long v = strtol(optarg, &end, 10); + if (optarg[0] == '\0' || *end != '\0' || errno != 0 + || v < 0 || v > INT_MAX) + die("invalid --send-fd value: %s", optarg); + send_fd_num = (int) v; + break; + } + default: + die("usage: %s --host H --port P --send-fd N " + "--ciphers LIST --curves NAME " + "[--cert-bundle-file PEM | --no-verify] [--sni NAME]", argv[0]); + } + } + if (!host || !port || send_fd_num < 0) + die("missing required argument; need --host --port --send-fd"); + /* --ciphers/--curves are mandatory and must be non-empty. The cipher list + and ECDHE curve come from xapi's TLS policy (Stunnel.Openssl) via argv, so + the helper keeps no cipher policy of its own. Fail here rather than + skip the SSL_CTX_set_cipher_list/set1_groups_list calls below: skipping + would leave OpenSSL's broad defaults active, negotiating weaker crypto + than the stunnel client this helper replaces. */ + if (!ciphers || !ciphers[0] || !curves || !curves[0]) + die("--ciphers and --curves are required and must be non-empty"); + if (!no_verify && !bundle) + die("--cert-bundle-file is required unless --no-verify is given"); + + int fd = tcp_connect(host, port); + + const SSL_METHOD *method = TLS_client_method(); + SSL_CTX *ctx = SSL_CTX_new(method); + if (!ctx) + die("SSL_CTX_new: %s", ossl_err()); + + /* Pin TLSv1.2. This pin is necessary for kTLS, not merely stunnel parity: + it prevents TLS1.3 post-handshake KeyUpdate, which the kernel kTLS data + path cannot process once OpenSSL has handed off the socket. */ + SSL_CTX_set_min_proto_version(ctx, TLS1_2_VERSION); + SSL_CTX_set_max_proto_version(ctx, TLS1_2_VERSION); + /* The cipher list and ECDHE curve arrive via --ciphers/--curves, sourced + from xapi's Stunnel.Openssl TLS policy (the same values the stunnel client + this helper replaces negotiates), so there is no second copy to drift. */ + if (SSL_CTX_set_cipher_list(ctx, ciphers) != 1) + die("SSL_CTX_set_cipher_list(%s): %s", ciphers, ossl_err()); + if (SSL_CTX_set1_groups_list(ctx, curves) != 1) + die("SSL_CTX_set1_groups_list(%s): %s", curves, ossl_err()); + + /* Request kTLS BEFORE the handshake; also forbid renegotiation (defence in + depth — the AES-GCM TLS1.2 suites do not renegotiate, and the kernel + could not process a post-handoff renegotiation anyway). If kTLS install + fails along the way the handshake still succeeds but the BIO_get_ktls_* + checks below return 0. */ + SSL_CTX_set_options(ctx, SSL_OP_ENABLE_KTLS | SSL_OP_NO_RENEGOTIATION); + + if (no_verify) { + SSL_CTX_set_verify(ctx, SSL_VERIFY_NONE, NULL); + } else { + if (SSL_CTX_load_verify_locations(ctx, bundle, NULL) != 1) + die("failed to load --cert-bundle-file %s (expected a PEM bundle): " + "%s", bundle, ossl_err()); + SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, NULL); + } + + SSL *ssl = SSL_new(ctx); + if (!ssl) + die("SSL_new: %s", ossl_err()); + + /* BIO_NOCLOSE: SSL_free must not close the underlying fd, since we are + handing it to xenopsd. */ + BIO *bio = BIO_new_socket(fd, BIO_NOCLOSE); + if (!bio) + die("BIO_new_socket: %s", ossl_err()); + SSL_set_bio(ssl, bio, bio); + + if (sni && SSL_set_tlsext_host_name(ssl, sni) != 1) + die("SSL_set_tlsext_host_name(%s): %s", sni, ossl_err()); + + ERR_clear_error(); + if (SSL_connect(ssl) != 1) + die("SSL_connect: %s", ossl_err()); + + /* SSL_VERIFY_PEER (set above) already makes SSL_connect fail on a bad + certificate, so in normal operation this re-check never fires. It is a + defence-in-depth guard against a future change that drops or weakens + that flag; if it ever did fire it reports the specific failure reason. */ + if (!no_verify) { + long vr = SSL_get_verify_result(ssl); + if (vr != X509_V_OK) + die("certificate verification failed: %s", + X509_verify_cert_error_string(vr)); + } + + /* No-plaintext invariant: confirm the kernel installed kTLS in BOTH + directions BEFORE handing the fd to xenopsd. The migration channel is + bidirectional (the sender both writes the memory image and reads + handshake replies on this fd), so TX-only kTLS is not sufficient. These + gates MUST stay strictly after SSL_connect and strictly before send_fd + below — a refactor must not reorder them, or plaintext could be sent. */ + if (!BIO_get_ktls_send(SSL_get_wbio(ssl))) + die("kTLS TX not installed (tls.ko missing or cipher rejected by " + "kernel); negotiated cipher = %s", SSL_get_cipher_name(ssl)); + if (!BIO_get_ktls_recv(SSL_get_rbio(ssl))) + die("kTLS RX not installed (kernel lacks TLS_RX for the negotiated " + "cipher); negotiated cipher = %s", SSL_get_cipher_name(ssl)); + + /* Report the negotiated TLS version and cipher of the kTLS socket before + handoff. xenopsd forwards the helper's stdout and stderr to syslog (key + "ktls-helper"). Flush explicitly, as stdout to forkexecd is buffered; + otherwise the line is lost if the helper is killed on the xenopsd + timeout after the fd is sent. */ + printf("kTLS active: %s %s\n", SSL_get_version(ssl), + SSL_get_cipher_name(ssl)); + fflush(stdout); + + if (send_fd(send_fd_num, fd) < 0) + die("sendmsg(SCM_RIGHTS) on fd %d: %s", send_fd_num, strerror(errno)); + + /* Do NOT SSL_shutdown — it would send close_notify down the socket that + xenopsd is about to use. SSL_free is safe (BIO_NOCLOSE). The kTLS state + lives in the kernel socket, so userspace teardown here is purely local; + end-of-stream integrity is enforced by the migration layer. */ + SSL_free(ssl); + SSL_CTX_free(ctx); + + /* Closing our fd is fine: the kernel keeps the socket alive while xenopsd + holds the duplicated fd received via SCM_RIGHTS. */ + close(fd); + close(send_fd_num); + return 0; +} diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index ff97bc3db36..13981b9af41 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -759,5 +759,19 @@ let client_of_req_and_fd req fd = None ) +(* An IPv4 connection may arrive as an IPv4-mapped IPv6 address + (e.g. ::ffff:1.2.3.4) depending on how the listening socket is bound. + [Ipaddr.to_string] preserves the IPv6 form, which then fails to + match string comparisons against the plain IPv4 form of the same + address. Callers that use the string for exact matching (e.g. the + per-caller rate-limit table) should route the value through this + helper first. *) +let canonical_ip_string ip = + match Ipaddr.to_v4 ip with + | Some v4 -> + Ipaddr.V4.to_string v4 + | None -> + Ipaddr.to_string ip + let string_of_client (protocol, ip) = - Printf.sprintf "%s %s" (string_of_protocol protocol) (Ipaddr.to_string ip) + Printf.sprintf "%s %s" (string_of_protocol protocol) (canonical_ip_string ip) diff --git a/ocaml/libs/http-lib/http_svr.mli b/ocaml/libs/http-lib/http_svr.mli index 0aae32467f8..84e746f91ca 100644 --- a/ocaml/libs/http-lib/http_svr.mli +++ b/ocaml/libs/http-lib/http_svr.mli @@ -136,4 +136,11 @@ val https_client_of_req : Http.Request.t -> Ipaddr.t option val client_of_req_and_fd : Http.Request.t -> Unix.file_descr -> client option +val canonical_ip_string : Ipaddr.t -> string +(** [canonical_ip_string ip] returns [ip] as a string, normalising an + IPv4-mapped IPv6 address (e.g. ::ffff:1.2.3.4) to its plain IPv4 + form. Use before comparing a request's source IP against caller + records so that IPv4 patterns match connections that surface as + IPv4-mapped IPv6. *) + val string_of_client : client -> string diff --git a/ocaml/libs/rate-limit/caller_statistics.ml b/ocaml/libs/rate-limit/caller_statistics.ml new file mode 100644 index 00000000000..ac84f2b7d59 --- /dev/null +++ b/ocaml/libs/rate-limit/caller_statistics.ml @@ -0,0 +1,37 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type caller_statistics = {call_count: int; token_count: float} + +type t = {caller_uuid: string; statistics: caller_statistics Atomic.t} + +let create ~caller_uuid = + {caller_uuid; statistics= Atomic.make {call_count= 0; token_count= 0.0}} + +(* Recursion should only trigger rarely when under contention *) +let rec register_call ~token_amount ({statistics; _} as t) = + let ({call_count; token_count} as vl) = Atomic.get statistics in + if + not + (Atomic.compare_and_set statistics vl + {call_count= call_count + 1; token_count= token_count +. token_amount} + ) + then + register_call ~token_amount t + +let get_uuid {caller_uuid; _} = caller_uuid + +let get_call_count {statistics; _} = (Atomic.get statistics).call_count + +let get_token_count {statistics; _} = (Atomic.get statistics).token_count diff --git a/ocaml/libs/rate-limit/caller_statistics.mli b/ocaml/libs/rate-limit/caller_statistics.mli new file mode 100644 index 00000000000..89e9b454790 --- /dev/null +++ b/ocaml/libs/rate-limit/caller_statistics.mli @@ -0,0 +1,14 @@ +type t + +val create : caller_uuid:string -> t +(** [create ~caller_uuid] creates a fresh statistics record with zero counts + and a [last_called] of [Mtime.Span.zero]. *) + +val register_call : token_amount:float -> t -> unit +(** Track that a client has made a call *) + +val get_uuid : t -> string + +val get_call_count : t -> int + +val get_token_count : t -> float diff --git a/ocaml/libs/rate-limit/caller_table.ml b/ocaml/libs/rate-limit/caller_table.ml new file mode 100644 index 00000000000..79d4273bcc1 --- /dev/null +++ b/ocaml/libs/rate-limit/caller_table.ml @@ -0,0 +1,166 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module D = Debug.Make (struct let name = "caller_table" end) + +module Key = struct + (* Prefix "" is a wildcard *) + type match_pattern = Full of string | Prefix of string + + type t = {user_agent: string; client_ip: string} + + type pattern_key = { + user_agent_pattern: match_pattern + ; client_ip_pattern: match_pattern + } + + let matches_pattern ~pattern ~target = + match pattern with + | Full s -> + target = s + | Prefix prefix -> + String.starts_with ~prefix target + + let matches_key ~pattern ~target = + matches_pattern ~pattern:pattern.user_agent_pattern + ~target:target.user_agent + && matches_pattern ~pattern:pattern.client_ip_pattern + ~target:target.client_ip + + let equal_pattern a b = + a.user_agent_pattern = b.user_agent_pattern + && a.client_ip_pattern = b.client_ip_pattern + + let wildcard_score = function Full _ -> 0 | Prefix "" -> 2 | Prefix _ -> 1 + + let compare_wildcard k = + let user_agent_score = wildcard_score k.user_agent_pattern in + let client_ip_score = wildcard_score k.client_ip_pattern in + (user_agent_score + client_ip_score, user_agent_score, client_ip_score) + + let is_all_wildcard k = + k.user_agent_pattern = Prefix "" && k.client_ip_pattern = Prefix "" + + (** Total order: fewer wildcards first, then lexicographic by patterns *) + let compare a b = + match compare (compare_wildcard a) (compare_wildcard b) with + | 0 -> ( + match compare a.user_agent_pattern b.user_agent_pattern with + | 0 -> + compare a.client_ip_pattern b.client_ip_pattern + | n -> + n + ) + | n -> + n +end + +type 'a cached_table = { + table: (Key.pattern_key * 'a) list + ; cache: (Key.t, 'a list) Lru.t +} + +type 'a t = 'a cached_table Atomic.t + +let cache_capacity = 100 + +let create () = Atomic.make {table= []; cache= Lru.create cache_capacity} + +(** Build a fresh cache from [old_cache] but drop entries whose cached + target is matched by [pattern]. Those are exactly the entries whose + result list would change if [pattern] is inserted into or removed + from the table. *) +let cache_without_matches ~pattern old_cache = + Lru.filter old_cache ~f:(fun target _ -> + not (Key.matches_key ~pattern ~target) + ) + +(** Insert [entry] into [table] (sorted by Key.compare ascending, i.e. most + specific first) at the position that preserves the ordering. *) +let rec insert_sorted entry table = + match table with + | [] -> + [entry] + | (k, _) :: _ when Key.compare (fst entry) k <= 0 -> + entry :: table + | hd :: tl -> + hd :: insert_sorted entry tl + +(** Find all matching entries for a caller_id, ordered by Key.compare + (most specific first). Priority: exact > prefix > full wildcard. *) +let find_matches {table; cache} ~caller_id = + let entry_opt = Lru.lookup cache caller_id in + match entry_opt with + | Some result -> + result + | None -> + let result = + List.filter_map + (fun (key, v) -> + if Key.matches_key ~pattern:key ~target:caller_id then + Some v + else + None + ) + table + in + Lru.add_trim cache caller_id result ; + result + +let mem t ~caller_id = + let entries = Atomic.get t in + find_matches entries ~caller_id <> [] + +let insert t ~pattern data = + if Key.is_all_wildcard pattern then + false + (* Reject keys with both fields full wildcards. *) + else + let {table; cache} = Atomic.get t in + if List.exists (fun (key, _) -> Key.equal_pattern key pattern) table then + false + else ( + Atomic.set t + { + table= insert_sorted (pattern, data) table + ; cache= cache_without_matches ~pattern cache + } ; + true + ) + +let delete t ~pattern = + let {table; cache} = Atomic.get t in + match List.find_opt (fun (key, _) -> Key.equal_pattern key pattern) table with + | None -> + () + | Some _ -> + Atomic.set t + { + table= + List.filter + (fun (key, _) -> not (Key.equal_pattern key pattern)) + table + ; cache= cache_without_matches ~pattern cache + } + +let get t ~caller_id = + let entries = Atomic.get t in + find_matches entries ~caller_id + +let get_exact t ~pattern = + let {table; _} = Atomic.get t in + Option.map snd + (List.find_opt (fun (key, _) -> Key.equal_pattern key pattern) table) + +let to_list t = (Atomic.get t).table diff --git a/ocaml/libs/rate-limit/caller_table.mli b/ocaml/libs/rate-limit/caller_table.mli new file mode 100644 index 00000000000..3f10ddf7b9b --- /dev/null +++ b/ocaml/libs/rate-limit/caller_table.mli @@ -0,0 +1,79 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Key types for table entries and lookups. + Entries are stored under a [pattern_key] (which may contain wildcards), + while lookups identify a caller with a concrete [t]. *) +module Key : sig + (** A pattern for a single field. [Full s] matches exactly [s]. + [Prefix p] matches any string starting with [p]; [Prefix ""] is a + full wildcard. *) + type match_pattern = Full of string | Prefix of string + + (** A concrete caller identifier used for lookups. *) + type t = {user_agent: string; client_ip: string} + + (** A pattern stored in the table. Each field is matched independently. *) + type pattern_key = { + user_agent_pattern: match_pattern + ; client_ip_pattern: match_pattern + } + + val matches_key : pattern:pattern_key -> target:t -> bool + (** [matches_key ~pattern ~target] returns true if [pattern] matches + [target]. Both fields must match independently. *) + + val compare : pattern_key -> pattern_key -> int + (** Total order on patterns: fewer wildcards first, then lexicographic + by patterns. *) + + val is_all_wildcard : pattern_key -> bool + (** [is_all_wildcard k] returns true if every field of [k] is a full + wildcard ([Prefix ""]). Such patterns are rejected by [insert]. *) +end + +(** List of entries mapping patterns to values. + Lookups use wildcard matching with priority: exact > prefix > full wildcard. *) +type 'a t + +val create : unit -> 'a t +(** [create ()] creates a new empty table. *) + +val insert : 'a t -> pattern:Key.pattern_key -> 'a -> bool +(** [insert t ~pattern data] adds an entry for the given pattern. + Returns [false] if an entry already exists for that exact pattern, or + if [pattern] has both fields as full wildcards (all-wildcard patterns + are rejected). *) + +val mem : 'a t -> caller_id:Key.t -> bool +(** [mem t ~caller_id] returns whether [caller_id] matches any entry + in the table using wildcard matching. *) + +val delete : 'a t -> pattern:Key.pattern_key -> unit +(** [delete t ~pattern] removes the entry for the exact pattern. *) + +val get : 'a t -> caller_id:Key.t -> 'a list +(** [get t ~caller_id] returns the values for all entries whose pattern + matches [caller_id], ordered from most specific to least specific match + (exact > prefix > full wildcard). Returns the empty list if no entry + matches. *) + +val get_exact : 'a t -> pattern:Key.pattern_key -> 'a option +(** [get_exact t ~pattern] returns the value for the entry whose pattern + is exactly equal to [pattern], or [None]. Does not use wildcard + matching. *) + +val to_list : 'a t -> (Key.pattern_key * 'a) list +(** [to_list t] returns a snapshot of all entries in [t], most specific + first. *) diff --git a/ocaml/libs/rate-limit/dune b/ocaml/libs/rate-limit/dune new file mode 100644 index 00000000000..0cd642fa456 --- /dev/null +++ b/ocaml/libs/rate-limit/dune @@ -0,0 +1,8 @@ +(library + (name rate_limit_lib) + (public_name xapi-rate-limit) + + (libraries threads.posix mtime mtime.clock.os xapi-log xapi-stdext-threads clock) +) + + diff --git a/ocaml/libs/rate-limit/linked_list.ml b/ocaml/libs/rate-limit/linked_list.ml new file mode 100644 index 00000000000..92242cc6825 --- /dev/null +++ b/ocaml/libs/rate-limit/linked_list.ml @@ -0,0 +1,125 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type 'a node = { + value: 'a + ; mutable prev: 'a node option + ; mutable next: 'a node option +} + +type 'a t = {mutable first: 'a node option; mutable last: 'a node option} + +let create () = {first= None; last= None} + +let node x = {value= x; prev= None; next= None} + +let append t n = + match t.last with + | None -> + let node = Some n in + t.first <- node ; + t.last <- node + | Some lst -> + let node = Some n in + lst.next <- node ; + n.prev <- t.last ; + t.last <- node + +(** [drop] a node [n] from (its) list [t]. The interesting property is + that we can drop any element from its list that we know. However, + we don't check that [n] is indeed a member of [t] and it's an + unchecked error to pass an [n] that is not a member of [t]. + + This is similar to a + pointer-based implementation in C. We infer that we need to update + the fist, last entry of the list of [n]'s prev or next is [None], + hence it is the first or last element in the list. *) +let drop t n = + let np = n.prev in + let nn = n.next in + ( match np with + | None -> + t.first <- nn + | Some x -> + x.next <- nn ; + n.prev <- None + ) ; + match nn with + | None -> + t.last <- np + | Some x -> + x.prev <- np ; + n.next <- None + +let first t = t.first + +let last t = t.last + +let value node = node.value + +let foldl f zero t = + let rec loop acc = function + | None -> + acc + | Some n -> + loop (f acc n.value) n.next + in + loop zero t.first + +let foldr f t zero = + let rec loop acc = function + | None -> + acc + | Some n -> + loop (f n.value acc) n.prev + in + loop zero t.last + +let to_list t = foldr (fun x xs -> x :: xs) t [] + +let from_list xs = + let t = create () in + List.iter (fun x -> append t (node x)) xs ; + t + +let compare cmp t1 t2 = + (* Floyd's tortoise-and-hare: slow pointer advances 1 step, fast 2. + Physical equality on nodes detects a cycle in either list. *) + let next2 n = + Option.bind (Option.bind n (fun x -> x.next)) (fun x -> x.next) + in + let cycle a b = match (a, b) with Some x, Some y -> x == y | _ -> false in + let rec loop sa sb fa fb = + match (sa, sb) with + | None, None -> + 0 + | None, Some _ -> + -1 + | Some _, None -> + 1 + | Some na, Some nb -> + let c = cmp na.value nb.value in + if c <> 0 then + c + else + let sa' = na.next and sb' = nb.next in + let fa' = next2 fa and fb' = next2 fb in + if cycle fa' sa' || cycle fb' sb' then + 0 + else + loop sa' sb' fa' fb' + in + loop t1.first t2.first t1.first t2.first + +let equal t1 t2 = compare Stdlib.compare t1 t2 = 0 diff --git a/ocaml/libs/rate-limit/linked_list.mli b/ocaml/libs/rate-limit/linked_list.mli new file mode 100644 index 00000000000..496c8752af9 --- /dev/null +++ b/ocaml/libs/rate-limit/linked_list.mli @@ -0,0 +1,64 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Doubly linked list ['a t] holding elements of type ['a]. *) + +(** doubly linked list; this is a cyclic data structure; don't use [=] + on it as it may not terminate. *) +type 'a t + +(** a node in the list. A node can be removed from its list. Don't use + [=] on [node] values as it may not terminate. *) +type 'a node + +val create : unit -> 'a t +(** create an empty list *) + +val node : 'a -> 'a node +(** create a node to carry a value *) + +val value : 'a node -> 'a +(** obtain the value from a node *) + +val append : 'a t -> 'a node -> unit +(** append a node at the end *) + +val drop : 'a t -> 'a node -> unit +(** [drop t n] a node [n] from list [t]. It is an unchecked error to + pass a node [n] to [drop] that is not an element of [t] to begin + with.*) + +val first : 'a t -> 'a node option +(** first/head node of the list *) + +val last : 'a t -> 'a node option +(** last/tail node of the list *) + +val foldl : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a +(** fold from head *) + +val foldr : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b +(** fold from tail *) + +val to_list : 'a t -> 'a list +(** retrieve all elements from the list *) + +val from_list : 'a list -> 'a t +(** construct a [t] value from list *) + +val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int +(** Lexicographic comparison. Terminates on cyclic lists. *) + +val equal : 'a t -> 'a t -> bool +(** Structural equality on the sequence of values. Terminates on cyclic lists. *) diff --git a/ocaml/libs/rate-limit/lru.ml b/ocaml/libs/rate-limit/lru.ml new file mode 100644 index 00000000000..b6292af7836 --- /dev/null +++ b/ocaml/libs/rate-limit/lru.ml @@ -0,0 +1,158 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +let invalid_arg fmt = Printf.ksprintf invalid_arg fmt + +module LL = Linked_list + +(** A store for key/value pairs of type ['k] and ['v]. The main store + is [table] that maps a key to a key/value node. Every item in the + store is also a member in the [queue]. The [queue] keeps track of + which elements are looked up most often. The first element in the + [queue] is the least used one. *) +type ('k, 'v) t = { + table: ('k, ('k * 'v) LL.node) Hashtbl.t + ; queue: ('k * 'v) LL.t + ; cap: int (** max capacity of table and queue *) + ; mutable entries: int (** actual capacity of table and queue *) + ; lock: Mutex.t (** lock while operating on this value *) +} + +let locked m f = + let finally () = Mutex.unlock m in + Mutex.lock m ; Fun.protect ~finally f + +(* All primed functions below are not thread safe because they are + manipulating state; we will use a lock to protect against concurrent + update. However, we have to do that on an outer layer such that we + can use these functions internally after we obtained the lock. *) + +module Unsafe = struct + let create' capacity = + if capacity <= 0 then + invalid_arg "%s: capacity needs to be postive" __FUNCTION__ ; + { + table= Hashtbl.create capacity + ; queue= LL.create () + ; cap= capacity + ; entries= 0 + ; lock= Mutex.create () + } + + let size' t = t.entries + + let cap' t = t.cap + + let to_list' t = LL.to_list t.queue + + (** [lookup] an entry based on its [key]; this may fail or succeeed. + In the success case, the entry is moved to the tail of the + [queue]. Hnece, the least-used entry is at the front. *) + let lookup' t key = + match Hashtbl.find_opt t.table key with + | Some v -> + LL.drop t.queue v ; + LL.append t.queue v ; + Some (LL.value v |> snd) + | None -> + None + + (** [remove] an entry based on this [key] *) + let remove' t key = + match Hashtbl.find_opt t.table key with + | Some v -> + LL.drop t.queue v ; + Hashtbl.remove t.table key ; + t.entries <- t.entries - 1 + | None -> + () + + (** [add] a new entry; do nothing if the entry exists. If the new + entry exceeds the capacity of the table, [true] + is returned and [false] otherwise. It signals the caller to [trim] + the table.*) + let add' t key value = + match lookup' t key with + | None -> + let node = LL.node (key, value) in + Hashtbl.add t.table key node ; + t.entries <- t.entries + 1 ; + LL.append t.queue node ; + t.entries > t.cap + | Some _ -> + t.entries > t.cap + + (** [lru] returns the least-recently-used key/value pair *) + let lru' t = LL.first t.queue |> Option.map LL.value + + (** [drop_while] drops elements starting in least-recently-used order + while predicate [evict] is true. The predicate receives the key/value + and a boolean that indicates if the cache is over capacity. If + [evict] returns true it can perform any finalisation on the value + before it will be removed by [drop_while]. *) + + let rec drop_while' t ~evict = + match lru' t with + | Some ((key, _) as kv) when evict kv (t.entries > t.cap) -> + remove' t key ; drop_while' t ~evict + | Some _ -> + () + | None -> + () + + (** [trim] the table such that it does not exceed its capacity by + removing the least-used element repeatedly until this is achieved. + If finalisation of values is required, use [drop_while] because + [trim] does not provide it. *) + + let trim' t = + let evict _ x = x in + drop_while' t ~evict + + let add_trim' t key value = + ignore (add' t key value) ; + trim' t +end + +(* Functions below are intended to be used by clients of this modules. + They have to take care of locking. *) + +let create = Unsafe.create' + +let size t = locked t.lock @@ fun () -> Unsafe.size' t + +let cap t = locked t.lock @@ fun () -> Unsafe.cap' t + +let to_list t = locked t.lock @@ fun () -> Unsafe.to_list' t + +let lookup t = locked t.lock @@ fun () -> Unsafe.lookup' t + +let remove t = locked t.lock @@ fun () -> Unsafe.remove' t + +let add t = locked t.lock @@ fun () -> Unsafe.add' t + +let drop_while t = locked t.lock @@ fun () -> Unsafe.drop_while' t + +let trim t = locked t.lock @@ fun () -> Unsafe.trim' t + +let add_trim t key value = + locked t.lock @@ fun () -> Unsafe.add_trim' t key value + +let filter t ~f = + locked t.lock @@ fun () -> + let fresh = Unsafe.create' t.cap in + List.iter + (fun (k, v) -> if f k v then Unsafe.add_trim' fresh k v) + (Unsafe.to_list' t) ; + fresh diff --git a/ocaml/libs/rate-limit/lru.mli b/ocaml/libs/rate-limit/lru.mli new file mode 100644 index 00000000000..97e15c03852 --- /dev/null +++ b/ocaml/libs/rate-limit/lru.mli @@ -0,0 +1,62 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** A least-recently-used (LRU) cache mapping keys of type ['k] to + values of type ['v]. The cache has a fixed capacity; when full, the + least recently used entries are evicted to make room for new ones. + All operations are thread-safe. *) +type ('k, 'v) t + +val create : int -> ('k, 'v) t +(** [create capacity] creates an empty cache with the given capacity. + Raises [Invalid_argument] if [capacity <= 0]. *) + +val size : ('k, 'v) t -> int +(** [size t] is the current number of entries in the cache. *) + +val cap : ('k, 'v) t -> int +(** [cap t] is the maximum capacity of the cache. *) + +val to_list : ('k, 'v) t -> ('k * 'v) list +(** [to_list t] returns all entries in LRU order: the least recently + used entry is at the head of the list. *) + +val lookup : ('k, 'v) t -> 'k -> 'v option +(** [lookup t key] returns the value bound to [key] if present, and + marks the entry as most recently used. *) + +val remove : ('k, 'v) t -> 'k -> unit +(** [remove t key] removes the entry for [key]; does nothing if absent. *) + +val add : ('k, 'v) t -> 'k -> 'v -> bool +(** [add t key value] inserts [(key, value)] if [key] is not already + present. Returns [true] if the cache now exceeds its capacity, + signalling the caller to call [trim]. *) + +val drop_while : ('k, 'v) t -> evict:('k * 'v -> bool -> bool) -> unit +(** [drop_while t ~evict] drops entries in least-recently-used order + while [evict (k, v) over_capacity] is true. The boolean argument + indicates whether the cache currently exceeds its capacity. *) + +val trim : ('k, 'v) t -> unit +(** [trim t] evicts least-recently-used entries until the cache no + longer exceeds its capacity. *) + +val add_trim : ('k, 'v) t -> 'k -> 'v -> unit +(** [add_trim t key value] is equivalent to [add] followed by [trim]. *) + +val filter : ('k, 'v) t -> f:('k -> 'v -> bool) -> ('k, 'v) t +(** [filter t ~f] returns a fresh cache containing only the entries for + which [f k v] returns true, preserving LRU order. The source cache + is not modified. *) diff --git a/ocaml/libs/rate-limit/rate_limit.ml b/ocaml/libs/rate-limit/rate_limit.ml new file mode 100644 index 00000000000..49b9be9eaac --- /dev/null +++ b/ocaml/libs/rate-limit/rate_limit.ml @@ -0,0 +1,207 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module D = Debug.Make (struct let name = __MODULE__ end) + +type delay_observer = {on_start: unit -> unit; on_end: unit -> unit} + +let safe_observe context f = + try f () + with e -> + D.warn "Rate_limit: delay_observer %s raised: %s" context + (Printexc.to_string e) + +type queue_item = { + cost: float + ; callback: unit -> unit (** run when tokens are granted (worker thread) *) + ; on_worker_end: unit -> unit +} + +type t = { + bucket: Token_bucket.t + ; process_queue: queue_item Queue.t + ; process_queue_lock: Mutex.t + ; worker_thread_cond: Condition.t + ; should_terminate: bool Atomic.t + (* Signal termination to worker thread. The worker thread will + process all remaining items in the queue before exiting. *) + ; worker_thread: Thread.t +} + +let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute + +let noop () = () + +(* The worker thread is responsible for calling the callback when the token + amount becomes available *) +let rec worker_loop ~bucket ~process_queue ~process_queue_lock + ~worker_thread_cond ~should_terminate = + let peeked = + with_lock process_queue_lock (fun () -> + while + Queue.is_empty process_queue && not (Atomic.get should_terminate) + do + Condition.wait worker_thread_cond process_queue_lock + done ; + match Queue.peek_opt process_queue with + | None -> + None + | Some {cost; _} -> + let delay = Token_bucket.get_delay_until_available bucket cost in + Some (cost, delay) + ) + in + match peeked with + | None -> + (* Queue is empty only when termination was signalled *) + D.debug "%s: queue empty in deleted rate limiter; exiting" __FUNCTION__ + | Some (cost, delay) -> + if delay > 0. then Thread.delay delay ; + let item_opt = + with_lock process_queue_lock (fun () -> + if Token_bucket.consume bucket cost then + Queue.take_opt process_queue + else + None + ) + in + Option.iter + (fun {callback; on_worker_end; _} -> + safe_observe "on_end" on_worker_end ; + callback () + ) + item_opt ; + worker_loop ~bucket ~process_queue ~process_queue_lock ~worker_thread_cond + ~should_terminate + +let create ~burst_size ~fill_rate = + let bucket = Token_bucket.create ~burst_size ~fill_rate in + let process_queue = Queue.create () in + let process_queue_lock = Mutex.create () in + let worker_thread_cond = Condition.create () in + let should_terminate = Atomic.make false in + let worker_thread = + Thread.create + (fun () -> + worker_loop ~bucket ~process_queue ~process_queue_lock + ~worker_thread_cond ~should_terminate + ) + () + in + { + bucket + ; process_queue + ; process_queue_lock + ; worker_thread_cond + ; should_terminate + ; worker_thread + } + +let delete data = + (* Set the termination flag and signal under [process_queue_lock]. The worker + evaluates its wait predicate (queue empty && not terminated) and calls + [Condition.wait] while holding this lock, so taking it here makes the + flag update and the signal atomic with respect to that check. Signalling + without the lock races the worker between its predicate check and + [Condition.wait]: the signal would be lost and the worker would sleep + forever, hanging [Thread.join] below. *) + with_lock data.process_queue_lock (fun () -> + Atomic.set data.should_terminate true ; + Condition.signal data.worker_thread_cond + ) ; + Thread.join data.worker_thread + +let check_not_terminated should_terminate = + if Atomic.get should_terminate then + invalid_arg "Rate_limit: submit called on a deleted rate limiter" + +(* The callback should return quickly - if it is a longer task it is + responsible for creating a thread to do the task *) +let submit_async + { + bucket + ; process_queue + ; process_queue_lock + ; worker_thread_cond + ; should_terminate + ; _ + } ?observer ~callback ~caller_details amount = + check_not_terminated should_terminate ; + let on_start, on_worker_end = + match observer with + | Some {on_start; on_end} -> + (on_start, on_end) + | None -> + (noop, noop) + in + let run_immediately = + with_lock process_queue_lock (fun () -> + let immediate = + Queue.is_empty process_queue && Token_bucket.consume bucket amount + in + if not immediate then ( + Queue.add {cost= amount; callback; on_worker_end} process_queue ; + Condition.signal worker_thread_cond + ) ; + immediate + ) + in + if run_immediately then + callback () + else ( + D.debug "%s: rate limiting call from %s" __FUNCTION__ caller_details ; + safe_observe "on_start" on_start + ) + +(* Block and execute on the same thread *) +let submit_sync bucket_data ?observer ~callback ~caller_details amount = + check_not_terminated bucket_data.should_terminate ; + let on_start, on_end = + match observer with + | Some {on_start; on_end} -> + (on_start, on_end) + | None -> + (noop, noop) + in + let channel_opt = + with_lock bucket_data.process_queue_lock (fun () -> + if + Queue.is_empty bucket_data.process_queue + && Token_bucket.consume bucket_data.bucket amount + then + None + (* Can run callback immediately after releasing lock *) + else + (* Rate limited, need to retrieve function result via channel *) + let channel = Event.new_channel () in + Queue.add + { + cost= amount + ; callback= (fun () -> Event.sync (Event.send channel ())) + ; on_worker_end= noop + } + bucket_data.process_queue ; + Condition.signal bucket_data.worker_thread_cond ; + Some channel + ) + in + match channel_opt with + | None -> + callback () + | Some channel -> + D.debug "%s: rate limiting call from %s" __FUNCTION__ caller_details ; + safe_observe "on_start" on_start ; + Event.sync (Event.receive channel) ; + safe_observe "on_end" on_end ; + callback () diff --git a/ocaml/libs/rate-limit/rate_limit.mli b/ocaml/libs/rate-limit/rate_limit.mli new file mode 100644 index 00000000000..20987a72e2d --- /dev/null +++ b/ocaml/libs/rate-limit/rate_limit.mli @@ -0,0 +1,61 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Rate limiter built on top of a token bucket. Provides async and sync + submission of callbacks that are rate-limited. Uses a worker thread + to process queued callbacks when tokens become available. *) + +type t + +val create : burst_size:float -> fill_rate:float -> t +(** [create ~burst_size ~fill_rate] creates a new rate limiter with the given + token bucket parameters. + @raises Invalid_argument if the parameters are invalid + (e.g. non-positive fill rate). + @param burst_size Maximum number of tokens in the bucket + @param fill_rate Number of tokens added per second *) + +val delete : t -> unit +(** [delete t] signals the worker thread to terminate. The worker thread + processes any remaining queued callbacks, then exits. Blocks the caller + until the worker thread has finished. Subsequent calls to [submit_async] + or [submit_sync] will raise [Invalid_argument]. *) + +type delay_observer = {on_start: unit -> unit; on_end: unit -> unit} + +val submit_async : + t + -> ?observer:delay_observer + -> callback:(unit -> unit) + -> caller_details:string + -> float + -> unit +(** [submit_async t ~callback amount] submits a callback under rate limiting. + If tokens are immediately available and no callbacks are queued, the + callback runs synchronously on the calling thread. Otherwise it is + enqueued and will be executed by a worker thread when tokens become + available. Returns immediately. *) + +val submit_sync : + t + -> ?observer:delay_observer + -> callback:(unit -> 'a) + -> caller_details:string + -> float + -> 'a +(** [submit_sync t ~callback amount] submits a callback under rate limiting + and blocks until it completes, returning the callback's result. If tokens + are immediately available and no callbacks are queued, the callback runs + directly. Otherwise, the caller blocks until the worker thread signals + that tokens are available. *) diff --git a/ocaml/libs/rate-limit/test/dune b/ocaml/libs/rate-limit/test/dune new file mode 100644 index 00000000000..ee7027bcd1f --- /dev/null +++ b/ocaml/libs/rate-limit/test/dune @@ -0,0 +1,4 @@ +(tests + (names test_token_bucket test_rate_limit test_linked_list test_lru test_caller_table test_caller_statistics) + (package xapi-rate-limit) + (libraries rate_limit_lib alcotest qcheck-core qcheck-alcotest mtime mtime.clock.os fmt xapi-log threads.posix)) diff --git a/ocaml/libs/rate-limit/test/test_caller_statistics.ml b/ocaml/libs/rate-limit/test/test_caller_statistics.ml new file mode 100644 index 00000000000..e920b695153 --- /dev/null +++ b/ocaml/libs/rate-limit/test/test_caller_statistics.ml @@ -0,0 +1,124 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Caller_statistics = Rate_limit_lib.Caller_statistics + +let test_initial_state () = + let cs = Caller_statistics.create ~caller_uuid:"uuid-1" in + Alcotest.(check string) + "uuid is stored" "uuid-1" + (Caller_statistics.get_uuid cs) ; + Alcotest.(check int) + "initial call count is 0" 0 + (Caller_statistics.get_call_count cs) ; + Alcotest.(check (float 0.0)) + "initial token count is 0.0" 0.0 + (Caller_statistics.get_token_count cs) + +let test_single_register () = + let cs = Caller_statistics.create ~caller_uuid:"uuid-2" in + Caller_statistics.register_call ~token_amount:2.5 cs ; + Alcotest.(check int) + "count incremented" 1 + (Caller_statistics.get_call_count cs) ; + Alcotest.(check (float 0.0)) + "tokens accumulated" 2.5 + (Caller_statistics.get_token_count cs) + +(* Many threads, each registering many calls. The CAS retry loop must not lose + any updates — the final counts must equal the sum of every thread's + contributions. *) +let test_concurrent_register () = + let cs = Caller_statistics.create ~caller_uuid:"uuid-4" in + let num_threads = 16 in + let calls_per_thread = 500 in + let token_per_call = 0.25 in + let threads = + Array.init num_threads (fun _ -> + Thread.create + (fun () -> + for _ = 1 to calls_per_thread do + Caller_statistics.register_call ~token_amount:token_per_call cs + done + ) + () + ) + in + Array.iter Thread.join threads ; + let total_calls = num_threads * calls_per_thread in + Alcotest.(check int) + "no register_call updates were lost under contention" total_calls + (Caller_statistics.get_call_count cs) ; + Alcotest.(check (float 1e-6)) + "token sum matches total contributions" + (float_of_int total_calls *. token_per_call) + (Caller_statistics.get_token_count cs) + +(* Readers running concurrently with writers should never observe a torn + value: call_count and token_count come from the same atomic snapshot, + so token_count >= call_count * token_per_call at every observation. *) +let test_concurrent_reads_see_consistent_snapshot () = + let cs = Caller_statistics.create ~caller_uuid:"uuid-6" in + let num_writers = 4 in + let calls_per_writer = 1_000 in + let token_per_call = 1.0 in + let stop = Atomic.make false in + let inconsistencies = Atomic.make 0 in + let reader () = + while not (Atomic.get stop) do + let count = Caller_statistics.get_call_count cs in + let tokens = Caller_statistics.get_token_count cs in + let expected = float_of_int count *. token_per_call in + if abs_float (tokens -. expected) > 1e-9 then Atomic.incr inconsistencies + done + in + let writers = + Array.init num_writers (fun _ -> + Thread.create + (fun () -> + for _ = 1 to calls_per_writer do + Caller_statistics.register_call ~token_amount:token_per_call cs + done + ) + () + ) + in + let readers = Array.init 4 (fun _ -> Thread.create reader ()) in + Array.iter Thread.join writers ; + Atomic.set stop true ; + Array.iter Thread.join readers ; + Alcotest.(check int) + "readers never observed a torn count/token snapshot" 0 + (Atomic.get inconsistencies) ; + Alcotest.(check int) + "all writer updates landed" + (num_writers * calls_per_writer) + (Caller_statistics.get_call_count cs) + +let test = + [ + ("Initial state", `Quick, test_initial_state) + ; ("Single register updates all fields", `Quick, test_single_register) + ; ( "Concurrent register_call loses no updates" + , `Quick + , test_concurrent_register + ) + ; ( "Concurrent readers see a consistent snapshot" + , `Quick + , test_concurrent_reads_see_consistent_snapshot + ) + ] + +let () = + Alcotest.run "Caller statistics library" [("Caller statistics tests", test)] diff --git a/ocaml/libs/rate-limit/test/test_caller_statistics.mli b/ocaml/libs/rate-limit/test/test_caller_statistics.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/rate-limit/test/test_caller_table.ml b/ocaml/libs/rate-limit/test/test_caller_table.ml new file mode 100644 index 00000000000..a3016e1bc94 --- /dev/null +++ b/ocaml/libs/rate-limit/test/test_caller_table.ml @@ -0,0 +1,579 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Caller_table = Rate_limit_lib.Caller_table +open Caller_table.Key + +(* Build a target (Key.t) from a single string for the user_agent field. *) +let target s = {user_agent= s; client_ip= ""} + +(* Build a pattern_key with an exact-match user_agent and empty client_ip. *) +let pat s = {user_agent_pattern= Full s; client_ip_pattern= Full ""} + +let test_create () = + let table = Caller_table.create () in + Alcotest.(check (list int)) + "Empty table returns [] for get" [] + (Caller_table.get table ~caller_id:{user_agent= "test"; client_ip= ""}) + +let test_insert () = + let table = Caller_table.create () in + let success = + Caller_table.insert table + ~pattern:{user_agent_pattern= Full "test"; client_ip_pattern= Full ""} + 42 + in + Alcotest.(check bool) "Inserting should succeed" true success ; + Alcotest.(check (list int)) + "Get should return inserted value" [42] + (Caller_table.get table ~caller_id:{user_agent= "test"; client_ip= ""}) + +let test_insert_duplicate () = + let table = Caller_table.create () in + let success = Caller_table.insert table ~pattern:(pat "agent1") 1 in + Alcotest.(check bool) "First insert should succeed" true success ; + let success_dup = Caller_table.insert table ~pattern:(pat "agent1") 2 in + Alcotest.(check bool) "Inserting duplicate key should fail" false success_dup + +let test_delete () = + let table = Caller_table.create () in + let _ = Caller_table.insert table ~pattern:(pat "agent1") 42 in + Alcotest.(check (list int)) + "Entry exists before delete" [42] + (Caller_table.get table ~caller_id:(target "agent1")) ; + Caller_table.delete table ~pattern:(pat "agent1") ; + Alcotest.(check (list int)) + "Entry removed after delete" [] + (Caller_table.get table ~caller_id:(target "agent1")) + +let test_delete_nonexistent () = + let table = Caller_table.create () in + Caller_table.delete table ~pattern:(pat "nonexistent") ; + Alcotest.(check pass) "Deleting nonexistent entry should not raise" () () + +let test_get_nonexistent () = + let table = Caller_table.create () in + Alcotest.(check (list int)) + "Get nonexistent entry returns []" [] + (Caller_table.get table ~caller_id:(target "nonexistent")) + +let test_multiple_entries () = + let table = Caller_table.create () in + let _ = Caller_table.insert table ~pattern:(pat "agent1") 10 in + let _ = Caller_table.insert table ~pattern:(pat "agent2") 20 in + Alcotest.(check (list int)) + "Agent1 has correct value" [10] + (Caller_table.get table ~caller_id:(target "agent1")) ; + Alcotest.(check (list int)) + "Agent2 has correct value" [20] + (Caller_table.get table ~caller_id:(target "agent2")) + +let test_concurrent_insert_delete_stress () = + (* Stress test: rapidly insert and delete entries. *) + let table = Caller_table.create () in + let iterations = 1000 in + let num_keys = 10 in + let errors = ref 0 in + let errors_mutex = Mutex.create () in + let add_threads = + Array.init 5 (fun t -> + Thread.create + (fun () -> + for i = 0 to iterations - 1 do + let k = + Printf.sprintf "key%d" (((t * iterations) + i) mod num_keys) + in + let _ = Caller_table.insert table ~pattern:(pat k) i in + () + done + ) + () + ) + in + let delete_threads = + Array.init 5 (fun t -> + Thread.create + (fun () -> + for i = 0 to iterations - 1 do + let k = + Printf.sprintf "key%d" (((t * iterations) + i) mod num_keys) + in + Caller_table.delete table ~pattern:(pat k) + done + ) + () + ) + in + let read_threads = + Array.init 5 (fun t -> + Thread.create + (fun () -> + for i = 0 to iterations - 1 do + let k = + Printf.sprintf "key%d" (((t * iterations) + i) mod num_keys) + in + (* This should never crash, even if key doesn't exist *) + try + let _ = Caller_table.get table ~caller_id:(target k) in + () + with _ -> + Mutex.lock errors_mutex ; + incr errors ; + Mutex.unlock errors_mutex + done + ) + () + ) + in + Array.iter Thread.join add_threads ; + Array.iter Thread.join delete_threads ; + Array.iter Thread.join read_threads ; + Alcotest.(check int) "No errors during concurrent operations" 0 !errors + +let test_get_during_delete_race () = + (* Test that get doesn't crash when entry is being deleted. *) + let iterations = 500 in + let errors = ref 0 in + let errors_mutex = Mutex.create () in + for _ = 1 to iterations do + let table = Caller_table.create () in + let _ = Caller_table.insert table ~pattern:(pat "target") 42 in + let barrier = ref 0 in + let barrier_mutex = Mutex.create () in + let reader = + Thread.create + (fun () -> + Mutex.lock barrier_mutex ; + incr barrier ; + Mutex.unlock barrier_mutex ; + while + Mutex.lock barrier_mutex ; + let b = !barrier in + Mutex.unlock barrier_mutex ; b < 2 + do + Thread.yield () + done ; + try + let _ = Caller_table.get table ~caller_id:(target "target") in + () + with _ -> + Mutex.lock errors_mutex ; incr errors ; Mutex.unlock errors_mutex + ) + () + in + let deleter = + Thread.create + (fun () -> + Mutex.lock barrier_mutex ; + incr barrier ; + Mutex.unlock barrier_mutex ; + while + Mutex.lock barrier_mutex ; + let b = !barrier in + Mutex.unlock barrier_mutex ; b < 2 + do + Thread.yield () + done ; + Caller_table.delete table ~pattern:(pat "target") + ) + () + in + Thread.join reader ; Thread.join deleter + done ; + Alcotest.(check int) "No crashes during get/delete race" 0 !errors + +(* Wildcard matching tests *) + +let test_wildcard_user_agent_matches_any () = + (* An entry with a full-wildcard user_agent should match any user_agent *) + let table = Caller_table.create () in + let pattern = + {user_agent_pattern= Prefix ""; client_ip_pattern= Full "192.168.1.1"} + in + let _ = Caller_table.insert table ~pattern 1 in + (* Should match any user_agent with same client_ip *) + let client1 = {user_agent= "curl"; client_ip= "192.168.1.1"} in + let client2 = {user_agent= "wget"; client_ip= "192.168.1.1"} in + let client3 = {user_agent= ""; client_ip= "192.168.1.1"} in + Alcotest.(check bool) + "wildcard user_agent matches curl" true + (Caller_table.mem table ~caller_id:client1) ; + Alcotest.(check bool) + "wildcard user_agent matches wget" true + (Caller_table.mem table ~caller_id:client2) ; + Alcotest.(check bool) + "wildcard user_agent matches empty" true + (Caller_table.mem table ~caller_id:client3) ; + (* Should not match different client_ip *) + let client_other = {user_agent= "curl"; client_ip= "10.0.0.1"} in + Alcotest.(check bool) + "{user_agent=curl, client_ip=10.0.0.1} does not match {user_agent=*, \ + client_ip=192.168.1.1}" + false + (Caller_table.mem table ~caller_id:client_other) + +let test_wildcard_client_ip_matches_any () = + (* An entry with a full-wildcard client_ip should match any client_ip *) + let table = Caller_table.create () in + let pattern = + {user_agent_pattern= Full "curl"; client_ip_pattern= Prefix ""} + in + let _ = Caller_table.insert table ~pattern 1 in + (* Should match any client_ip with same user_agent *) + let client1 = {user_agent= "curl"; client_ip= "192.168.1.1"} in + let client2 = {user_agent= "curl"; client_ip= "10.0.0.1"} in + let client3 = {user_agent= "curl"; client_ip= ""} in + Alcotest.(check bool) + "wildcard client_ip matches 192.168.1.1" true + (Caller_table.mem table ~caller_id:client1) ; + Alcotest.(check bool) + "wildcard client_ip matches 10.0.0.1" true + (Caller_table.mem table ~caller_id:client2) ; + Alcotest.(check bool) + "wildcard client_ip matches empty" true + (Caller_table.mem table ~caller_id:client3) ; + (* Should not match different user_agent *) + let client_other = {user_agent= "wget"; client_ip= "192.168.1.1"} in + Alcotest.(check bool) + "wildcard does not match different user_agent" false + (Caller_table.mem table ~caller_id:client_other) + +let test_wildcard_match_priority_exact_first () = + (* Exact match should take priority over wildcards *) + let table = Caller_table.create () in + let exact = + {user_agent_pattern= Full "curl"; client_ip_pattern= Full "192.168.1.1"} + in + let wildcard_ua = + {user_agent_pattern= Prefix ""; client_ip_pattern= Full "192.168.1.1"} + in + let wildcard_ip = + {user_agent_pattern= Full "curl"; client_ip_pattern= Prefix ""} + in + (* Add in reverse priority order to test sorting *) + let _ = Caller_table.insert table ~pattern:wildcard_ua 5 in + let _ = Caller_table.insert table ~pattern:wildcard_ip 15 in + let _ = Caller_table.insert table ~pattern:exact 10 in + (* Lookup with exact key should return exact entry (10), not wildcards *) + let client = {user_agent= "curl"; client_ip= "192.168.1.1"} in + Alcotest.(check (list int)) + "matches ordered most-specific first: exact, prefix-ip, wildcard-ua" + [10; 15; 5] + (Caller_table.get table ~caller_id:client) + +let test_wildcard_match_priority_client_ip_over_user_agent () = + (* client_ip wildcard (user_agent specified) should match before + user_agent wildcard (client_ip specified) *) + let table = Caller_table.create () in + let wildcard_ua = + {user_agent_pattern= Prefix ""; client_ip_pattern= Full "192.168.1.1"} + in + let wildcard_ip = + {user_agent_pattern= Full "curl"; client_ip_pattern= Prefix ""} + in + (* Add user_agent wildcard first *) + let _ = Caller_table.insert table ~pattern:wildcard_ua 5 in + (* Add client_ip wildcard second *) + let _ = Caller_table.insert table ~pattern:wildcard_ip 15 in + (* Lookup should prefer client_ip wildcard (15) over user_agent wildcard (5) *) + let client = {user_agent= "curl"; client_ip= "192.168.1.1"} in + Alcotest.(check (list int)) + "client_ip wildcard ordered before user_agent wildcard" [15; 5] + (Caller_table.get table ~caller_id:client) + +let test_no_spurious_wildcard_matches () = + (* Ensure wildcards don't match when they shouldn't *) + let table = Caller_table.create () in + let pattern1 = + {user_agent_pattern= Full "curl"; client_ip_pattern= Full "192.168.1.1"} + in + let pattern2 = + {user_agent_pattern= Full "wget"; client_ip_pattern= Prefix ""} + in + let _ = Caller_table.insert table ~pattern:pattern1 10 in + let _ = Caller_table.insert table ~pattern:pattern2 20 in + (* Client with different user_agent and client_ip should not match pattern1 *) + let client1 = {user_agent= "curl"; client_ip= "10.0.0.1"} in + Alcotest.(check bool) + "{user_agent=curl, client_ip=10.0.0.1} does not match {user_agent=curl, \ + client_ip=192.168.1.1}" + false + (Caller_table.mem table ~caller_id:client1) ; + (* Client with matching user_agent but different client_ip should match pattern2 *) + let client2 = {user_agent= "wget"; client_ip= "10.0.0.1"} in + Alcotest.(check (list int)) + "{user_agent=wget, client_ip=10.0.0.1} matches {user_agent=wget, \ + client_ip=*} wildcard" + [20] + (Caller_table.get table ~caller_id:client2) ; + (* Client with no matching pattern *) + let client3 = {user_agent= "firefox"; client_ip= "172.16.0.1"} in + Alcotest.(check bool) + "{user_agent=firefox, client_ip=172.16.0.1} has no match" false + (Caller_table.mem table ~caller_id:client3) + +let test_lru_cache_overflow () = + (* The internal LRU cache has capacity 100. Insert a wildcard entry and + perform >100 distinct lookups so the cache overflows, then verify + lookups still return correct results after evictions. *) + let table = Caller_table.create () in + let pattern = + {user_agent_pattern= Full "curl"; client_ip_pattern= Prefix ""} + in + let _ = Caller_table.insert table ~pattern 42 in + (* Perform 150 distinct lookups to overflow the cache *) + for i = 1 to 150 do + let client = + {user_agent= "curl"; client_ip= Printf.sprintf "10.0.0.%d" i} + in + Alcotest.(check (list int)) + (Printf.sprintf "lookup %d returns correct value" i) + [42] + (Caller_table.get table ~caller_id:client) + done ; + (* Re-check the first few lookups which should have been evicted from + the cache; they must still resolve correctly via the table scan. *) + for i = 1 to 10 do + let client = + {user_agent= "curl"; client_ip= Printf.sprintf "10.0.0.%d" i} + in + Alcotest.(check (list int)) + (Printf.sprintf "re-lookup %d after eviction" i) + [42] + (Caller_table.get table ~caller_id:client) + done ; + (* Also check that a non-matching lookup still returns None *) + let miss = {user_agent= "wget"; client_ip= "10.0.0.1"} in + Alcotest.(check (list int)) + "non-matching lookup after overflow" [] + (Caller_table.get table ~caller_id:miss) + +let test_reject_all_wildcard_key () = + (* Patterns with both fields as full wildcards should be rejected *) + let table = Caller_table.create () in + let all_wildcard = + {user_agent_pattern= Prefix ""; client_ip_pattern= Prefix ""} + in + let success = Caller_table.insert table ~pattern:all_wildcard 1 in + Alcotest.(check bool) "all-wildcard key rejected" false success + +let test_prefix_wildcard_matches_prefix () = + let table = Caller_table.create () in + let pattern = + { + user_agent_pattern= Prefix "xen_api_libs/" + ; client_ip_pattern= Full "192.168.1.1" + } + in + let _ = Caller_table.insert table ~pattern 7 in + let matching = {user_agent= "xen_api_libs/1.2"; client_ip= "192.168.1.1"} in + let non_matching = {user_agent= "xen_api/1.2"; client_ip= "192.168.1.1"} in + Alcotest.(check (list int)) + "prefix wildcard matches xen_api_libs/1.2" [7] + (Caller_table.get table ~caller_id:matching) ; + Alcotest.(check (list int)) + "prefix wildcard does not match different prefix" [] + (Caller_table.get table ~caller_id:non_matching) + +let test_prefix_priority_over_full_wildcard () = + let table = Caller_table.create () in + let full = + {user_agent_pattern= Prefix ""; client_ip_pattern= Full "192.168.1.1"} + in + let prefix = + { + user_agent_pattern= Prefix "xen_api_libs/" + ; client_ip_pattern= Full "192.168.1.1" + } + in + let _ = Caller_table.insert table ~pattern:full 5 in + let _ = Caller_table.insert table ~pattern:prefix 9 in + let client = {user_agent= "xen_api_libs/1.2"; client_ip= "192.168.1.1"} in + Alcotest.(check (list int)) + "prefix match ordered before full wildcard" [9; 5] + (Caller_table.get table ~caller_id:client) + +let test_get_ordered_specificity_ladder () = + (* All eight insertable wildcard combinations match the same client. + Inserted in a deliberately scrambled order; get must return them + ordered by Key.compare (most specific first). *) + let table = Caller_table.create () in + let exact = + {user_agent_pattern= Full "curl/1.2"; client_ip_pattern= Full "192.168.1.1"} + in + let ua_exact_ip_prefix = + {user_agent_pattern= Full "curl/1.2"; client_ip_pattern= Prefix "192.168."} + in + let ua_prefix_ip_exact = + {user_agent_pattern= Prefix "curl/"; client_ip_pattern= Full "192.168.1.1"} + in + let ua_exact_ip_full = + {user_agent_pattern= Full "curl/1.2"; client_ip_pattern= Prefix ""} + in + let ua_prefix_ip_prefix = + {user_agent_pattern= Prefix "curl/"; client_ip_pattern= Prefix "192.168."} + in + let ua_full_ip_exact = + {user_agent_pattern= Prefix ""; client_ip_pattern= Full "192.168.1.1"} + in + let ua_prefix_ip_full = + {user_agent_pattern= Prefix "curl/"; client_ip_pattern= Prefix ""} + in + let ua_full_ip_prefix = + {user_agent_pattern= Prefix ""; client_ip_pattern= Prefix "192.168."} + in + (* Insert in a scrambled order to exercise the sorted-insert logic *) + let _ = Caller_table.insert table ~pattern:ua_prefix_ip_full 7 in + let _ = Caller_table.insert table ~pattern:exact 1 in + let _ = Caller_table.insert table ~pattern:ua_full_ip_prefix 8 in + let _ = Caller_table.insert table ~pattern:ua_prefix_ip_exact 3 in + let _ = Caller_table.insert table ~pattern:ua_exact_ip_full 4 in + let _ = Caller_table.insert table ~pattern:ua_full_ip_exact 6 in + let _ = Caller_table.insert table ~pattern:ua_exact_ip_prefix 2 in + let _ = Caller_table.insert table ~pattern:ua_prefix_ip_prefix 5 in + let client = {user_agent= "curl/1.2"; client_ip= "192.168.1.1"} in + Alcotest.(check (list int)) + "all eight overlapping patterns ordered most-specific first" + [1; 2; 3; 4; 5; 6; 7; 8] + (Caller_table.get table ~caller_id:client) + +let test_get_ordered_tiebreak_lex () = + (* When wildcard scores are identical, ties break lexicographically by + user_agent then client_ip. All three patterns are ua-prefix + ip-exact + (score (1,1,0)) and all match the client "abc/foo". *) + let table = Caller_table.create () in + let p_a = + {user_agent_pattern= Prefix "a"; client_ip_pattern= Full "10.0.0.1"} + in + let p_ab = + {user_agent_pattern= Prefix "ab"; client_ip_pattern= Full "10.0.0.1"} + in + let p_abc = + {user_agent_pattern= Prefix "abc"; client_ip_pattern= Full "10.0.0.1"} + in + (* Insert in reverse lex order *) + let _ = Caller_table.insert table ~pattern:p_abc 30 in + let _ = Caller_table.insert table ~pattern:p_ab 20 in + let _ = Caller_table.insert table ~pattern:p_a 10 in + let client = {user_agent= "abc/foo"; client_ip= "10.0.0.1"} in + (* Lex order: "a" < "ab" < "abc" *) + Alcotest.(check (list int)) + "equal wildcard scores tie-break by user_agent lex order" [10; 20; 30] + (Caller_table.get table ~caller_id:client) + +let test_get_ordered_tiebreak_client_ip () = + (* Ties on user_agent fall through to client_ip lex order. Patterns + have identical user_agent and the same wildcard scores, so client_ip + decides. *) + let table = Caller_table.create () in + let p1 = + {user_agent_pattern= Full "curl/1.2"; client_ip_pattern= Prefix "10.0."} + in + let p2 = + {user_agent_pattern= Full "curl/1.2"; client_ip_pattern= Prefix "10.0.0."} + in + let _ = Caller_table.insert table ~pattern:p2 200 in + let _ = Caller_table.insert table ~pattern:p1 100 in + let client = {user_agent= "curl/1.2"; client_ip= "10.0.0.5"} in + Alcotest.(check (list int)) + "equal user_agent + equal scores tie-break by client_ip lex order" + [100; 200] + (Caller_table.get table ~caller_id:client) + +let test_get_ordered_after_delete_reinsert () = + (* Sorting is preserved across mutation: delete a middle entry and + re-insert; the result list must still be ordered. *) + let table = Caller_table.create () in + let exact = + {user_agent_pattern= Full "curl"; client_ip_pattern= Full "1.2.3.4"} + in + let ua_full = + {user_agent_pattern= Prefix ""; client_ip_pattern= Full "1.2.3.4"} + in + let ip_full = + {user_agent_pattern= Full "curl"; client_ip_pattern= Prefix ""} + in + let _ = Caller_table.insert table ~pattern:ua_full 2 in + let _ = Caller_table.insert table ~pattern:exact 1 in + let _ = Caller_table.insert table ~pattern:ip_full 3 in + let client = {user_agent= "curl"; client_ip= "1.2.3.4"} in + Alcotest.(check (list int)) + "ordered before delete" [1; 3; 2] + (Caller_table.get table ~caller_id:client) ; + Caller_table.delete table ~pattern:ip_full ; + Alcotest.(check (list int)) + "ordered after delete" [1; 2] + (Caller_table.get table ~caller_id:client) ; + let _ = Caller_table.insert table ~pattern:ip_full 30 in + Alcotest.(check (list int)) + "ordered after re-insert in new position" [1; 30; 2] + (Caller_table.get table ~caller_id:client) + +let test = + [ + ("Create empty table", `Quick, test_create) + ; ("Insert entry", `Quick, test_insert) + ; ("Insert duplicate", `Quick, test_insert_duplicate) + ; ("Delete entry", `Quick, test_delete) + ; ("Delete nonexistent entry", `Quick, test_delete_nonexistent) + ; ("Get nonexistent", `Quick, test_get_nonexistent) + ; ("Multiple entries", `Quick, test_multiple_entries) + ; ( "Concurrent insert/delete stress" + , `Quick + , test_concurrent_insert_delete_stress + ) + ; ("Get during delete race", `Quick, test_get_during_delete_race) + ; ( "Wildcard user_agent matches any" + , `Quick + , test_wildcard_user_agent_matches_any + ) + ; ( "Wildcard client_ip matches any" + , `Quick + , test_wildcard_client_ip_matches_any + ) + ; ( "Wildcard priority: exact first" + , `Quick + , test_wildcard_match_priority_exact_first + ) + ; ( "Wildcard priority: client_ip over user_agent" + , `Quick + , test_wildcard_match_priority_client_ip_over_user_agent + ) + ; ("No spurious wildcard matches", `Quick, test_no_spurious_wildcard_matches) + ; ("Reject all-wildcard key", `Quick, test_reject_all_wildcard_key) + ; ("Prefix wildcard matches", `Quick, test_prefix_wildcard_matches_prefix) + ; ( "Prefix wildcard preferred over full wildcard" + , `Quick + , test_prefix_priority_over_full_wildcard + ) + ; ("LRU cache overflow", `Quick, test_lru_cache_overflow) + ; ( "Ordered retrieval: full specificity ladder" + , `Quick + , test_get_ordered_specificity_ladder + ) + ; ( "Ordered retrieval: lex tiebreak on user_agent" + , `Quick + , test_get_ordered_tiebreak_lex + ) + ; ( "Ordered retrieval: lex tiebreak on client_ip" + , `Quick + , test_get_ordered_tiebreak_client_ip + ) + ; ( "Ordered retrieval: preserved across delete and re-insert" + , `Quick + , test_get_ordered_after_delete_reinsert + ) + ] + +let () = Alcotest.run "Client table library" [("Client table tests", test)] diff --git a/ocaml/libs/rate-limit/test/test_caller_table.mli b/ocaml/libs/rate-limit/test/test_caller_table.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/rate-limit/test/test_linked_list.ml b/ocaml/libs/rate-limit/test/test_linked_list.ml new file mode 100644 index 00000000000..aeecdffac03 --- /dev/null +++ b/ocaml/libs/rate-limit/test/test_linked_list.ml @@ -0,0 +1,112 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module LL = Rate_limit_lib.Linked_list + +(* Generators *) +let chars = + let open QCheck in + list_of_size Gen.(int_range 0 50) char + +let ints = + let open QCheck in + list_of_size Gen.(int_range 0 50) int + +let count = 1000 + +let test_ll_from_to_list = + QCheck.Test.make ~name:"LL from_list/to_list roundtrip" chars ~count + @@ fun chars -> + let t = LL.from_list chars in + LL.to_list t = chars + +let test_ll_append_drop = + QCheck.Test.make ~name:"LL append and drop" chars ~count @@ fun chars -> + let open LL in + let t = from_list chars in + let x = node 'x' in + let y = node 'y' in + let z = node 'z' in + List.iter (append t) [x; y; z] ; + assert (match last t with Some z -> value z = 'z' | None -> false) ; + List.iter (drop t) [y; z; x] ; + to_list t = chars + +let test_ll_fold = + QCheck.Test.make ~name:"LL foldl/foldr consistency" ints ~count @@ fun ints -> + let total = List.fold_left ( + ) 0 ints in + let open LL in + let t = from_list ints in + List.for_all (( = ) total) [foldl ( + ) 0 t; foldr ( + ) t 0] + +let test_ll_compare_matches_list_compare = + QCheck.Test.make ~name:"LL compare matches List.compare" + QCheck.(pair ints ints) + ~count + @@ fun (xs, ys) -> + let got = LL.compare Int.compare (LL.from_list xs) (LL.from_list ys) in + let expected = List.compare Int.compare xs ys in + Int.compare got 0 = Int.compare expected 0 + +let test_ll_equal_same = + QCheck.Test.make ~name:"LL equal: same contents" ints ~count @@ fun xs -> + LL.equal (LL.from_list xs) (LL.from_list xs) + +let test_ll_equal_matches_value_equality = + QCheck.Test.make ~name:"LL equal matches structural equality on values" + QCheck.(pair ints ints) + ~count + @@ fun (xs, ys) -> LL.equal (LL.from_list xs) (LL.from_list ys) = (xs = ys) + +(* Wire last.next back to first, manufacturing a cycle. + Uses Obj because the node type is abstract; field layout is + { value=0; prev=1; next=2 }. *) +let make_cyclic xs = + let t = LL.from_list xs in + ( match (LL.first t, LL.last t) with + | Some _, Some last -> + Obj.set_field (Obj.repr last) 2 (Obj.repr (LL.first t)) + | _ -> + () + ) ; + t + +let cyclic_tests = + [ + Alcotest.test_case "compare terminates on cyclic list" `Quick (fun () -> + let t1 = make_cyclic [1; 2; 3] in + let t2 = make_cyclic [1; 2; 3] in + ignore (LL.compare Int.compare t1 t2) + ) + ; Alcotest.test_case "equal terminates on cyclic list" `Quick (fun () -> + let t1 = make_cyclic [1; 2; 3] in + let t2 = make_cyclic [1; 2; 3] in + ignore (LL.equal t1 t2) + ) + ] + +let property_tests = + List.map QCheck_alcotest.to_alcotest + [ + test_ll_from_to_list + ; test_ll_append_drop + ; test_ll_fold + ; test_ll_compare_matches_list_compare + ; test_ll_equal_same + ; test_ll_equal_matches_value_equality + ] + +let () = + Alcotest.run "Linked list library" + [("Linked list tests", property_tests); ("Cycle termination", cyclic_tests)] diff --git a/ocaml/libs/rate-limit/test/test_linked_list.mli b/ocaml/libs/rate-limit/test/test_linked_list.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/rate-limit/test/test_lru.ml b/ocaml/libs/rate-limit/test/test_lru.ml new file mode 100644 index 00000000000..a8b0f151e0c --- /dev/null +++ b/ocaml/libs/rate-limit/test/test_lru.ml @@ -0,0 +1,202 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module LRU = Rate_limit_lib.Lru + +(* Generators *) +let kvs = + let open QCheck in + list_of_size Gen.(int_range 1 20) (pair char int) + +let lru = + let open QCheck in + kvs + |> map @@ fun kvs -> + let lru = LRU.create (List.length kvs) in + List.iter (fun (k, v) -> LRU.add lru k v |> ignore) kvs ; + lru + +(* Tests *) + +let count = 1000 + +let test_lru_length = + QCheck.Test.make ~name:"LRU length matches to_list" lru ~count @@ fun lru -> + LRU.to_list lru |> List.length = LRU.size lru + +let test_lru_drop = + QCheck.Test.make ~name:"LRU drop_while evicts all" lru ~count @@ fun lru -> + let evict (_, _) _ = true in + LRU.drop_while ~evict lru ; + LRU.size lru = 0 && LRU.cap lru > 0 + +(** add a new value but make room if the cache is full *) +let add lru (key, value) = + match LRU.add lru key value with true -> LRU.trim lru | false -> () + +(** The test takes a full cache and adds more elements but now elements + are trimmed such that the cache does not grow *) +let test_lru_growth = + QCheck.Test.make ~name:"LRU growth respects capacity" + QCheck.(pair lru kvs) + ~count + @@ fun (lru, kvs) -> + List.iter (add lru) kvs ; + LRU.size lru <= LRU.cap lru + +(* We expect to find all keys; we sort the keys before looking them up. + The least recently used key should be the head of that list *) +let test_lru_lookup = + QCheck.Test.make ~name:"LRU lookup finds all keys" lru ~count @@ fun lru -> + let sort = List.sort_uniq Char.compare in + let keys = List.map fst (LRU.to_list lru) |> sort in + let lookup key = + match LRU.lookup lru key with + | Some _ -> + () + | None -> + failwith "failed to find key" + in + List.iter lookup keys ; + LRU.to_list lru |> List.map fst |> sort = keys + +let test_lru_add_trim_growth = + QCheck.Test.make ~name:"LRU add_trim respects capacity" + QCheck.(pair lru kvs) + ~count + @@ fun (lru, kvs) -> + List.iter (fun (k, v) -> LRU.add_trim lru k v) kvs ; + LRU.size lru <= LRU.cap lru + +let test_lru_add_trim_equivalent = + QCheck.Test.make ~name:"LRU add_trim equivalent to add+trim" + QCheck.(pair kvs kvs) + ~count + @@ fun (init, extra) -> + let lru_at = LRU.create (max 1 (List.length init)) in + let lru_sep = LRU.create (max 1 (List.length init)) in + List.iter (fun (k, v) -> LRU.add_trim lru_at k v) init ; + List.iter (fun (k, v) -> add lru_sep (k, v)) init ; + List.iter (fun (k, v) -> LRU.add_trim lru_at k v) extra ; + List.iter (fun (k, v) -> add lru_sep (k, v)) extra ; + LRU.to_list lru_at = LRU.to_list lru_sep + +(* [filter] tests *) + +let test_lru_filter_keep_all = + QCheck.Test.make ~name:"LRU filter ~f:(fun _ _ -> true) preserves contents" + lru ~count + @@ fun lru -> + let kept = LRU.filter lru ~f:(fun _ _ -> true) in + LRU.to_list kept = LRU.to_list lru + && LRU.cap kept = LRU.cap lru + && LRU.size kept = LRU.size lru + +let test_lru_filter_drop_all = + QCheck.Test.make ~name:"LRU filter ~f:(fun _ _ -> false) empties the cache" + lru ~count + @@ fun lru -> + let dropped = LRU.filter lru ~f:(fun _ _ -> false) in + LRU.size dropped = 0 && LRU.cap dropped = LRU.cap lru + +let test_lru_filter_does_not_mutate_source = + QCheck.Test.make ~name:"LRU filter does not mutate the source cache" lru + ~count + @@ fun lru -> + let before = LRU.to_list lru in + let _ = LRU.filter lru ~f:(fun (k : char) _ -> Char.code k mod 2 = 0) in + LRU.to_list lru = before + +let test_lru_filter_predicate_correct = + QCheck.Test.make ~name:"LRU filter keeps exactly the matching entries" lru + ~count + @@ fun lru -> + let keep k _ = Char.code k mod 2 = 0 in + let kept = LRU.filter lru ~f:keep in + let expected = List.filter (fun (k, v) -> keep k v) (LRU.to_list lru) in + LRU.to_list kept = expected + +let test_lru_filter_preserves_lru_order = + QCheck.Test.make ~name:"LRU filter preserves LRU order of survivors" lru + ~count + @@ fun lru -> + let keep k _ = Char.code k mod 3 <> 0 in + let kept = LRU.filter lru ~f:keep in + let survivors = + List.filter_map + (fun (k, v) -> + if keep k v then + Some k + else + None + ) + (LRU.to_list lru) + in + List.map fst (LRU.to_list kept) = survivors + +let test_lru_filter_result_usable = + (* Stress test: after a filter, the resulting LRU must still behave like a + normal LRU — lookups update LRU order, add+trim respects capacity, and + adding distinct keys beyond capacity evicts the oldest first. *) + QCheck.Test.make ~name:"LRU filter result behaves like a normal LRU" + QCheck.(pair lru kvs) + ~count + @@ fun (lru, extras) -> + let kept = LRU.filter lru ~f:(fun k _ -> Char.code k mod 2 = 0) in + (* lookups on surviving keys succeed *) + let surviving_keys = List.map fst (LRU.to_list kept) in + List.iter + (fun k -> + match LRU.lookup kept k with + | Some _ -> + () + | None -> + failwith "filter dropped a key it should have kept" + ) + surviving_keys ; + (* now add a bunch of extras; capacity must be respected *) + List.iter (fun (k, v) -> LRU.add_trim kept k v) extras ; + LRU.size kept <= LRU.cap kept + +let test_lru_filter_repeated = + (* Stress test: alternating filter operations on the same LRU should be + idempotent in the sense that filtering with the same predicate twice + yields the same result as filtering once, and composing filters is + equivalent to a single combined predicate. *) + QCheck.Test.make ~name:"LRU filter composes" lru ~count @@ fun lru -> + let p1 k _ = Char.code k mod 2 = 0 in + let p2 _ v = v mod 3 = 0 in + let combined k v = p1 k () && p2 () v in + let a = LRU.filter (LRU.filter lru ~f:p1) ~f:p2 in + let b = LRU.filter lru ~f:combined in + LRU.to_list a = LRU.to_list b + +let test = + [ + QCheck_alcotest.to_alcotest test_lru_length + ; QCheck_alcotest.to_alcotest test_lru_drop + ; QCheck_alcotest.to_alcotest test_lru_growth + ; QCheck_alcotest.to_alcotest test_lru_lookup + ; QCheck_alcotest.to_alcotest test_lru_add_trim_growth + ; QCheck_alcotest.to_alcotest test_lru_add_trim_equivalent + ; QCheck_alcotest.to_alcotest test_lru_filter_keep_all + ; QCheck_alcotest.to_alcotest test_lru_filter_drop_all + ; QCheck_alcotest.to_alcotest test_lru_filter_does_not_mutate_source + ; QCheck_alcotest.to_alcotest test_lru_filter_predicate_correct + ; QCheck_alcotest.to_alcotest test_lru_filter_preserves_lru_order + ; QCheck_alcotest.to_alcotest test_lru_filter_result_usable + ; QCheck_alcotest.to_alcotest test_lru_filter_repeated + ] + +let () = Alcotest.run "LRU library" [("LRU tests", test)] diff --git a/ocaml/libs/rate-limit/test/test_lru.mli b/ocaml/libs/rate-limit/test/test_lru.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/rate-limit/test/test_rate_limit.ml b/ocaml/libs/rate-limit/test/test_rate_limit.ml new file mode 100644 index 00000000000..7a2a2bee317 --- /dev/null +++ b/ocaml/libs/rate-limit/test/test_rate_limit.ml @@ -0,0 +1,404 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Rate_limit = Rate_limit_lib.Rate_limit + +let test_create_invalid () = + Alcotest.match_raises "Creating with zero fill rate should raise" + (function Invalid_argument _ -> true | _ -> false) + (fun () -> ignore (Rate_limit.create ~burst_size:10.0 ~fill_rate:0.0)) ; + Alcotest.match_raises "Creating with negative fill rate should raise" + (function Invalid_argument _ -> true | _ -> false) + (fun () -> ignore (Rate_limit.create ~burst_size:10.0 ~fill_rate:(-1.0))) + +let test_submit () = + let rl = Rate_limit.create ~burst_size:10.0 ~fill_rate:10.0 in + (* Drain the bucket *) + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 10.0 ; + let executed = ref false in + let start_counter = Mtime_clock.counter () in + Rate_limit.submit_async rl + ~callback:(fun () -> executed := true) + ~caller_details:"" 5.0 ; + let elapsed_span = Mtime_clock.count start_counter in + let elapsed_seconds = Mtime.Span.to_float_ns elapsed_span *. 1e-9 in + (* submit should return immediately (non-blocking) *) + Alcotest.(check bool) "submit returns immediately" true (elapsed_seconds < 0.1) ; + (* Wait for callback to be executed by worker *) + Thread.delay 0.6 ; + Alcotest.(check bool) "callback eventually executed" true !executed ; + Rate_limit.delete rl + +let test_submit_fairness () = + (* Test that callbacks are executed in FIFO order regardless of token cost *) + let rl = Rate_limit.create ~burst_size:5.0 ~fill_rate:5.0 in + (* Drain the bucket *) + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 5.0 ; + let execution_order = ref [] in + let order_mutex = Mutex.create () in + let record_execution id = + Mutex.lock order_mutex ; + execution_order := id :: !execution_order ; + Mutex.unlock order_mutex + in + (* Submit callbacks with varying costs - order should be preserved *) + Rate_limit.submit_async rl + ~callback:(fun () -> record_execution 1) + ~caller_details:"" 1.0 ; + Rate_limit.submit_async rl + ~callback:(fun () -> record_execution 2) + ~caller_details:"" 3.0 ; + Rate_limit.submit_async rl + ~callback:(fun () -> record_execution 3) + ~caller_details:"" 1.0 ; + Rate_limit.submit_async rl + ~callback:(fun () -> record_execution 4) + ~caller_details:"" 2.0 ; + (* Wait for all callbacks to complete (total cost = 7 tokens, rate = 5/s) *) + Thread.delay 2.0 ; + let order = List.rev !execution_order in + Alcotest.(check (list int)) + "callbacks execute in FIFO order" [1; 2; 3; 4] order ; + Rate_limit.delete rl + +let test_submit_sync () = + let rl = Rate_limit.create ~burst_size:10.0 ~fill_rate:10.0 in + (* Test 1: Returns callback result immediately when tokens available *) + let result = + Rate_limit.submit_sync rl ~callback:(fun () -> 42) ~caller_details:"" 5.0 + in + Alcotest.(check int) "returns callback result" 42 result ; + (* Test 2: Blocks and waits for tokens, then returns result *) + (* Drain the bucket *) + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 5.0 ; + let start_counter = Mtime_clock.counter () in + let result2 = + Rate_limit.submit_sync rl + ~callback:(fun () -> "hello") + ~caller_details:"" 5.0 + in + let elapsed_span = Mtime_clock.count start_counter in + let elapsed_seconds = Mtime.Span.to_float_ns elapsed_span *. 1e-9 in + Alcotest.(check string) "returns string result" "hello" result2 ; + Alcotest.(check bool) + "blocked waiting for tokens" true (elapsed_seconds >= 0.4) ; + Rate_limit.delete rl + +let test_submit_sync_with_queued_items () = + (* Test that submit_sync respects FIFO ordering when queue has items *) + let rl = Rate_limit.create ~burst_size:5.0 ~fill_rate:10.0 in + (* Drain the bucket *) + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 5.0 ; + let execution_order = ref [] in + let order_mutex = Mutex.create () in + let record_execution id = + Mutex.lock order_mutex ; + execution_order := id :: !execution_order ; + Mutex.unlock order_mutex + in + (* Submit async items first *) + Rate_limit.submit_async rl + ~callback:(fun () -> record_execution 1) + ~caller_details:"" 1.0 ; + Rate_limit.submit_async rl + ~callback:(fun () -> record_execution 2) + ~caller_details:"" 1.0 ; + (* Now submit_sync should queue behind the async items *) + let result = + Rate_limit.submit_sync rl + ~callback:(fun () -> record_execution 3 ; "sync_result") + ~caller_details:"" 1.0 + in + Alcotest.(check string) + "submit_sync returns correct result" "sync_result" result ; + let order = List.rev !execution_order in + Alcotest.(check (list int)) + "submit_sync executes after queued items" [1; 2; 3] order ; + Rate_limit.delete rl + +let test_submit_sync_concurrent () = + (* Test multiple concurrent submit_sync calls *) + let rl = Rate_limit.create ~burst_size:1.0 ~fill_rate:10.0 in + (* Drain the bucket to force queueing *) + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 1.0 ; + let results = Array.make 5 0 in + let threads = + Array.init 5 (fun i -> + Thread.create + (fun () -> + let r = + Rate_limit.submit_sync rl + ~callback:(fun () -> i + 1) + ~caller_details:"" 1.0 + in + results.(i) <- r + ) + () + ) + in + Array.iter Thread.join threads ; + (* Each thread should get its own result back *) + for i = 0 to 4 do + Alcotest.(check int) + (Printf.sprintf "thread %d gets correct result" i) + (i + 1) results.(i) + done ; + Rate_limit.delete rl + +let test_no_skip_ahead_during_worker_delay () = + (* A caller arriving while the worker is delaying the only queued item + must not skip ahead of it. The queued item has a large cost so the + worker's delay is long enough for the bucket to refill enough that a + newly-arriving cheap caller could opportunistically consume without + the fix. *) + let rl = Rate_limit.create ~burst_size:10.0 ~fill_rate:100.0 in + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 10.0 ; + let execution_order = ref [] in + let order_mutex = Mutex.create () in + let record_execution id = + Mutex.lock order_mutex ; + execution_order := id :: !execution_order ; + Mutex.unlock order_mutex + in + Rate_limit.submit_async rl + ~callback:(fun () -> record_execution 1) + ~caller_details:"" 10.0 ; + Thread.delay 0.02 ; + Rate_limit.submit_async rl + ~callback:(fun () -> record_execution 2) + ~caller_details:"" 1.0 ; + Thread.delay 0.2 ; + let order = List.rev !execution_order in + Alcotest.(check (list int)) + "late arrival does not overtake queued item" [1; 2] order ; + Rate_limit.delete rl + +let test_submit_sync_interleaved () = + (* Test interleaving submit and submit_sync *) + let rl = Rate_limit.create ~burst_size:2.0 ~fill_rate:10.0 in + (* Drain the bucket *) + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 2.0 ; + let async_executed = ref false in + (* Submit async first *) + Rate_limit.submit_async rl + ~callback:(fun () -> async_executed := true) + ~caller_details:"" 1.0 ; + (* Submit sync should wait for async to complete first *) + let sync_result = + Rate_limit.submit_sync rl + ~callback:(fun () -> !async_executed) + ~caller_details:"" 1.0 + in + Alcotest.(check bool) + "sync callback sees async already executed" true sync_result ; + Rate_limit.delete rl + +(* A recording observer used by the tests below. [event] captures ordering of + observer callbacks relative to the user callback via monotonically-increasing + timestamps, which is what we want to assert. *) +let make_recording_observer () = + let mtx = Mutex.create () in + let started = ref 0 in + let ended = ref 0 in + let start_time = ref None in + let end_time = ref None in + let stamp r = + Mutex.lock mtx ; + r := Some (Mtime_clock.now ()) ; + Mutex.unlock mtx + in + let bump c = Mutex.lock mtx ; incr c ; Mutex.unlock mtx in + let observer = + Rate_limit. + { + on_start= (fun () -> bump started ; stamp start_time) + ; on_end= (fun () -> bump ended ; stamp end_time) + } + in + (observer, fun () -> (!started, !ended, !start_time, !end_time)) + +let test_observer_not_fired_when_immediate () = + let rl = Rate_limit.create ~burst_size:10.0 ~fill_rate:10.0 in + let observer, snapshot = make_recording_observer () in + let result = + Rate_limit.submit_sync rl ~observer + ~callback:(fun () -> 42) + ~caller_details:"" 1.0 + in + Alcotest.(check int) "callback ran" 42 result ; + let started, ended, _, _ = snapshot () in + Alcotest.(check int) "on_start not fired" 0 started ; + Alcotest.(check int) "on_end not fired" 0 ended ; + let observer2, snapshot2 = make_recording_observer () in + Rate_limit.submit_async rl ~observer:observer2 + ~callback:(fun () -> ()) + ~caller_details:"" 1.0 ; + let started2, ended2, _, _ = snapshot2 () in + Alcotest.(check int) "async on_start not fired" 0 started2 ; + Alcotest.(check int) "async on_end not fired" 0 ended2 ; + Rate_limit.delete rl + +let test_observer_fired_when_delayed_sync () = + let rl = Rate_limit.create ~burst_size:1.0 ~fill_rate:5.0 in + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 1.0 ; + let observer, snapshot = make_recording_observer () in + let callback_seen_end = ref false in + let ended_before_cb = ref false in + let _ = + Rate_limit.submit_sync rl ~observer + ~callback:(fun () -> + let _, ended, _, _ = snapshot () in + ended_before_cb := ended = 1 ; + callback_seen_end := true + ) + ~caller_details:"" 1.0 + in + let started, ended, start_time, end_time = snapshot () in + Alcotest.(check int) "on_start fired once" 1 started ; + Alcotest.(check int) "on_end fired once" 1 ended ; + Alcotest.(check bool) "callback ran" true !callback_seen_end ; + Alcotest.(check bool) + "on_end observed before callback runs" true !ended_before_cb ; + ( match (start_time, end_time) with + | Some s, Some e -> + Alcotest.(check bool) + "on_start precedes on_end" true + (Mtime.is_earlier s ~than:e || Mtime.equal s e) + | _ -> + Alcotest.fail "timestamps missing" + ) ; + Rate_limit.delete rl + +let test_observer_fired_when_delayed_async () = + let rl = Rate_limit.create ~burst_size:1.0 ~fill_rate:5.0 in + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 1.0 ; + let observer, snapshot = make_recording_observer () in + let done_mtx = Mutex.create () in + let done_cond = Condition.create () in + let ran = ref false in + let ended_before_cb = ref false in + Rate_limit.submit_async rl ~observer + ~callback:(fun () -> + let _, ended, _, _ = snapshot () in + ended_before_cb := ended = 1 ; + Mutex.lock done_mtx ; + ran := true ; + Condition.signal done_cond ; + Mutex.unlock done_mtx + ) + ~caller_details:"" 1.0 ; + let started_immediately, _, _, _ = snapshot () in + Alcotest.(check int) + "on_start fires synchronously on caller thread" 1 started_immediately ; + Mutex.lock done_mtx ; + while not !ran do + Condition.wait done_cond done_mtx + done ; + Mutex.unlock done_mtx ; + let started, ended, _, _ = snapshot () in + Alcotest.(check int) "on_start fired once" 1 started ; + Alcotest.(check int) "on_end fired once" 1 ended ; + Alcotest.(check bool) + "on_end observed before callback ran" true !ended_before_cb ; + Rate_limit.delete rl + +let test_observer_exception_isolated () = + let rl = Rate_limit.create ~burst_size:1.0 ~fill_rate:20.0 in + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 1.0 ; + let raising_observer = + Rate_limit. + { + on_start= (fun () -> failwith "boom on_start") + ; on_end= (fun () -> failwith "boom on_end") + } + in + (* Async: raising observer must not stop the callback or crash the worker. *) + let done_mtx = Mutex.create () in + let done_cond = Condition.create () in + let ran_first = ref false in + Rate_limit.submit_async rl ~observer:raising_observer + ~callback:(fun () -> + Mutex.lock done_mtx ; + ran_first := true ; + Condition.signal done_cond ; + Mutex.unlock done_mtx + ) + ~caller_details:"" 1.0 ; + Mutex.lock done_mtx ; + while not !ran_first do + Condition.wait done_cond done_mtx + done ; + Mutex.unlock done_mtx ; + Alcotest.(check bool) + "async callback ran despite observer raising" true !ran_first ; + (* Now confirm the worker is still healthy and processes further items. *) + let ran_second = ref false in + Rate_limit.submit_async rl + ~callback:(fun () -> + Mutex.lock done_mtx ; + ran_second := true ; + Condition.signal done_cond ; + Mutex.unlock done_mtx + ) + ~caller_details:"" 1.0 ; + Mutex.lock done_mtx ; + while not !ran_second do + Condition.wait done_cond done_mtx + done ; + Mutex.unlock done_mtx ; + Alcotest.(check bool) "worker still processes later items" true !ran_second ; + (* Sync: raising observer must not reach the caller as an exception. *) + Rate_limit.submit_async rl ~callback:(fun () -> ()) ~caller_details:"" 1.0 ; + let sync_ran = ref false in + let sync_result = + Rate_limit.submit_sync rl ~observer:raising_observer + ~callback:(fun () -> + sync_ran := true ; + 7 + ) + ~caller_details:"" 1.0 + in + Alcotest.(check int) "sync callback returned normally" 7 sync_result ; + Alcotest.(check bool) "sync callback ran" true !sync_ran ; + Rate_limit.delete rl + +let test = + [ + ("Create invalid", `Quick, test_create_invalid) + ; ("Submit", `Slow, test_submit) + ; ("Submit fairness", `Slow, test_submit_fairness) + ; ("Submit sync", `Slow, test_submit_sync) + ; ("Submit sync with queue", `Slow, test_submit_sync_with_queued_items) + ; ("Submit sync concurrent", `Slow, test_submit_sync_concurrent) + ; ("Submit sync interleaved", `Slow, test_submit_sync_interleaved) + ; ( "No skip-ahead during worker delay" + , `Slow + , test_no_skip_ahead_during_worker_delay + ) + ; ( "Observer not fired when immediate" + , `Quick + , test_observer_not_fired_when_immediate + ) + ; ( "Observer fired when delayed sync" + , `Slow + , test_observer_fired_when_delayed_sync + ) + ; ( "Observer fired when delayed async" + , `Slow + , test_observer_fired_when_delayed_async + ) + ; ("Observer exception isolated", `Slow, test_observer_exception_isolated) + ] + +let () = Alcotest.run "Rate limit library" [("Rate limit tests", test)] diff --git a/ocaml/libs/rate-limit/test/test_rate_limit.mli b/ocaml/libs/rate-limit/test/test_rate_limit.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/rate-limit/test/test_token_bucket.ml b/ocaml/libs/rate-limit/test/test_token_bucket.ml new file mode 100644 index 00000000000..988dfd07aeb --- /dev/null +++ b/ocaml/libs/rate-limit/test/test_token_bucket.ml @@ -0,0 +1,511 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Token_bucket = Rate_limit_lib.Token_bucket + +let test_bad_fill_rate () = + Alcotest.match_raises "Creating a token bucket with 0 fill rate should fail" + (function Invalid_argument _ -> true | _ -> false) + (fun () -> ignore (Token_bucket.create ~burst_size:1.0 ~fill_rate:0.0)) ; + Alcotest.match_raises + "Creating a token bucket with negative fill rate should fail" + (function Invalid_argument _ -> true | _ -> false) + (fun () -> ignore (Token_bucket.create ~burst_size:1.0 ~fill_rate:(-1.0))) + +let test_consume_removes_correct_amount () = + let initial_time = Mtime.Span.of_uint64_ns 0L in + let tb = + Token_bucket.create_with_timestamp initial_time ~burst_size:10.0 + ~fill_rate:2.0 + in + + Alcotest.(check (float 0.0)) + "Initial tokens should be burst_size" 10.0 + (Token_bucket.peek_with_timestamp initial_time tb) ; + + let consume_time = Mtime.Span.of_uint64_ns 1_000_000_000L in + let success = + Token_bucket.consume_with_timestamp (fun () -> consume_time) tb 3.0 + in + Alcotest.(check bool) "Consume 3 tokens should succeed" true success ; + Alcotest.(check (float 0.0)) + "After consume, tokens should be 7" 7.0 + (Token_bucket.peek_with_timestamp consume_time tb) + +let test_consume_more_than_available () = + let initial_time = Mtime.Span.of_uint64_ns 0L in + let tb = + Token_bucket.create_with_timestamp initial_time ~burst_size:5.0 + ~fill_rate:1.0 + in + + let _ = Token_bucket.consume_with_timestamp (fun () -> initial_time) tb 4.0 in + + let consume_time = Mtime.Span.of_uint64_ns 1_000_000_000L in + let success = + Token_bucket.consume_with_timestamp (fun () -> consume_time) tb 10.0 + in + Alcotest.(check bool) "Consume more than available should fail" false success ; + Alcotest.(check (float 0.0)) + "After failed consume, tokens should be 2" 2.0 + (Token_bucket.peek_with_timestamp consume_time tb) + +let test_consume_refills_before_removing () = + let initial_time = Mtime.Span.of_uint64_ns 0L in + let tb = + Token_bucket.create_with_timestamp initial_time ~burst_size:10.0 + ~fill_rate:2.0 + in + + let first_consume = + Token_bucket.consume_with_timestamp (fun () -> initial_time) tb 5.0 + in + Alcotest.(check bool) "First consume should succeed" true first_consume ; + + let later_time = Mtime.Span.of_uint64_ns 3_000_000_000L in + let second_consume = + Token_bucket.consume_with_timestamp (fun () -> later_time) tb 8.0 + in + + Alcotest.(check bool) + "Second consume after refill should succeed" true second_consume ; + + Alcotest.(check (float 0.0)) + "After refill and consume, tokens should be 2" 2.0 + (Token_bucket.peek_with_timestamp later_time tb) + +let test_peek_respects_burst_size () = + let initial_time = Mtime.Span.of_uint64_ns 0L in + let tb = + Token_bucket.create_with_timestamp initial_time ~burst_size:10.0 + ~fill_rate:5.0 + in + + let _ = Token_bucket.consume_with_timestamp (fun () -> initial_time) tb 8.0 in + + let later_time = Mtime.Span.of_uint64_ns 10_000_000_000L in + let available = Token_bucket.peek_with_timestamp later_time tb in + Alcotest.(check (float 0.0)) + "Peek should respect burst_size limit" 10.0 available + +let test_concurrent_access () = + let tb = + Token_bucket.create_with_timestamp Mtime.Span.zero ~burst_size:15.0 + ~fill_rate:0.01 + in + let threads = + Array.init 10 (fun _ -> + Thread.create + (fun () -> + ignore + (Token_bucket.consume_with_timestamp + (fun () -> Mtime.Span.zero) + tb 1.0 + ) + ) + () + ) + in + Array.iter Thread.join threads ; + Alcotest.(check (float 0.0)) + "Threads consuming concurrently should all remove from token amount" + (Token_bucket.peek_with_timestamp Mtime.Span.zero tb) + 5.0 + +let test_sleep () = + let tb = Token_bucket.create ~burst_size:20.0 ~fill_rate:5.0 in + let _ = Token_bucket.consume tb 10.0 in + Thread.delay 1.0 ; + Alcotest.(check (float 0.5)) + "Sleep 1 should refill token bucket by fill_rate" 15.0 (Token_bucket.peek tb) + +let test_system_time_versions () = + let tb = Token_bucket.create ~burst_size:10.0 ~fill_rate:2.0 in + + let initial_peek = Token_bucket.peek tb in + Alcotest.(check (float 0.01)) + "System time peek should return burst_size initially" 10.0 initial_peek ; + + let consume_result = Token_bucket.consume tb 3.0 in + Alcotest.(check bool) "System time consume should succeed" true consume_result ; + + let after_consume_peek = Token_bucket.peek tb in + Alcotest.(check (float 0.01)) + "After consume, should have 7 tokens" 7.0 after_consume_peek + +let test_concurrent_system_time () = + let tb = Token_bucket.create ~burst_size:100.0 ~fill_rate:10.0 in + let num_threads = 20 in + let consume_per_thread = 3 in + + let threads = + Array.init num_threads (fun _ -> + Thread.create + (fun () -> + for _ = 1 to consume_per_thread do + ignore (Token_bucket.consume tb 1.0) + done + ) + () + ) + in + Array.iter Thread.join threads ; + + let remaining = Token_bucket.peek tb in + let expected_remaining = + 100.0 -. float_of_int (num_threads * consume_per_thread) + in + Alcotest.(check (float 0.1)) + "Concurrent system time consumption should work correctly" + expected_remaining remaining + +let test_consume_more_than_available_concurrent () = + let tb = + Token_bucket.create_with_timestamp Mtime.Span.zero ~burst_size:5.0 + ~fill_rate:0.1 + in + let num_threads = 10 in + let consume_per_thread = 1 in + let successful_consumes = ref 0 in + let counter_mutex = Mutex.create () in + + let threads = + Array.init num_threads (fun _ -> + Thread.create + (fun () -> + let success = + Token_bucket.consume_with_timestamp + (fun () -> Mtime.Span.zero) + tb + (float_of_int consume_per_thread) + in + if success then ( + Mutex.lock counter_mutex ; + incr successful_consumes ; + Mutex.unlock counter_mutex + ) + ) + () + ) + in + Array.iter Thread.join threads ; + + Alcotest.(check int) + "Only 5 consumptions should succeed" 5 !successful_consumes ; + Alcotest.(check (float 0.1)) + "Bucket should be empty after consumptions" 0.0 + (Token_bucket.peek_with_timestamp Mtime.Span.zero tb) + +let test_delay_until_available () = + let initial_time = Mtime.Span.of_uint64_ns 0L in + let tb = + Token_bucket.create_with_timestamp initial_time ~burst_size:10.0 + ~fill_rate:2.0 + in + + let _ = + Token_bucket.consume_with_timestamp (fun () -> initial_time) tb 10.0 + in + + let delay = + Token_bucket.get_delay_until_available_timestamp initial_time tb 4.0 + in + Alcotest.(check (float 0.01)) + "Delay for 4 tokens at 2 tokens/sec should be 2 seconds" 2.0 delay ; + + let tb_fresh = Token_bucket.create ~burst_size:10.0 ~fill_rate:2.0 in + let _ = Token_bucket.consume tb_fresh 10.0 in + let delay_system = Token_bucket.get_delay_until_available tb_fresh 4.0 in + + Alcotest.(check (float 0.1)) + "System time delay should be approximately 2 seconds" 2.0 delay_system + +let test_edge_cases () = + let tb = + Token_bucket.create_with_timestamp Mtime.Span.zero ~burst_size:5.0 + ~fill_rate:1.0 + in + let success = + Token_bucket.consume_with_timestamp (fun () -> Mtime.Span.zero) tb 0.0 + in + Alcotest.(check bool) "Consuming zero tokens should succeed" true success ; + + let tb_small = + Token_bucket.create_with_timestamp Mtime.Span.zero ~burst_size:1.0 + ~fill_rate:0.1 + in + let success_small = + Token_bucket.consume_with_timestamp + (fun () -> Mtime.Span.zero) + tb_small 0.001 + in + Alcotest.(check bool) + "Consuming very small amount should succeed" true success_small + +let test_oversized_consume_goes_negative () = + let initial_time = Mtime.Span.of_uint64_ns 0L in + let tb = + Token_bucket.create_with_timestamp initial_time ~burst_size:5.0 + ~fill_rate:1.0 + in + let success = + Token_bucket.consume_with_timestamp (fun () -> initial_time) tb 10.0 + in + Alcotest.(check bool) + "Oversized consume from a full bucket should succeed" true success ; + Alcotest.(check (float 0.0)) + "Bucket should be negative by (amount - burst_size)" (-5.0) + (Token_bucket.peek_with_timestamp initial_time tb) + +let test_second_oversized_consume_waits_for_burst () = + let initial_time = Mtime.Span.of_uint64_ns 0L in + let tb = + Token_bucket.create_with_timestamp initial_time ~burst_size:5.0 + ~fill_rate:1.0 + in + let _ = + Token_bucket.consume_with_timestamp (fun () -> initial_time) tb 10.0 + in + + (* After 5s: -5 + 5*1 = 0 tokens; bucket must still be at burst_size (5) + before a second oversized request can run. *) + let five_s = Mtime.Span.of_uint64_ns 5_000_000_000L in + Alcotest.(check (float 0.0)) + "5s later, tokens have climbed to zero" 0.0 + (Token_bucket.peek_with_timestamp five_s tb) ; + Alcotest.(check (float 0.0)) + "Delay until second oversized request is (burst - current) / fill_rate" 5.0 + (Token_bucket.get_delay_until_available_timestamp five_s tb 6.0) ; + let fail_now = + Token_bucket.consume_with_timestamp (fun () -> five_s) tb 6.0 + in + Alcotest.(check bool) + "Oversized consume before bucket reaches burst_size should fail" false + fail_now ; + + (* At 10s: -5 + 10*1 = 5 tokens (capped at burst_size), consume 6 succeeds + and leaves the bucket at -1. *) + let ten_s = Mtime.Span.of_uint64_ns 10_000_000_000L in + let success = Token_bucket.consume_with_timestamp (fun () -> ten_s) tb 6.0 in + Alcotest.(check bool) + "Second oversized consume succeeds once bucket refills to burst_size" true + success ; + Alcotest.(check (float 0.0)) + "Bucket sits at burst_size - amount after second oversized consume" (-1.0) + (Token_bucket.peek_with_timestamp ten_s tb) + +(* Regression guard for the hang: previously, [delay_then_consume] on an + amount greater than [burst_size] looped forever because [consume] can + never see enough tokens (refill caps at [burst_size]) and + [get_delay_until_available] kept returning the same non-zero delay. Each + case here drains the bucket first so the operation must go through the + refill path, then runs it in a worker thread and asserts it completes + within a generous bound. A regression would leave the flag unset and + fail the alcotest check rather than deadlock the whole suite. *) +let test_delay_then_consume_always_terminates () = + let cases = + [ + (* label, burst_size, fill_rate, amount, bound_s *) + ("standard request from drained bucket", 5.0, 100.0, 3.0, 1.0) + ; ("amount equal to burst_size", 5.0, 100.0, 5.0, 1.0) + ; ("oversized request, tight bucket", 0.5, 200.0, 10.0, 1.0) + ; ("oversized request, small bucket", 1.0, 100.0, 5.0, 1.0) + ] + in + List.iter + (fun (label, burst_size, fill_rate, amount, bound_s) -> + let tb = Token_bucket.create ~burst_size ~fill_rate in + ignore (Token_bucket.consume tb burst_size) ; + let done_flag = Atomic.make false in + let _worker = + Thread.create + (fun () -> + Token_bucket.delay_then_consume tb amount ; + Atomic.set done_flag true + ) + () + in + let start = Mtime_clock.counter () in + let elapsed_s () = + Mtime.Span.to_float_ns (Mtime_clock.count start) *. 1e-9 + in + while (not (Atomic.get done_flag)) && elapsed_s () < bound_s do + Thread.delay 0.01 + done ; + Alcotest.(check bool) + (Printf.sprintf "delay_then_consume terminates: %s" label) + true (Atomic.get done_flag) + ) + cases + +let test_consume_quickcheck = + let open QCheck.Gen in + let gen_operations = + let gen_operation = + pair (float_range 0.0 1000.0) (int_range 0 1_000_000_000) + in + list_size (int_range 1 50) gen_operation + in + + let fail_peek op_num time_ns time_delta expected current added actual diff = + QCheck.Test.fail_reportf + "Operation %d: peek failed\n\ + \ Time: %d ns (delta: %d ns)\n\ + \ Expected tokens: %.3f (current: %.3f + added: %.3f)\n\ + \ Actual tokens: %.3f\n\ + \ Diff: %.6f" + op_num time_ns time_delta expected current added actual diff + in + + let fail_consume op_num time_ns time_delta amount available success expected + actual diff = + QCheck.Test.fail_reportf + "Operation %d: consume failed\n\ + \ Time: %d ns (delta: %d ns)\n\ + \ Consume amount: %.3f\n\ + \ Available before: %.3f\n\ + \ Success: %b\n\ + \ Expected after: %.3f\n\ + \ Actual after: %.3f\n\ + \ Diff: %.6f" + op_num time_ns time_delta amount available success expected actual diff + in + + let property (burst_size, fill_rate, operations) = + let initial_time = Mtime.Span.of_uint64_ns 0L in + let tb = + Token_bucket.create_with_timestamp initial_time ~burst_size ~fill_rate + in + + let rec check_operations op_num time_ns last_refill_ns current_tokens ops = + match ops with + | [] -> + true + | (consume_amount, time_delta_ns) :: rest -> + let new_time_ns = time_ns + time_delta_ns in + let current_time = + Mtime.Span.of_uint64_ns (Int64.of_int new_time_ns) + in + let time_since_refill_seconds = + float_of_int (new_time_ns - last_refill_ns) *. 1e-9 + in + let tokens_added = time_since_refill_seconds *. fill_rate in + let expected_available = + min burst_size (current_tokens +. tokens_added) + in + let actual_before = + Token_bucket.peek_with_timestamp current_time tb + in + let peek_diff = abs_float (actual_before -. expected_available) in + + if peek_diff >= 0.001 then + fail_peek op_num new_time_ns time_delta_ns expected_available + current_tokens tokens_added actual_before peek_diff + else + let success = + Token_bucket.consume_with_timestamp + (fun () -> current_time) + tb consume_amount + in + let actual_after = + Token_bucket.peek_with_timestamp current_time tb + in + let new_tokens = + if success then + expected_available -. consume_amount + else + expected_available + in + let after_diff = abs_float (actual_after -. new_tokens) in + + if after_diff >= 0.001 then + fail_consume op_num new_time_ns time_delta_ns consume_amount + expected_available success new_tokens actual_after after_diff + else + check_operations (op_num + 1) new_time_ns new_time_ns new_tokens + rest + in + + check_operations 1 0 0 burst_size operations + in + + let gen_all = + map3 + (fun burst fill ops -> (burst, fill, ops)) + pfloat (float_range 1e-9 1e9) gen_operations + in + + let arb_all = + QCheck.make + ~print:(fun (burst, fill, ops) -> + let ops_str = + ops + |> List.mapi (fun i (amount, delta) -> + Printf.sprintf " Op %d: consume %.3f at +%d ns" (i + 1) amount + delta + ) + |> String.concat "\n" + in + Printf.sprintf "burst_size=%.3f, fill_rate=%.3f, %d operations:\n%s" + burst fill (List.length ops) ops_str + ) + gen_all + in + + QCheck.Test.make ~name:"Consume operations maintain correct token count" + ~count:100 arb_all (fun (burst, fill, ops) -> property (burst, fill, ops) + ) + +let test = + [ + ( "A bucket with zero or negative fill rate cannot be created" + , `Quick + , test_bad_fill_rate + ) + ; ( "Consume removes correct amount" + , `Quick + , test_consume_removes_correct_amount + ) + ; ("Consume more than available", `Quick, test_consume_more_than_available) + ; ( "Consume refills before removing" + , `Quick + , test_consume_refills_before_removing + ) + ; ("Peek respects burst size", `Quick, test_peek_respects_burst_size) + ; ("Concurrent access", `Quick, test_concurrent_access) + ; ("Refill after sleep", `Slow, test_sleep) + ; ("System time versions", `Quick, test_system_time_versions) + ; ("Concurrent system time", `Quick, test_concurrent_system_time) + ; ( "Consume more than available concurrent" + , `Quick + , test_consume_more_than_available_concurrent + ) + ; ("Delay until available", `Quick, test_delay_until_available) + ; ("Edge cases", `Quick, test_edge_cases) + ; ( "Oversized consume drives the bucket negative" + , `Quick + , test_oversized_consume_goes_negative + ) + ; ( "Second oversized consume waits for burst refill" + , `Quick + , test_second_oversized_consume_waits_for_burst + ) + ; ( "delay_then_consume always terminates" + , `Quick + , test_delay_then_consume_always_terminates + ) + ; QCheck_alcotest.to_alcotest test_consume_quickcheck + ] + +let () = Alcotest.run "Token bucket library" [("Token bucket tests", test)] diff --git a/ocaml/libs/rate-limit/test/test_token_bucket.mli b/ocaml/libs/rate-limit/test/test_token_bucket.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/rate-limit/token_bucket.ml b/ocaml/libs/rate-limit/token_bucket.ml new file mode 100644 index 00000000000..572b4b8eca4 --- /dev/null +++ b/ocaml/libs/rate-limit/token_bucket.ml @@ -0,0 +1,89 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type state = {tokens: float; last_refill: Mtime.span} + +type t = {burst_size: float; fill_rate: float; state: state Atomic.t} + +let create_with_timestamp timestamp ~burst_size ~fill_rate = + if fill_rate <= 0. then + invalid_arg "Token_bucket.create: fill_rate must be positive" + else + let state = Atomic.make {tokens= burst_size; last_refill= timestamp} in + {burst_size; fill_rate; state} + +let create = create_with_timestamp (Mtime_clock.elapsed ()) + +let compute_tokens timestamp {tokens; last_refill} ~burst_size ~fill_rate = + let time_delta = Mtime.Span.abs_diff last_refill timestamp in + let time_delta_seconds = Mtime.Span.to_float_ns time_delta *. 1e-9 in + min burst_size (tokens +. (time_delta_seconds *. fill_rate)) + +let peek_with_timestamp timestamp tb = + let tb_state = Atomic.get tb.state in + compute_tokens timestamp tb_state ~burst_size:tb.burst_size + ~fill_rate:tb.fill_rate + +let peek tb = peek_with_timestamp (Mtime_clock.elapsed ()) tb + +(* A request whose cost exceeds [burst_size] can never wait for its full + amount to accumulate (refill caps at [burst_size]). We admit such a + request once the bucket is full and let [tokens] go negative; the debt + is repaid at [fill_rate] before any later request can proceed. *) +let consume_with_timestamp get_time tb amount = + let rec try_consume () = + let timestamp = get_time () in + let old_state = Atomic.get tb.state in + let new_tokens = + compute_tokens timestamp old_state ~burst_size:tb.burst_size + ~fill_rate:tb.fill_rate + in + let required = Float.min amount tb.burst_size in + let success, final_tokens = + if new_tokens >= required then + (true, new_tokens -. amount) + else + (false, new_tokens) + in + let new_state = {tokens= final_tokens; last_refill= timestamp} in + if Atomic.compare_and_set tb.state old_state new_state then + success + else + try_consume () + in + try_consume () + +let consume = consume_with_timestamp Mtime_clock.elapsed + +let get_delay_until_available_timestamp timestamp tb amount = + let {tokens; last_refill} = Atomic.get tb.state in + let current_tokens = + compute_tokens timestamp {tokens; last_refill} ~burst_size:tb.burst_size + ~fill_rate:tb.fill_rate + in + let required = Float.min amount tb.burst_size in + let required_tokens = max 0. (required -. current_tokens) in + required_tokens /. tb.fill_rate + +let get_delay_until_available tb amount = + get_delay_until_available_timestamp (Mtime_clock.elapsed ()) tb amount + +(* This implementation only works when there is only one thread trying to + consume - fairness needs to be implemented on top of it with a queue. + If there is no contention, it should only delay once. *) +let rec delay_then_consume tb amount = + if not (consume tb amount) then ( + Thread.delay (get_delay_until_available tb amount) ; + delay_then_consume tb amount + ) diff --git a/ocaml/libs/rate-limit/token_bucket.mli b/ocaml/libs/rate-limit/token_bucket.mli new file mode 100644 index 00000000000..164f4015765 --- /dev/null +++ b/ocaml/libs/rate-limit/token_bucket.mli @@ -0,0 +1,123 @@ +(* + * Copyright (C) 2026 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** This module implements a classic token-bucket rate limiter. Token buckets + contain tokens that are refilled over time, and can be consumed in a + thread-safe way. A token bucket accumulates [fill_rate] tokens per second, + up to [burst_size]. Consumers may take tokens (if available), or query when + enough tokens will become available. + + Token counts are represented as floats rather than integers to allow + fractional token costs and fine-grained refill rates. + + Token buckets implement rate limiting by allowing operations to proceed + only when sufficient tokens are available - otherwise, the operations can + be delayed until enough tokens are available. + + A single request whose cost exceeds [burst_size] cannot be satisfied by + a full bucket. Rather than being rejected, such a request is admitted + once the bucket reaches [burst_size] and the token count is allowed to + go negative; the debt is repaid at [fill_rate] before any subsequent + request can proceed. [peek] therefore may return a value below zero. + + To avoid doing unnecessary work to refill the bucket, token amounts are + only updated when a consume operation is carried out. The buckets keep a + last_refill timestamp which is updated on consume in tandem with the token + counts, and informs how many tokens should be added by the bucket refill. + + We include versions of functions that take a timestamp as a parameter for + testing purposes only - consumers of this library should use the + timestamp-less versions. +*) + +type t + +val create : burst_size:float -> fill_rate:float -> t +(** Create token bucket with given parameters. + @raises Invalid_argument if the fill rate is 0 or negative. + @param burst_size Maximum number of tokens that can fit in the bucket + @param fill_rate Number of tokens added to the bucket per second + *) + +val peek : t -> float +(** Retrieve current token amount + @param tb Token bucket + @return Amount of tokens in the token bucket + *) + +val consume : t -> float -> bool +(** Consume tokens from the bucket in a thread-safe manner. Succeeds when + the bucket contains at least [min amount burst_size] tokens; on success + [amount] is subtracted, which may leave the token count negative if + [amount > burst_size]. + @param tb Token bucket + @param amount How many tokens to consume + @return Whether the tokens were successfully consumed + *) + +val get_delay_until_available : t -> float -> float +(** Get number of seconds that need to pass until [consume tb amount] is + expected to succeed. For [amount > burst_size] this is the time until + the bucket reaches [burst_size] (after which the request is admitted + and the bucket goes negative). + @param tb Token bucket + @param amount How many tokens we want to consume + @return Number of seconds until tokens are available +*) + +val delay_then_consume : t -> float -> unit +(** [delay_then_consume tb amount] sleeps the calling thread until [amount] + tokens are available, then consumes them. Thread-safe but does not + guarantee fairness between competing callers. *) + +(**/**) + +(* Fuctions accepting a timestamp are meant for testing only *) + +val create_with_timestamp : + Mtime.span -> burst_size:float -> fill_rate:float -> t +(** Create token bucket with given parameters and supplied inital timestamp. + @raises Invalid_argument if the fill_rate is 0 or negative. + @param timestamp Initial timestamp + @param burst_size Maximum number of tokens that can fit in the bucket + @param fill_rate Number of tokens added to the bucket per second + *) + +val peek_with_timestamp : Mtime.span -> t -> float +(** Retrieve token amount in token bucket at given timestamp. + Undefined behaviour when [timestamp] <= [tb.timestamp] + @param timestamp Current time + @param tb Token bucket + @return Amount of tokens in the token bucket + *) + +val consume_with_timestamp : (unit -> Mtime.span) -> t -> float -> bool +(** Consume tokens from the bucket in a thread-safe manner, using supplied + function for obtaining the current time + @param get_time Function to obtain timestamp, e.g. Mtime_clock.elapsed + @param tb Token bucket + @param amount How many tokens to consume + @return Whether the tokens were successfully consumed + *) + +val get_delay_until_available_timestamp : Mtime.span -> t -> float -> float +(** Get number of seconds that need to pass until bucket is expected to have + enough tokens to fulfil the request + @param timestamp + @param tb Token bucket + @param amount How many tokens we want to consume + @return Number of seconds until tokens are available +*) + +(**/**) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 6c3c2748e01..6bbcfcc85cd 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -173,6 +173,17 @@ let debug_conf_of_env () : string = |> String.lowercase_ascii |> fun x -> List.mem x ["yes"; "true"; "1"] |> debug_conf_of_bool +module Openssl = struct + (* The OpenSSL-rendered cipher list and ECDHE curve the stunnel client + negotiates, re-exported from the single source of truth in Tls_policy so + callers that must match it (the ktls-helper, which replaces the + per-migration stunnel client) share one definition instead of keeping a + second copy that can drift. *) + let default_ciphers = Tls_policy.Openssl.default_ciphers + + let default_curve = Tls_policy.Openssl.default_curve +end + let config_file ?(accept = None) config host port = ( match config with | None -> @@ -224,9 +235,9 @@ let config_file ?(accept = None) config host port = ) ; [Printf.sprintf "connect=%s:%d" host port] ; [ - "sslVersion = TLSv1.2" - ; "ciphers = " ^ Constants.good_ciphersuites - ; "curve = secp384r1" + Printf.sprintf "sslVersion = %s" Tls_policy.Openssl.default_version + ; Printf.sprintf "ciphers = %s" Tls_policy.Openssl.default_ciphers + ; Printf.sprintf "curve = %s" Tls_policy.Openssl.default_curve ] ; ( match config with | None -> @@ -536,6 +547,15 @@ module UnixSocketProxy = struct Printf.sprintf "/tmp/stunnel-proxy-%s-%d-%s.sock" remote_host remote_port uuid + let kill pid = + match pid with + | StdFork _ | FEFork _ -> ( + try Unix.kill (getpid pid) Sys.sigkill + with Unix.Unix_error (Unix.ESRCH, _, _) -> () + ) + | Nopid -> + () + let diagnose handle = let ic = handle.proxy_log_ic in Stunnel_log_scanner.check_stunnel_logfile ~ic (fun s -> !stunnel_logger s) @@ -572,7 +592,8 @@ module UnixSocketProxy = struct let ic = open_in logfile in let clean_up () = close_in ic ; - disconnect_with_pid ~wait:false ~force:true pid ; + kill pid ; + disconnect_with_pid pid ; Unixext.unlink_safe unix_socket_path ; Unixext.unlink_safe logfile in @@ -614,7 +635,8 @@ module UnixSocketProxy = struct Ok handle let stop handle = - disconnect_with_pid ~wait:false ~force:true handle.proxy_pid ; + kill handle.proxy_pid ; + disconnect_with_pid handle.proxy_pid ; Unixext.unlink_safe handle.proxy_socket_path ; close_in handle.proxy_log_ic ; Unixext.unlink_safe handle.proxy_logfile ; diff --git a/ocaml/libs/stunnel/stunnel.mli b/ocaml/libs/stunnel/stunnel.mli index cf0b3919ab6..a1633e5373e 100644 --- a/ocaml/libs/stunnel/stunnel.mli +++ b/ocaml/libs/stunnel/stunnel.mli @@ -64,6 +64,16 @@ val world : verification_config val external_host : string -> verification_config +module Openssl : sig + val default_ciphers : string + (** OpenSSL cipher list the stunnel client negotiates; the single source of + truth the ktls-helper mirrors. *) + + val default_curve : string + (** OpenSSL ECDHE curve the stunnel client pins; the single source of truth + the ktls-helper mirrors. *) +end + val with_connect : ?unique_id:int -> ?use_fork_exec_helper:bool diff --git a/ocaml/libs/uuid/uuidx.ml b/ocaml/libs/uuid/uuidx.ml index b22c22ebd14..ec8d0911b70 100644 --- a/ocaml/libs/uuid/uuidx.ml +++ b/ocaml/libs/uuid/uuidx.ml @@ -64,6 +64,8 @@ type without_secret = | `sr_stat | `subject | `task + | `Caller + | `Rate_limit | `tunnel | `USB_group | `user diff --git a/ocaml/libs/uuid/uuidx.mli b/ocaml/libs/uuid/uuidx.mli index bd0865cf628..1f1f7135f99 100644 --- a/ocaml/libs/uuid/uuidx.mli +++ b/ocaml/libs/uuid/uuidx.mli @@ -75,6 +75,8 @@ type without_secret = | `sr_stat | `subject | `task + | `Caller + | `Rate_limit | `tunnel | `USB_group | `user diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml index edfc82ab521..349719aa53e 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -110,6 +110,16 @@ module List = struct in loop [] l + let try_map_any f l = + let rec loop errs = function + | [] -> + Error (List.rev errs) + | x :: xs -> ( + match f x with Ok _ as ok -> ok | Error e -> loop (e :: errs) xs + ) + in + loop [] l + let take n list = let rec loop i acc = function | x :: xs when i < n -> diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli index c3ff7436d18..7de45eec7f6 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -50,6 +50,11 @@ module List : sig the [Ok] results, and the first [Error] result encountered, if it is encountered. *) + val try_map_any : ('a -> ('b, 'c) result) -> 'a list -> ('b, 'c list) result + (** [try_map_any f l] applies [f] to elements of [l] in turn. Returns the + first [Ok] result encountered or, if all elements produce errors, returns + all the [Error] results in a list. *) + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list (** [rev_map f l] gives the same result as {!Stdlib.List.rev}[ (] {!Stdlib.List.mapi}[ f l)], but is tail-recursive and more efficient. *) diff --git a/ocaml/libs/xenctrl-ext/xenctrlext_stubs.c b/ocaml/libs/xenctrl-ext/xenctrlext_stubs.c index acca4cad479..70b0f43cc01 100644 --- a/ocaml/libs/xenctrl-ext/xenctrlext_stubs.c +++ b/ocaml/libs/xenctrl-ext/xenctrlext_stubs.c @@ -171,7 +171,10 @@ CAMLprim value stub_xenctrlext_domain_get_acpi_s_state(value xch_val, xc_interface *xch = xch_of_val(xch_val); int domain = Int_val(domid); + caml_release_runtime_system(); rc = xc_get_hvm_param(xch, domain, HVM_PARAM_ACPI_S_STATE, &v); + caml_acquire_runtime_system(); + if (rc != 0) failwith_xc(xch); @@ -337,7 +340,11 @@ CAMLprim value stub_xenctrlext_domain_update_channels(value xch_val, static int get_cpumap_len(xc_interface *xch, value cpumap_val) { int ml_len = Wosize_val(cpumap_val); - int xc_len = xc_get_max_cpus(xch); + int xc_len; + + caml_release_runtime_system(); + xc_len = xc_get_max_cpus(xch); + caml_acquire_runtime_system(); return (ml_len < xc_len ? ml_len : xc_len); } @@ -345,10 +352,14 @@ static int get_cpumap_len(xc_interface *xch, value cpumap_val) static void populate_cpumap(xc_interface *xch, xc_cpumap_t cpumap, value cpumap_val) { + CAMLparam1(cpumap_val); int i, len = get_cpumap_len(xch, cpumap_val); + for (i = 0; i < len; i++) if (Bool_val(Field(cpumap_val, i))) cpumap[i / 8] |= 1 << (i & 7); + + CAMLreturn0; } CAMLprim value stub_xenctrlext_vcpu_setaffinity_hard(value xch_val, @@ -362,14 +373,20 @@ CAMLprim value stub_xenctrlext_vcpu_setaffinity_hard(value xch_val, xc_interface *xch = xch_of_val(xch_val); xc_cpumap_t cpumap; + caml_release_runtime_system(); cpumap = xc_cpumap_alloc(xch); + caml_acquire_runtime_system(); + if (cpumap == NULL) failwith_xc(xch); populate_cpumap(xch, cpumap, cpumap_val); + caml_release_runtime_system(); rc = xc_vcpu_setaffinity(xch, domid, vcpu, cpumap, NULL, XEN_VCPUAFFINITY_HARD); + caml_acquire_runtime_system(); + free(cpumap); if (rc < 0) failwith_xc(xch); @@ -388,14 +405,20 @@ CAMLprim value stub_xenctrlext_vcpu_setaffinity_soft(value xch_val, xc_interface *xch = xch_of_val(xch_val); xc_cpumap_t cpumap; + caml_release_runtime_system(); cpumap = xc_cpumap_alloc(xch); + caml_acquire_runtime_system(); + if (cpumap == NULL) failwith_xc(xch); populate_cpumap(xch, cpumap, cpumap_val); + caml_release_runtime_system(); rc = xc_vcpu_setaffinity(xch, domid, vcpu, NULL, cpumap, XEN_VCPUAFFINITY_SOFT); + caml_acquire_runtime_system(); + free(cpumap); if (rc < 0) failwith_xc(xch); @@ -414,7 +437,10 @@ CAMLprim value stub_xenctrlext_numainfo(value xch_val) int rc; xc_interface *xch = xch_of_val(xch_val); + caml_release_runtime_system(); rc = xc_numainfo(xch, &max_nodes, NULL, NULL); + caml_acquire_runtime_system(); + if (rc < 0) failwith_xc(xch); @@ -426,7 +452,10 @@ CAMLprim value stub_xenctrlext_numainfo(value xch_val) caml_raise_out_of_memory(); } + caml_release_runtime_system(); rc = xc_numainfo(xch, &max_nodes, meminfo, distance); + caml_acquire_runtime_system(); + if (rc < 0) { free(meminfo); free(distance); @@ -468,7 +497,10 @@ CAMLprim value stub_xenctrlext_cputopoinfo(value xch_val) int rc; xc_interface *xch = xch_of_val(xch_val); + caml_release_runtime_system(); rc = xc_cputopoinfo(xch, &max_cpus, NULL); + caml_acquire_runtime_system(); + if (rc < 0) failwith_xc(xch); @@ -476,7 +508,10 @@ CAMLprim value stub_xenctrlext_cputopoinfo(value xch_val) if (!cputopo) caml_raise_out_of_memory(); + caml_release_runtime_system(); rc = xc_cputopoinfo(xch, &max_cpus, cputopo); + caml_acquire_runtime_system(); + if (rc < 0) { free(cputopo); failwith_xc(xch); diff --git a/ocaml/nbd/src/main.ml b/ocaml/nbd/src/main.ml index eccfc004265..bfca59d3299 100644 --- a/ocaml/nbd/src/main.ml +++ b/ocaml/nbd/src/main.ml @@ -92,8 +92,8 @@ let init_tls_get_server_ctx ~certfile = let certfile = require_str "certfile" certfile in Some (Nbd_unix.TlsServer - (Nbd_unix.init_tls_get_ctx ~curve:"secp384r1" ~certfile - ~ciphersuites:Constants.good_ciphersuites () + (Nbd_unix.init_tls_get_ctx ~curve:Tls_policy.Openssl.default_curve + ~certfile ~ciphersuites:Tls_policy.Openssl.default_ciphers () ) ) diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index ff1ef3869c0..6cf27e1f967 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -78,6 +78,7 @@ let () = ; ("Quicktest_static_vdis", Quicktest_static_vdis.tests ()) ; ("Quicktest_date", Quicktest_date.tests ()) ; ("Quicktest_crypt_r", Quicktest_crypt_r.tests ()) + ; ("Quicktest_rate_limit", Quicktest_rate_limit.tests ()) ] @ ( if not !Quicktest_args.using_unix_domain_socket then [("http", Quicktest_http.tests)] diff --git a/ocaml/quicktest/quicktest_rate_limit.ml b/ocaml/quicktest/quicktest_rate_limit.ml new file mode 100644 index 00000000000..7fb6528d90f --- /dev/null +++ b/ocaml/quicktest/quicktest_rate_limit.ml @@ -0,0 +1,194 @@ +module Caller = Client.Client.Caller +module Rate_limit = Client.Client.Rate_limit +module Pool = Client.Client.Pool + +(* Create an RPC function that uses a specific User-Agent header. Mirrors the + transport chosen for the framework's default RPC so that the throttled and + unthrottled measurements go over the same channel. *) +let make_rpc_with_user_agent user_agent = + let http = + Http.Request.make ~user_agent ~version:"1.1" ~keep_alive:false Http.Post "/" + in + let open Xmlrpc_client in + let transport = + if !Quicktest_args.using_unix_domain_socket then + Unix Xapi_globs.unix_domain_socket + else + SSL + ( SSL.make ~use_fork_exec_helper:false + ~verify_cert:(Stunnel_client.pool ()) () + , !Quicktest_args.host + , 443 + ) + in + fun xml -> + XMLRPC_protocol.rpc ~srcstr:"quicktest" ~dststr:"xapi" ~transport ~http xml + +(* Build a caller + rate-limit pair and link them. Returns a cleanup + thunk that tears them down in dependency order. *) +let with_throttled_caller rpc session_id ~name ~user_agent ~burst_size + ~fill_rate k = + let caller_ref = + Caller.create ~rpc ~session_id ~name_label:name ~name_description:"" + ~user_agent ~client_ip:"" + in + let rate_limit_ref = + Rate_limit.create ~rpc ~session_id ~name_label:name ~name_description:"" + ~burst_size ~fill_rate + in + Rate_limit.add_caller ~rpc ~session_id ~self:rate_limit_ref ~caller:caller_ref ; + let cleanup () = + (* destroy clears each caller's rate_limit pointer first. *) + (try Rate_limit.destroy ~rpc ~session_id ~self:rate_limit_ref with _ -> ()) ; + try Caller.destroy ~rpc ~session_id ~self:caller_ref with _ -> () + in + Fun.protect ~finally:cleanup (fun () -> k caller_ref rate_limit_ref) + +(* Detect whether the server has rate limiting enabled. The Caller datamodel + API works regardless of the feature flag (validation and DB CRUD always + run), but dispatch-time bookkeeping (which feeds Caller.query_usage) only + happens when rate_limit=true in xapi.conf. So if a probe of throttled calls + leaves the caller's "calls" counter at 0, the server is running with the + feature disabled and the throttling assertions cannot be meaningfully run. *) +let rate_limiting_active rpc session_id caller_ref ~throttled_rpc = + for _ = 1 to 5 do + ignore (Client.Client.Pool.get_all ~rpc:throttled_rpc ~session_id) + done ; + let usage = + Client.Client.Caller.query_call_count ~rpc ~session_id ~self:caller_ref + in + usage > 0L + +let rate_limit_throttling_test rpc session_id () = + let test_user_agent = + "quicktest-rate-limit-throttle-" ^ Uuidx.(to_string (make ())) + in + (* pool.get_all is not listed in call-costs.conf, so its cost falls back to + xapi_caller.ml's default_token_cost of 1.0. Pick burst/fill so 100 calls + take a few seconds while still throttling well below the unthrottled + rate. *) + let burst_size = 10.0 in + let fill_rate = 40.0 in + let call_cost = 1.0 in + with_throttled_caller rpc session_id ~name:"quicktest-throttle" + ~user_agent:test_user_agent ~burst_size ~fill_rate (fun caller_ref _ -> + let throttled_rpc = make_rpc_with_user_agent test_user_agent in + if not (rate_limiting_active rpc session_id caller_ref ~throttled_rpc) + then + Printf.printf + "Rate limiting disabled on server (rate_limit=false in xapi.conf); \ + skipping throttling assertions\n\ + %!" + else + let make_call () = + ignore (Client.Client.Pool.get_all ~rpc:throttled_rpc ~session_id) + in + (* Measure baseline: unthrottled calls *) + let num_calls = 100 in + let start_unthrottled = Mtime_clock.counter () in + for _ = 1 to num_calls do + ignore (Client.Client.Pool.get_all ~rpc ~session_id) + done ; + let elapsed_unthrottled = + Mtime.Span.to_float_ns (Mtime_clock.count start_unthrottled) *. 1e-9 + in + Printf.printf "%d unthrottled calls took %.3f seconds\n%!" num_calls + elapsed_unthrottled ; + let start_throttled = Mtime_clock.counter () in + for _ = 1 to num_calls do + make_call () + done ; + let elapsed_throttled = + Mtime.Span.to_float_ns (Mtime_clock.count start_throttled) *. 1e-9 + in + Printf.printf "%d throttled calls took %.3f seconds\n%!" num_calls + elapsed_throttled ; + (* Token-bucket adds a fixed delay once the initial burst is drained: + (N*cost - burst)/fill_rate. The unthrottled baseline captures + per-call RPC overhead, so subtracting it isolates the throttler's + contribution. Bound above and below to catch both under- and + over-limiting. Requires both paths to share a transport. *) + let num_calls_f = Float.of_int num_calls in + let floor = + Float.max 0.0 (((num_calls_f *. call_cost) -. burst_size) /. fill_rate) + in + let tolerance_low = 0.10 *. floor in + let tolerance_high = 0.5 +. (0.20 *. floor) in + Alcotest.(check bool) + "Throttled call time above predicted rate limit overhead" true + (elapsed_throttled >= floor -. tolerance_low) ; + Alcotest.(check bool) + "Throttled time below unthrottled + rate limit overhead" true + (elapsed_throttled <= floor +. elapsed_unthrottled +. tolerance_high) + ) + +(* Test that invalid rate limits are rejected *) +let rate_limit_invalid_test rpc session_id () = + let is_invalid_value f = + try f () ; false + with Api_errors.Server_error (code, _) -> code = Api_errors.invalid_value + in + (* Creating with non-positive fill_rate or burst_size must fail before any + state is left behind. *) + Alcotest.(check bool) + "Zero fill rate rejected at create" true + (is_invalid_value (fun () -> + let r = + Rate_limit.create ~rpc ~session_id ~name_label:"invalid" + ~name_description:"" ~burst_size:10.0 ~fill_rate:0.0 + in + Rate_limit.destroy ~rpc ~session_id ~self:r + ) + ) ; + Alcotest.(check bool) + "Negative fill rate rejected at create" true + (is_invalid_value (fun () -> + let r = + Rate_limit.create ~rpc ~session_id ~name_label:"invalid" + ~name_description:"" ~burst_size:10.0 ~fill_rate:(-1.0) + in + Rate_limit.destroy ~rpc ~session_id ~self:r + ) + ) ; + Alcotest.(check bool) + "Zero burst rejected at create" true + (is_invalid_value (fun () -> + let r = + Rate_limit.create ~rpc ~session_id ~name_label:"invalid" + ~name_description:"" ~burst_size:0.0 ~fill_rate:1.0 + in + Rate_limit.destroy ~rpc ~session_id ~self:r + ) + ) ; + (* Once a valid rate limit exists, setters must reject invalid updates. *) + let r = + Rate_limit.create ~rpc ~session_id ~name_label:"invalid-setters" + ~name_description:"" ~burst_size:10.0 ~fill_rate:1.0 + in + Fun.protect + ~finally:(fun () -> Rate_limit.destroy ~rpc ~session_id ~self:r) + (fun () -> + Alcotest.(check bool) + "set_fill_rate rejects zero" true + (is_invalid_value (fun () -> + Rate_limit.set_fill_rate ~rpc ~session_id ~self:r ~value:0.0 + ) + ) ; + Alcotest.(check bool) + "set_burst_size rejects negative" true + (is_invalid_value (fun () -> + Rate_limit.set_burst_size ~rpc ~session_id ~self:r ~value:(-1.0) + ) + ) + ) + +let tests () = + let open Qt_filter in + [ + [ + ("rate_limit_throttling", `Slow, rate_limit_throttling_test) + ; ("rate_limit_invalid_rejected", `Quick, rate_limit_invalid_test) + ] + |> conn + ] + |> List.concat diff --git a/ocaml/quicktest/quicktest_vm_snapshot.ml b/ocaml/quicktest/quicktest_vm_snapshot.ml index be48d02e070..182be6c8f33 100644 --- a/ocaml/quicktest/quicktest_vm_snapshot.ml +++ b/ocaml/quicktest/quicktest_vm_snapshot.ml @@ -144,12 +144,15 @@ let test_snapshot_ignore_vdi rpc session_id vm vdi vdi2 = check_vdi_snapshot_of rpc session_id vbds ~vdi "0" let test_revert rpc session_id vm vdi vdi2 ~change = - let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in + let snapshot = + take_snapshot rpc session_id vm ~origin:__FUNCTION__ ~ignore_vdis:[vdi2] + in Client.Client.VM.revert ~rpc ~session_id ~snapshot ; let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:vm in + Alcotest.(check int) + "There should only be one VBD after VM.revert" 1 (List.length vbds) ; let vdi_after = get_vdi_with_user_device rpc session_id vbds "0" in - let vdi_after2 = get_vdi_with_user_device rpc session_id vbds "1" in let check = if change then @@ -158,7 +161,7 @@ let test_revert rpc session_id vm vdi vdi2 ~change = else check_vdis_same in - check vdi vdi_after ; check vdi2 vdi_after2 + check vdi vdi_after let test_revert_cds rpc session_id vm vdi vdi2 = let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in diff --git a/ocaml/sdk-gen/csharp/FriendlyErrorNames.resx b/ocaml/sdk-gen/csharp/FriendlyErrorNames.resx index 5786eca65fa..7fd09739f79 100644 --- a/ocaml/sdk-gen/csharp/FriendlyErrorNames.resx +++ b/ocaml/sdk-gen/csharp/FriendlyErrorNames.resx @@ -324,6 +324,12 @@ Failed to enable external authentication, a duplicate hostname was detected. + + Failed to enable external authentication, none of the found certificates can be used to connect to domain controller. + + + Failed to enable external authentication, no certificates are available for LDAPS communication. + Failed to enable external authentication, permission on the AD server was denied. diff --git a/ocaml/sdk-gen/csharp/autogen/src/HTTP.cs b/ocaml/sdk-gen/csharp/autogen/src/HTTP.cs index c9b07eba90a..41609101a4a 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/HTTP.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/HTTP.cs @@ -203,7 +203,7 @@ private static string ReadLine(Stream stream) /// Read HTTP headers, doing any redirects as necessary /// /// True if a redirect has occurred - headers will need to be resent. - private static bool ReadHttpHeaders(ref Stream stream, IWebProxy proxy, bool nodelay, int timeout_ms, List headers = null) + private static bool ReadHttpHeaders(ref Stream stream, IWebProxy proxy, RemoteCertificateValidationCallback callback, bool nodelay, int timeoutMs, List headers = null) { // read headers/fields string line = ReadLine(stream); @@ -277,7 +277,7 @@ private static bool ReadHttpHeaders(ref Stream stream, IWebProxy proxy, bool nod string url = header == null ? "" : header.Substring(9).Trim(); Uri redirect = new Uri(url); stream.Close(); - stream = ConnectStream(redirect, proxy, nodelay, timeout_ms); + stream = ConnectStream(redirect, proxy, callback, nodelay, timeoutMs); return true; // headers need to be sent again default: @@ -309,20 +309,6 @@ private static int GetResultCode(string line) return bits.Length < 2 ? 0 : Int32.Parse(bits[1]); } - public static bool UseSSL(Uri uri) - { - return uri.Scheme == "https" || uri.Port == DEFAULT_HTTPS_PORT; - } - - private static bool ValidateServerCertificate( - object sender, - X509Certificate certificate, - X509Chain chain, - SslPolicyErrors sslPolicyErrors) - { - return true; - } - ///

/// Returns a secure MD5 hash of the given input string. /// @@ -475,45 +461,24 @@ private static NetworkStream ConnectSocket(Uri uri, bool nodelay, int timeoutMs) /// /// /// + /// /// /// Timeout, in ms. 0 for no timeout. - public static Stream ConnectStream(Uri uri, IWebProxy proxy, bool nodelay, int timeoutMs) + private static Stream ConnectStream(Uri uri, IWebProxy proxy, RemoteCertificateValidationCallback callback, bool nodelay, int timeoutMs) { if (proxy is IMockWebProxy mockProxy) return mockProxy.GetStream(uri); - Stream stream; - bool useProxy = proxy != null && !proxy.IsBypassed(uri); - - if (useProxy) - { - Uri proxyURI = proxy.GetProxy(uri); - stream = ConnectSocket(proxyURI, nodelay, timeoutMs); - } - else - { - stream = ConnectSocket(uri, nodelay, timeoutMs); - } + Stream stream = null; try { - if (useProxy) - { - string line = $"CONNECT {uri.Host}:{uri.Port} HTTP/1.0"; - WriteLine(line, stream); - WriteLine(stream); + stream = AuthenticateProxy(uri, proxy, callback, nodelay, timeoutMs); - List initialResponse = new List(); - ReadHttpHeaders(ref stream, proxy, nodelay, timeoutMs, initialResponse); - - AuthenticateProxy(ref stream, uri, proxy, nodelay, timeoutMs, initialResponse, line); - } - - if (UseSSL(uri)) + if (uri.Scheme == "https" || uri.Port == DEFAULT_HTTPS_PORT) { - SslStream sslStream = new SslStream(stream, false, ValidateServerCertificate, null); + SslStream sslStream = new SslStream(stream, false, callback, null); sslStream.AuthenticateAsClient("", null, SslProtocols.Tls12, true); - stream = sslStream; } @@ -521,25 +486,37 @@ public static Stream ConnectStream(Uri uri, IWebProxy proxy, bool nodelay, int t } catch { - stream.Close(); + stream?.Close(); throw; } } - private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy proxy, bool nodelay, int timeoutMs, List initialResponse, string header) + private static Stream AuthenticateProxy(Uri uri, IWebProxy proxy, RemoteCertificateValidationCallback callback, bool nodelay, int timeoutMs) { + if (proxy == null || proxy.IsBypassed(uri)) + return ConnectSocket(uri, nodelay, timeoutMs); + + Uri proxyUri = proxy.GetProxy(uri); + Stream stream = ConnectSocket(proxyUri, nodelay, timeoutMs); + + string header = $"CONNECT {uri.Host}:{uri.Port} HTTP/1.0"; + WriteLine(header, stream); + WriteLine(stream); + + var initialResponse = new List(); + ReadHttpHeaders(ref stream, proxy, callback, nodelay, timeoutMs, initialResponse); + // perform authentication only if proxy requires it List fields = initialResponse.FindAll(str => str.StartsWith("Proxy-Authenticate:", StringComparison.InvariantCultureIgnoreCase)); if (fields.Count <= 0) - return; + return stream; // clean up (if initial server response specifies "Proxy-Connection: Close" then stream cannot be re-used) string field = initialResponse.Find(str => str.StartsWith("Proxy-Connection: Close", StringComparison.InvariantCultureIgnoreCase)); if (!string.IsNullOrEmpty(field)) { stream.Close(); - Uri proxyURI = proxy.GetProxy(uri); - stream = ConnectSocket(proxyURI, nodelay, timeoutMs); + stream = ConnectSocket(proxyUri, nodelay, timeoutMs); } if (proxy.Credentials == null) @@ -675,7 +652,8 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox // handle authentication attempt response List authenticatedResponse = new List(); - ReadHttpHeaders(ref stream, proxy, nodelay, timeoutMs, authenticatedResponse); + ReadHttpHeaders(ref stream, proxy, callback, nodelay, timeoutMs, authenticatedResponse); + if (authenticatedResponse.Count == 0) throw new BadServerResponseException("No response from the proxy server after authentication attempt."); @@ -688,11 +666,13 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox default: throw new BadServerResponseException($"Received error code {authenticatedResponse[0]} from the server"); } + + return stream; } - private static Stream DoHttp(Uri uri, IWebProxy proxy, bool noDelay, int timeoutMs, params string[] headers) + private static Stream DoHttp(Uri uri, IWebProxy proxy, RemoteCertificateValidationCallback callback, bool noDelay, int timeoutMs, params string[] headers) { - Stream stream = ConnectStream(uri, proxy, noDelay, timeoutMs); + Stream stream = ConnectStream(uri, proxy, callback, noDelay, timeoutMs); int redirects = 0; @@ -709,7 +689,7 @@ private static Stream DoHttp(Uri uri, IWebProxy proxy, bool noDelay, int timeout stream.Flush(); } - while (ReadHttpHeaders(ref stream, proxy, noDelay, timeoutMs)); + while (ReadHttpHeaders(ref stream, proxy, callback, noDelay, timeoutMs)); return stream; } @@ -717,7 +697,7 @@ private static Stream DoHttp(Uri uri, IWebProxy proxy, bool noDelay, int timeout /// /// Adds HTTP CONNECT headers returning the stream ready for use /// - public static Stream HttpConnectStream(Uri uri, IWebProxy proxy, string session, int timeoutMs, Dictionary additionalHeaders = null) + public static Stream HttpConnectStream(Uri uri, IWebProxy proxy, RemoteCertificateValidationCallback callback, string session, int timeoutMs, Dictionary additionalHeaders = null) { var allHeaders = new List { @@ -732,13 +712,13 @@ public static Stream HttpConnectStream(Uri uri, IWebProxy proxy, string session, allHeaders.Add($"{kvp.Key}: {kvp.Value}"); } - return DoHttp(uri, proxy, true, timeoutMs, allHeaders.ToArray()); + return DoHttp(uri, proxy, callback, true, timeoutMs, allHeaders.ToArray()); } /// /// Adds HTTP PUT headers returning the stream ready for use /// - public static Stream HttpPutStream(Uri uri, IWebProxy proxy, long contentLength, int timeoutMs, Dictionary additionalHeaders = null) + public static Stream HttpPutStream(Uri uri, IWebProxy proxy, RemoteCertificateValidationCallback callback, long contentLength, int timeoutMs, Dictionary additionalHeaders = null) { var allHeaders = new List { @@ -753,13 +733,13 @@ public static Stream HttpPutStream(Uri uri, IWebProxy proxy, long contentLength, allHeaders.Add($"{kvp.Key}: {kvp.Value}"); } - return DoHttp(uri, proxy, false, timeoutMs, allHeaders.ToArray()); + return DoHttp(uri, proxy, callback, false, timeoutMs, allHeaders.ToArray()); } /// /// Adds HTTP GET headers returning the stream ready for use /// - public static Stream HttpGetStream(Uri uri, IWebProxy proxy, int timeoutMs, Dictionary additionalHeaders = null) + public static Stream HttpGetStream(Uri uri, IWebProxy proxy, RemoteCertificateValidationCallback callback, int timeoutMs, Dictionary additionalHeaders = null) { var allHeaders = new List { @@ -773,7 +753,7 @@ public static Stream HttpGetStream(Uri uri, IWebProxy proxy, int timeoutMs, Dict allHeaders.Add($"{kvp.Key}: {kvp.Value}"); } - return DoHttp(uri, proxy, false, timeoutMs, allHeaders.ToArray()); + return DoHttp(uri, proxy, callback, false, timeoutMs, allHeaders.ToArray()); } /// @@ -783,13 +763,14 @@ public static Stream HttpGetStream(Uri uri, IWebProxy proxy, int timeoutMs, Dict /// Delegate called periodically to see if need to cancel /// URI to PUT to /// A proxy to handle the HTTP connection + /// /// Path to file to put /// Timeout for the connection in ms. 0 for no timeout. public static void Put(UpdateProgressDelegate progressDelegate, FuncBool cancellingDelegate, - Uri uri, IWebProxy proxy, string path, int timeoutMs) + Uri uri, IWebProxy proxy, RemoteCertificateValidationCallback callback, string path, int timeoutMs) { using (Stream fileStream = new FileStream(path, FileMode.Open, FileAccess.Read), - requestStream = HttpPutStream(uri, proxy, fileStream.Length, timeoutMs)) + requestStream = HttpPutStream(uri, proxy, callback, fileStream.Length, timeoutMs)) { long len = fileStream.Length; DataCopiedDelegate dataCopiedDelegate = delegate(long bytes) @@ -809,10 +790,11 @@ public static void Put(UpdateProgressDelegate progressDelegate, FuncBool cancell /// Delegate called periodically to see if need to cancel /// URI to GET from /// A proxy to handle the HTTP connection + /// /// Path to file to receive the data /// Timeout for the connection in ms. 0 for no timeout. public static void Get(DataCopiedDelegate dataCopiedDelegate, FuncBool cancellingDelegate, - Uri uri, IWebProxy proxy, string path, int timeoutMs) + Uri uri, IWebProxy proxy, RemoteCertificateValidationCallback callback, string path, int timeoutMs) { if (string.IsNullOrWhiteSpace(path)) throw new ArgumentException(nameof(path)); @@ -833,7 +815,7 @@ public static void Get(DataCopiedDelegate dataCopiedDelegate, FuncBool cancellin try { using (Stream fileStream = new FileStream(tmpFile, FileMode.Create, FileAccess.Write, FileShare.None), - downloadStream = HttpGetStream(uri, proxy, timeoutMs)) + downloadStream = HttpGetStream(uri, proxy, callback, timeoutMs)) { CopyStream(downloadStream, fileStream, dataCopiedDelegate, cancellingDelegate); fileStream.Flush(); diff --git a/ocaml/sdk-gen/csharp/templates/HTTP_actions.mustache b/ocaml/sdk-gen/csharp/templates/HTTP_actions.mustache index 3c702c2af15..f1531bb63dd 100644 --- a/ocaml/sdk-gen/csharp/templates/HTTP_actions.mustache +++ b/ocaml/sdk-gen/csharp/templates/HTTP_actions.mustache @@ -28,44 +28,45 @@ */ using System.Net; +using System.Net.Security; namespace XenAPI { public partial class HTTP_actions { private static void Get(HTTP.DataCopiedDelegate dataCopiedDelegate, HTTP.FuncBool cancellingDelegate, int timeout_ms, - string hostname, string remotePath, IWebProxy proxy, string localPath, params object[] args) + string hostname, string remotePath, IWebProxy proxy, RemoteCertificateValidationCallback callback, string localPath, params object[] args) { - HTTP.Get(dataCopiedDelegate, cancellingDelegate, HTTP.BuildUri(hostname, remotePath, args), proxy, localPath, timeout_ms); + HTTP.Get(dataCopiedDelegate, cancellingDelegate, HTTP.BuildUri(hostname, remotePath, args), proxy, callback, localPath, timeout_ms); } private static void Put(HTTP.UpdateProgressDelegate progressDelegate, HTTP.FuncBool cancellingDelegate, int timeout_ms, - string hostname, string remotePath, IWebProxy proxy, string localPath, params object[] args) + string hostname, string remotePath, IWebProxy proxy, RemoteCertificateValidationCallback callback, string localPath, params object[] args) { - HTTP.Put(progressDelegate, cancellingDelegate, HTTP.BuildUri(hostname, remotePath, args), proxy, localPath, timeout_ms); + HTTP.Put(progressDelegate, cancellingDelegate, HTTP.BuildUri(hostname, remotePath, args), proxy, callback, localPath, timeout_ms); } {{#http_actions}} public static void {{name}}(HTTP.{{#isPut}}UpdateProgressDelegate progressDelegate{{/isPut}}{{#isGet}}DataCopiedDelegate dataCopiedDelegate{{/isGet}}, HTTP.FuncBool cancellingDelegate, int timeout_ms, - string hostname, IWebProxy proxy, string path, string task_id = null, string session_id = null{{#args}}, {{{arg_decl}}}{{/args}}) + string hostname, IWebProxy proxy, RemoteCertificateValidationCallback callback, string path, string task_id = null, string session_id = null{{#args}}, {{{arg_decl}}}{{/args}}) { - {{#isPut}}Put{{/isPut}}{{#isGet}}Get{{/isGet}}({{#isPut}}progressDelegate{{/isPut}}{{#isGet}}dataCopiedDelegate{{/isGet}}, cancellingDelegate, timeout_ms, hostname, "{{uri}}", proxy, path, + {{#isPut}}Put{{/isPut}}{{#isGet}}Get{{/isGet}}({{#isPut}}progressDelegate{{/isPut}}{{#isGet}}dataCopiedDelegate{{/isGet}}, cancellingDelegate, timeout_ms, hostname, "{{uri}}", proxy, callback, path, "task_id", task_id, "session_id", session_id{{#args}}, {{{arg_use}}}{{/args}}); } {{/http_actions}} public static void get_pool_patch_download(HTTP.DataCopiedDelegate dataCopiedDelegate, HTTP.FuncBool cancellingDelegate, int timeout_ms, - string hostname, IWebProxy proxy, string path, string task_id, string session_id, string uuid) + string hostname, IWebProxy proxy, RemoteCertificateValidationCallback callback, string path, string task_id, string session_id, string uuid) { - Get(dataCopiedDelegate, cancellingDelegate, timeout_ms, hostname, "/pool_patch_download", proxy, path, + Get(dataCopiedDelegate, cancellingDelegate, timeout_ms, hostname, "/pool_patch_download", proxy, callback, path, "task_id", task_id, "session_id", session_id, "uuid", uuid); } public static void put_oem_patch_stream(HTTP.UpdateProgressDelegate progressDelegate, HTTP.FuncBool cancellingDelegate, int timeout_ms, - string hostname, IWebProxy proxy, string path, string task_id, string session_id) + string hostname, IWebProxy proxy, RemoteCertificateValidationCallback callback, string path, string task_id, string session_id) { - Put(progressDelegate, cancellingDelegate, timeout_ms, hostname, "/oem_patch_stream", proxy, path, + Put(progressDelegate, cancellingDelegate, timeout_ms, hostname, "/oem_patch_stream", proxy, callback, path, "task_id", task_id, "session_id", session_id); } } diff --git a/ocaml/sdk-gen/java/autogen/xen-api/pom.xml b/ocaml/sdk-gen/java/autogen/xen-api/pom.xml index 460743379b2..b356fc33af6 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/pom.xml +++ b/ocaml/sdk-gen/java/autogen/xen-api/pom.xml @@ -55,7 +55,7 @@ com.fasterxml.jackson.core jackson-databind - 2.21.2 + 2.22.0 org.apache.httpcomponents.client5 diff --git a/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs b/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs index 943c91a7642..5c10656a072 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs @@ -30,7 +30,11 @@ using System; using System.Collections; using System.Collections.Generic; +using System.IO; using System.Management.Automation; +using System.Security.Cryptography; +using System.Security.Cryptography.X509Certificates; +using System.Xml; using XenAPI; namespace Citrix.XenServer @@ -39,6 +43,7 @@ internal class CommonCmdletFunctions { private const string SessionsVariable = "global:Citrix.XenServer.Sessions"; private const string DefaultSessionVariable = "global:XenServer_Default_Session"; + private const string CertificatesPathVariable = "global:KnownServerCertificatesFilePath"; internal static Dictionary GetAllSessions(PSCmdlet cmdlet) { @@ -137,5 +142,125 @@ internal static object EnumParseDefault(Type t, string s) } } } + + internal static bool VerifyInAllStores(X509Certificate2 certificate2) + { + try + { + X509Chain chain = new X509Chain(true); + return chain.Build(certificate2) || certificate2.Verify(); + } + catch (CryptographicException) + { + return false; + } + } + + internal static string GetCertificatesPath(PSCmdlet cmdlet) + { + var certPathObject = cmdlet.SessionState.PSVariable.GetValue(CertificatesPathVariable); + + return certPathObject is PSObject psObject + ? psObject.BaseObject as string + : certPathObject?.ToString() ?? string.Empty; + } + + internal static Dictionary LoadCertificates(string certPath) + { + var certificates = new Dictionary(); + + if (File.Exists(certPath)) + { + var doc = new XmlDocument(); + doc.Load(certPath); + + foreach (XmlNode node in doc.GetElementsByTagName("certificate")) + { + var hostAtt = node.Attributes?["hostname"]; + var fngprtAtt = node.Attributes?["fingerprint"]; + + if (hostAtt != null && fngprtAtt != null) + certificates[hostAtt.Value] = fngprtAtt.Value; + } + } + + return certificates; + } + + internal static void SaveCertificates(string certPath, Dictionary certificates) + { + string dirName = Path.GetDirectoryName(certPath); + + if (!Directory.Exists(dirName)) + Directory.CreateDirectory(dirName); + + XmlDocument doc = new XmlDocument(); + XmlDeclaration decl = doc.CreateXmlDeclaration("1.0", "utf-8", null); + doc.AppendChild(decl); + XmlNode node = doc.CreateElement("certificates"); + + foreach (KeyValuePair cert in certificates) + { + XmlNode certNode = doc.CreateElement("certificate"); + XmlAttribute hostname = doc.CreateAttribute("hostname"); + XmlAttribute fingerprint = doc.CreateAttribute("fingerprint"); + hostname.Value = cert.Key; + fingerprint.Value = cert.Value; + certNode.Attributes?.Append(hostname); + certNode.Attributes?.Append(fingerprint); + node.AppendChild(certNode); + } + + doc.AppendChild(node); + doc.Save(certPath); + } + } + + internal abstract class CertificateValidationException : Exception + { + protected const string CERT_TRUSTED = "The certificate on this server is trusted. It is recommended you re-issue this server's certificate."; + protected const string CERT_NOT_TRUSTED = "The certificate on this server is not trusted."; + + protected CertificateValidationException(string fingerprint, bool trusted, string hostname) + { + Fingerprint = fingerprint; + Trusted = trusted; + Hostname = hostname; + } + + protected bool Trusted { get; } + public string Fingerprint { get; } + public string Hostname { get; } + public abstract string Caption { get; } + } + + internal class CertificateChangedException : CertificateValidationException + { + public CertificateChangedException(string fingerprint, bool trusted, string hostname) + : base(fingerprint, trusted, hostname) + { + } + + public override string Caption => "Security Certificate Changed"; + + public override string Message => + $"The certificate thumbprint of server {Hostname} has changed since the last time you connected.\n" + + $"The certificate thumbprint of the server is:\n{Fingerprint}\n" + + (Trusted ? CERT_TRUSTED : CERT_NOT_TRUSTED) + + "\nDo you wish to continue?"; + } + + internal class CertificateNotFoundException : CertificateValidationException + { + public CertificateNotFoundException(string fingerprint, bool trusted, string hostname) + : base(fingerprint, trusted, hostname) + { + } + + public override string Caption => "New Security Certificate"; + + public override string Message => $"The certificate thumbprint of the server you have connected to is :\n{Fingerprint}\n" + + (Trusted ? CERT_TRUSTED : CERT_NOT_TRUSTED) + + "\nDo you wish to continue?"; } } diff --git a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs index dd61f358524..f9719979126 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs @@ -29,7 +29,6 @@ using System; using System.Collections.Generic; -using System.IO; using System.Management.Automation; using System.Net; #if NET8_0_OR_GREATER @@ -38,9 +37,7 @@ using System.Net.Security; using System.Runtime.InteropServices; using System.Security; -using System.Security.Cryptography; using System.Security.Cryptography.X509Certificates; -using System.Xml; using XenAPI; namespace Citrix.XenServer.Commands @@ -48,11 +45,8 @@ namespace Citrix.XenServer.Commands [Cmdlet("Connect", "XenServer")] public class ConnectXenServerCommand : PSCmdlet { - private const string CertificatesPathVariable = "global:KnownServerCertificatesFilePath"; - - private readonly object _certificateValidationLock = new object(); - - private static readonly string DefaultUserAgent = $"XenServerPSModule/@SDK_VERSION@"; + private static readonly string DefaultUserAgent = "XenServerPSModule/@SDK_VERSION@"; + private static readonly object CertificateValidationLock = new object(); public ConnectXenServerCommand() { @@ -228,10 +222,10 @@ protected override void ProcessRecord() { if (ShouldContinue(ex.Message, ex.Caption)) { - var certPath = GetCertificatesPath(); - var certificates = LoadCertificates(certPath); + var certPath = CommonCmdletFunctions.GetCertificatesPath(this); + var certificates = CommonCmdletFunctions.LoadCertificates(certPath); certificates[ex.Hostname] = ex.Fingerprint; - SaveCertificates(certPath, certificates); + CommonCmdletFunctions.SaveCertificates(certPath, certificates); i--; continue; } @@ -274,171 +268,53 @@ protected override void ProcessRecord() WriteObject(newSessions.Values, true); } - private bool ValidateServerCertificate(object sender, X509Certificate certificate, X509Chain chain, SslPolicyErrors sslPolicyErrors) + private bool ValidateServerCertificate(object sender, X509Certificate certificate, X509Chain chain, + SslPolicyErrors sslPolicyErrors) { if (sslPolicyErrors == SslPolicyErrors.None) return true; - lock (_certificateValidationLock) - { - bool ignoreChanged = Force || NoWarnCertificates || (bool)GetVariableValue("NoWarnCertificates", false); - bool ignoreNew = Force || NoWarnNewCertificates || (bool)GetVariableValue("NoWarnNewCertificates", false); - #if NET8_0_OR_GREATER - var requestMessage = sender as HttpRequestMessage; - string hostname = requestMessage?.RequestUri?.Host ?? string.Empty; + var requestMessage = sender as HttpRequestMessage; + string hostname = requestMessage?.RequestUri?.Host ?? string.Empty; #else - var webreq = sender as HttpWebRequest; - string hostname = webreq?.Address?.Host ?? string.Empty; + var webreq = sender as HttpWebRequest; + string hostname = webreq?.Address?.Host ?? string.Empty; #endif - string fingerprint = CommonCmdletFunctions.FingerprintPrettyString(certificate.GetCertHashString()); - bool trusted = VerifyInAllStores(new X509Certificate2(certificate)); + string fingerprint = CommonCmdletFunctions.FingerprintPrettyString(certificate.GetCertHashString()); - var certPath = GetCertificatesPath(); - var certificates = LoadCertificates(certPath); + lock (CertificateValidationLock) + { + var certPath = CommonCmdletFunctions.GetCertificatesPath(this); + var certificates = CommonCmdletFunctions.LoadCertificates(certPath); if (certificates.TryGetValue(hostname, out var fingerprintOld)) { if (fingerprintOld == fingerprint) return true; + bool ignoreChanged = Force || NoWarnCertificates || (bool)GetVariableValue("NoWarnCertificates", false); if (!ignoreChanged) - throw new CertificateChangedException(fingerprint, fingerprintOld, trusted, hostname); + { + var trusted = CommonCmdletFunctions.VerifyInAllStores(new X509Certificate2(certificate)); + throw new CertificateChangedException(fingerprint, trusted, hostname); + } } else { + bool ignoreNew = Force || NoWarnNewCertificates || (bool)GetVariableValue("NoWarnNewCertificates", false); if (!ignoreNew) + { + var trusted = CommonCmdletFunctions.VerifyInAllStores(new X509Certificate2(certificate)); throw new CertificateNotFoundException(fingerprint, trusted, hostname); + } } certificates[hostname] = fingerprint; - SaveCertificates(certPath, certificates); + CommonCmdletFunctions.SaveCertificates(certPath, certificates); return true; } } - - private bool VerifyInAllStores(X509Certificate2 certificate2) - { - try - { - X509Chain chain = new X509Chain(true); - return chain.Build(certificate2) || certificate2.Verify(); - } - catch (CryptographicException) - { - return false; - } - } - - private string GetCertificatesPath() - { - var certPathObject = SessionState.PSVariable.GetValue(CertificatesPathVariable); - - return certPathObject is PSObject psObject - ? psObject.BaseObject as string - : certPathObject?.ToString() ?? string.Empty; - } - - private Dictionary LoadCertificates(string certPath) - { - var certificates = new Dictionary(); - - if (File.Exists(certPath)) - { - var doc = new XmlDocument(); - doc.Load(certPath); - - foreach (XmlNode node in doc.GetElementsByTagName("certificate")) - { - var hostAtt = node.Attributes?["hostname"]; - var fngprtAtt = node.Attributes?["fingerprint"]; - - if (hostAtt != null && fngprtAtt != null) - certificates[hostAtt.Value] = fngprtAtt.Value; - } - } - - return certificates; - } - - private void SaveCertificates(string certPath, Dictionary certificates) - { - string dirName = Path.GetDirectoryName(certPath); - - if (!Directory.Exists(dirName)) - Directory.CreateDirectory(dirName); - - XmlDocument doc = new XmlDocument(); - XmlDeclaration decl = doc.CreateXmlDeclaration("1.0", "utf-8", null); - doc.AppendChild(decl); - XmlNode node = doc.CreateElement("certificates"); - - foreach (KeyValuePair cert in certificates) - { - XmlNode certNode = doc.CreateElement("certificate"); - XmlAttribute hostname = doc.CreateAttribute("hostname"); - XmlAttribute fingerprint = doc.CreateAttribute("fingerprint"); - hostname.Value = cert.Key; - fingerprint.Value = cert.Value; - certNode.Attributes?.Append(hostname); - certNode.Attributes?.Append(fingerprint); - node.AppendChild(certNode); - } - - doc.AppendChild(node); - doc.Save(certPath); - } - } - - internal abstract class CertificateValidationException : Exception - { - protected const string CERT_TRUSTED = "The certificate on this server is trusted. It is recommended you re-issue this server's certificate."; - protected const string CERT_NOT_TRUSTED = "The certificate on this server is not trusted."; - - protected readonly bool Trusted; - public readonly string Fingerprint; - public readonly string Hostname; - - protected CertificateValidationException(string fingerprint, bool trusted, string hostname) - { - Fingerprint = fingerprint; - Trusted = trusted; - Hostname = hostname; - } - - public abstract string Caption { get; } - } - - internal class CertificateChangedException : CertificateValidationException - { - private readonly string _oldFingerprint; - - public CertificateChangedException(string fingerprint, string oldFingerprint, bool trusted, string hostname) - : base(fingerprint, trusted, hostname) - { - _oldFingerprint = oldFingerprint; - } - - public override string Caption => "Security Certificate Changed"; - - public override string Message => $"The certificate fingerprint of the server you have connected to is:\n{Fingerprint}\n" + - $"But was expected to be:\n{_oldFingerprint}\n" + - (Trusted ? CERT_TRUSTED : CERT_NOT_TRUSTED) + - "\nDo you wish to continue?"; - } - - internal class CertificateNotFoundException : CertificateValidationException - { - public CertificateNotFoundException(string fingerprint, bool trusted, string hostname) - : base(fingerprint, trusted, hostname) - { - } - - public override string Caption => "New Security Certificate"; - - public override string Message => $"The certificate fingerprint of the server you have connected to is :\n{Fingerprint}\n" + - (Trusted ? CERT_TRUSTED : CERT_NOT_TRUSTED) + - "\nDo you wish to continue?"; } } diff --git a/ocaml/sdk-gen/powershell/autogen/src/Receive-XenPoolPatch.cs b/ocaml/sdk-gen/powershell/autogen/src/Receive-XenPoolPatch.cs index 7442e047ef2..836819e1296 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/Receive-XenPoolPatch.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/Receive-XenPoolPatch.cs @@ -58,8 +58,8 @@ protected override void ProcessRecord() GetSession(); RunApiCall(() => XenAPI.HTTP_actions.get_pool_patch_download(DataCopiedDelegate, - CancellingDelegate, TimeoutMs, XenHost, Proxy, Path, TaskRef, - session.opaque_ref, Uuid)); + CancellingDelegate, TimeoutMs, XenHost, Proxy, CertificateValidationCallback, + Path, TaskRef, session.opaque_ref, Uuid)); } #endregion diff --git a/ocaml/sdk-gen/powershell/autogen/src/Send-XenOemPatchStream.cs b/ocaml/sdk-gen/powershell/autogen/src/Send-XenOemPatchStream.cs index 3c6768f6d3a..2da05781c9e 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/Send-XenOemPatchStream.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/Send-XenOemPatchStream.cs @@ -58,8 +58,8 @@ protected override void ProcessRecord() return; RunApiCall(() => XenAPI.HTTP_actions.put_oem_patch_stream(ProgressDelegate, - CancellingDelegate, TimeoutMs, XenHost, Proxy, Path, TaskRef, - session.opaque_ref)); + CancellingDelegate, TimeoutMs, XenHost, Proxy, CertificateValidationCallback, + Path, TaskRef, session.opaque_ref)); } #endregion diff --git a/ocaml/sdk-gen/powershell/autogen/src/XenServerCmdlet.cs b/ocaml/sdk-gen/powershell/autogen/src/XenServerCmdlet.cs index fffa65b5823..1572b346db9 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/XenServerCmdlet.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/XenServerCmdlet.cs @@ -29,7 +29,6 @@ using System; -using System.Collections; using System.Collections.Generic; using System.Management.Automation; @@ -113,23 +112,44 @@ protected void UpdateSessions() protected void RunApiCall(XenApiCall call) { - try + for (int i = 0; i < 1; i++) { - call.Invoke(); - } - catch (Exception e) - { - // if you want to trap errors either set command-line switch "-BestEffort" - // or session-state variable "$BestEffort" to "$true" - - bool bestEffort = (bool)GetVariableValue("BestEffort", false) || BestEffort; - if (!bestEffort) - throw; - - // catch exception and write it to the terminal then return - // don't throw it because this will break piping a list into the cmd (won't run rest of list) - - ThrowTerminatingError(new ErrorRecord(e, string.Empty, ErrorCategory.InvalidOperation, null)); + try + { + call.Invoke(); + } + catch (Exception e) + { + if (e is CertificateValidationException ex) + { + if (ShouldContinue(ex.Message, ex.Caption)) + { + var certPath = CommonCmdletFunctions.GetCertificatesPath(this); + var certificates = CommonCmdletFunctions.LoadCertificates(certPath); + certificates[ex.Hostname] = ex.Fingerprint; + CommonCmdletFunctions.SaveCertificates(certPath, certificates); + i--; + continue; + } + + ThrowTerminatingError(new ErrorRecord(ex, "", ErrorCategory.AuthenticationError, ex.Hostname) + { + ErrorDetails = new ErrorDetails($"Certificate fingerprint rejected. ({ex.Fingerprint} - {ex.Hostname}).") + }); + } + + // if you want to trap errors either set command-line switch "-BestEffort" + // or session-state variable "$BestEffort" to "$true" + + bool bestEffort = (bool)GetVariableValue("BestEffort", false) || BestEffort; + if (!bestEffort) + throw; + + // catch exception and write it to the terminal then return + // don't throw it because this will break piping a list into the cmd (won't run rest of list) + + ThrowTerminatingError(new ErrorRecord(e, string.Empty, ErrorCategory.InvalidOperation, null)); + } } } diff --git a/ocaml/sdk-gen/powershell/autogen/src/XenServerHttpCmdlet.cs b/ocaml/sdk-gen/powershell/autogen/src/XenServerHttpCmdlet.cs index 0fdecbab02f..fcbf4d18b86 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/XenServerHttpCmdlet.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/XenServerHttpCmdlet.cs @@ -29,16 +29,24 @@ using System; -using System.Collections.Generic; using System.Management.Automation; using System.Net; - +using System.Net.Security; +using System.Security.Cryptography.X509Certificates; using XenAPI; namespace Citrix.XenServer.Commands { public class XenServerHttpCmdlet : XenServerCmdlet { + private bool _hitonce; + private static readonly object CertificateValidationLock = new object(); + + protected XenServerHttpCmdlet() + { + CertificateValidationCallback = ValidateServerCertificate; + } + #region Cmdlet Parameters [Parameter] @@ -53,6 +61,15 @@ public class XenServerHttpCmdlet : XenServerCmdlet [Parameter] public IWebProxy Proxy { get; set; } + [Parameter] + public RemoteCertificateValidationCallback CertificateValidationCallback { get; set; } + + [Parameter] + public SwitchParameter NoWarnNewCertificates { get; set; } + + [Parameter] + public SwitchParameter NoWarnCertificates { get; set; } + [Parameter(Mandatory = true)] public string Path { get; set; } @@ -60,5 +77,55 @@ public class XenServerHttpCmdlet : XenServerCmdlet public string TaskRef { get; set; } #endregion + + private bool ValidateServerCertificate(object sender, X509Certificate certificate, X509Chain chain, SslPolicyErrors sslPolicyErrors) + { + try + { + if (sslPolicyErrors == SslPolicyErrors.None) + return true; + + string fingerprintToCheck = CommonCmdletFunctions.FingerprintPrettyString(certificate.GetCertHashString()); + + lock (CertificateValidationLock) + { + var certPath = CommonCmdletFunctions.GetCertificatesPath(this); + var certificates = CommonCmdletFunctions.LoadCertificates(certPath); + + if (certificates.TryGetValue(XenHost, out var hostFingerprint)) + { + if (fingerprintToCheck == hostFingerprint) + return true; + + bool ignoreChanged = NoWarnCertificates || (bool)GetVariableValue("NoWarnCertificates", false); + if (!ignoreChanged) + { + if (_hitonce) + throw new Exception($"{XenHost} is not the correct server for this operation. Please specify a different server in the pool."); + + var trusted = CommonCmdletFunctions.VerifyInAllStores(new X509Certificate2(certificate)); + throw new CertificateChangedException(fingerprintToCheck, trusted, XenHost); + } + } + else + { + bool ignoreNew = NoWarnNewCertificates || (bool)GetVariableValue("NoWarnNewCertificates", false); + if (!ignoreNew) + { + var trusted = CommonCmdletFunctions.VerifyInAllStores(new X509Certificate2(certificate)); + throw new CertificateNotFoundException(fingerprintToCheck, trusted, XenHost); + } + } + + certificates[XenHost] = fingerprintToCheck; + CommonCmdletFunctions.SaveCertificates(certPath, certificates); + return true; + } + } + finally + { + _hitonce = true; + } + } } } diff --git a/ocaml/sdk-gen/powershell/templates/HttpAction.mustache b/ocaml/sdk-gen/powershell/templates/HttpAction.mustache index e346a68b8fe..40b5b897745 100644 --- a/ocaml/sdk-gen/powershell/templates/HttpAction.mustache +++ b/ocaml/sdk-gen/powershell/templates/HttpAction.mustache @@ -71,7 +71,7 @@ namespace Citrix.XenServer.Commands {{/isPut}} RunApiCall(() => HTTP_actions.{{action_name}}({{#isPut}}ProgressDelegate{{/isPut}}{{#isGet}}DataCopiedDelegate{{/isGet}}, - CancellingDelegate, TimeoutMs, XenHost, Proxy, Path, TaskRef, + CancellingDelegate, TimeoutMs, XenHost, Proxy, CertificateValidationCallback, Path, TaskRef, session.opaque_ref{{#args}}, {{arg_name}}{{/args}})); } diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index 9ad139d6462..47859d0671b 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -278,7 +278,7 @@ let make_vif ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) ?(ipv4_allowed = []) ?(ipv6_allowed = []) ?(ipv4_configuration_mode = `None) ?(ipv4_addresses = []) ?(ipv4_gateway = "") ?(ipv6_configuration_mode = `None) ?(ipv6_addresses = []) - ?(ipv6_gateway = "") () = + ?(ipv6_gateway = "") ?(trunks = []) () = Db.VIF.create ~__context ~ref ~uuid ~current_operations ~allowed_operations ~reserved ~device ~network ~vM ~mAC ~mAC_autogenerated ~mTU ~qos_algorithm_type ~qos_algorithm_params ~qos_supported_algorithms @@ -286,7 +286,7 @@ let make_vif ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) ~other_config ~metrics ~locking_mode ~ipv4_allowed ~ipv6_allowed ~ipv4_configuration_mode ~ipv4_addresses ~ipv4_gateway ~ipv6_configuration_mode ~ipv6_addresses ~ipv6_gateway - ~reserved_pci:Ref.null ; + ~reserved_pci:Ref.null ~trunks ; ref let make_pool ~__context ~master ?(name_label = "") ?(name_description = "") @@ -315,7 +315,8 @@ let make_pool ~__context ~master ?(name_label = "") ?(name_description = "") ?(update_sync_day = 0L) ?(update_sync_enabled = false) ?(recommendations = []) ?(license_server = []) ?(ha_reboot_vm_on_internal_shutdown = true) - ?(limit_console_sessions = false) ?(vm_console_idle_timeout = 0L) () = + ?(limit_console_sessions = false) ?(vm_console_idle_timeout = 0L) + ?(auto_update_vm_secureboot_certificates = false) () = let pool_ref = Ref.make () in Db.Pool.create ~__context ~ref:pool_ref ~uuid:(make_uuid ()) ~name_label ~name_description ~master ~default_SR ~suspend_image_SR ~crash_dump_SR @@ -337,7 +338,7 @@ let make_pool ~__context ~master ?(name_label = "") ?(name_description = "") ~ext_auth_cache_expiry:300L ~update_sync_frequency ~update_sync_day ~update_sync_enabled ~recommendations ~license_server ~ha_reboot_vm_on_internal_shutdown ~limit_console_sessions - ~vm_console_idle_timeout ; + ~vm_console_idle_timeout ~auto_update_vm_secureboot_certificates ; pool_ref let default_sm_features = diff --git a/ocaml/tests/suite_alcotest.ml b/ocaml/tests/suite_alcotest.ml index 74cc129b656..d93a2663404 100644 --- a/ocaml/tests/suite_alcotest.ml +++ b/ocaml/tests/suite_alcotest.ml @@ -37,6 +37,7 @@ let () = ; ("Test_pvs_proxy", Test_pvs_proxy.test) ; ("Test_pvs_server", Test_pvs_server.test) ; ("Test_vif_helpers", Test_vif_helpers.test) + ; ("Test_vif_trunks", Test_vif_trunks.test) ; ("Test_vm_memory_constraints", Test_vm_memory_constraints.test) ; ("Test_xapi_xenops", Test_xapi_xenops.test) ; ("Test_network_event_loop", Test_network_event_loop.test) @@ -44,6 +45,7 @@ let () = ; ("Test_storage_migrate_state", Test_storage_migrate_state.test) ; ("Test_bios_strings", Test_bios_strings.test) ; ("Test_certificates", Test_certificates.test) + ; ("Test_caller_limit", Test_caller_limit.test) ] @ Test_guest_agent.tests @ Test_nm.tests diff --git a/ocaml/tests/test_caller_limit.ml b/ocaml/tests/test_caller_limit.ml new file mode 100644 index 00000000000..cd733cb57c7 --- /dev/null +++ b/ocaml/tests/test_caller_limit.ml @@ -0,0 +1,160 @@ +(* + * Copyright (C) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(* Exercises the cap on auto-registered callers (Xapi_globs.max_auto_registered_callers) + and the least-recently-called eviction policy in Xapi_caller. The in-memory + caller_table is process-global, so all cases share one database context and + clean up through the public [destroy] between phases. *) + +let context = lazy (Test_common.make_test_database ()) + +(* Run the auto-create/rate-limit machinery synchronously by giving [submit_sync] + a [task_create] that runs its closure inline against the test context. *) +let call ~__context ~user_agent ~client_ip = + Xapi_caller.submit_sync ~user_agent ~client_ip + ~callback:(fun () -> ()) + ~task_create:(fun f -> f __context) + 1.0 + +(* Drop every caller so the global caller_table and the database start empty. *) +let reset ~__context = + List.iter + (fun self -> Xapi_caller.destroy ~__context ~self) + (Db.Caller.get_all ~__context) + +let user_agents ~__context = + Db.Caller.get_all ~__context + |> List.map (fun self -> Db.Caller.get_user_agent ~__context ~self) + |> List.sort String.compare + +let check_user_agents ~__context msg expected = + Alcotest.(check (list string)) msg expected (user_agents ~__context) + +let with_setup ~limit f = + let __context = Lazy.force context in + reset ~__context ; + Xapi_globs.rate_limit_enabled := true ; + Xapi_globs.max_auto_registered_callers := limit ; + f ~__context + +(* At the cap, a further distinct caller evicts the auto-registered caller with + the least recent call - not merely the oldest by creation. *) +let test_evicts_least_recently_called () = + with_setup ~limit:2 (fun ~__context -> + call ~__context ~user_agent:"agent-1" ~client_ip:"10.0.0.1" ; + call ~__context ~user_agent:"agent-2" ~client_ip:"10.0.0.2" ; + check_user_agents ~__context "two callers auto-registered" + ["agent-1"; "agent-2"] ; + (* Touch agent-1 again so agent-2 becomes the least recently called. *) + call ~__context ~user_agent:"agent-1" ~client_ip:"10.0.0.1" ; + (* A third distinct caller trips the cap and evicts agent-2. *) + call ~__context ~user_agent:"agent-3" ~client_ip:"10.0.0.3" ; + check_user_agents ~__context "agent-2 (least recently called) evicted" + ["agent-1"; "agent-3"] + ) + +(* Manually created callers are not auto-registered: they neither count towards + the cap nor get evicted by it. *) +let test_manual_callers_not_evicted () = + with_setup ~limit:2 (fun ~__context -> + let (_ : API.ref_Caller) = + Xapi_caller.create ~__context ~name_label:"manual" + ~name_description:"manually created" ~user_agent:"manual-agent" + ~client_ip:"192.168.0.1" + in + call ~__context ~user_agent:"agent-1" ~client_ip:"10.0.0.1" ; + call ~__context ~user_agent:"agent-2" ~client_ip:"10.0.0.2" ; + (* Trips the cap: an auto caller is evicted, the manual one is not. *) + call ~__context ~user_agent:"agent-3" ~client_ip:"10.0.0.3" ; + let agents = user_agents ~__context in + Alcotest.(check bool) + "manual caller survives eviction" true + (List.mem "manual-agent" agents) ; + Alcotest.(check int) + "cap counts only auto-registered callers" 3 (List.length agents) + ) + +(* A limit of 0 disables auto-registration: no callers are auto-created. *) +let test_zero_limit_disables_autoregistration () = + with_setup ~limit:0 (fun ~__context -> + call ~__context ~user_agent:"agent-1" ~client_ip:"10.0.0.1" ; + call ~__context ~user_agent:"agent-2" ~client_ip:"10.0.0.2" ; + check_user_agents ~__context "no callers auto-registered when limit is 0" + [] + ) + +(* A negative limit means unbounded - every distinct caller is registered and + none are evicted. *) +let test_negative_limit_is_unbounded () = + with_setup ~limit:(-1) (fun ~__context -> + call ~__context ~user_agent:"agent-1" ~client_ip:"10.0.0.1" ; + call ~__context ~user_agent:"agent-2" ~client_ip:"10.0.0.2" ; + call ~__context ~user_agent:"agent-3" ~client_ip:"10.0.0.3" ; + check_user_agents ~__context "no eviction when limit is negative" + ["agent-1"; "agent-2"; "agent-3"] + ) + +(* The RRD reporter aggregates per-caller usage into per-group totals. A caller + in several groups contributes to each; a caller in no group contributes to + none. *) +let test_group_totals_aggregate_callers () = + with_setup ~limit:100 (fun ~__context -> + let mk user_agent client_ip = + Xapi_caller.create ~__context ~name_label:user_agent + ~name_description:"" ~user_agent ~client_ip + in + let c1 = mk "a1" "10.0.0.1" in + let c2 = mk "a2" "10.0.0.2" in + let _ungrouped = mk "a3" "10.0.0.3" in + (* Accumulate stats: one call for a1, two for a2, one for the ungrouped + caller a3 (which should not show up in any group total). *) + call ~__context ~user_agent:"a1" ~client_ip:"10.0.0.1" ; + call ~__context ~user_agent:"a2" ~client_ip:"10.0.0.2" ; + call ~__context ~user_agent:"a2" ~client_ip:"10.0.0.2" ; + call ~__context ~user_agent:"a3" ~client_ip:"10.0.0.3" ; + Xapi_caller.add_group ~__context ~self:c1 ~group:"g1" ; + Xapi_caller.add_group ~__context ~self:c2 ~group:"g1" ; + Xapi_caller.add_group ~__context ~self:c2 ~group:"g2" ; + let summary = + Xapi_caller.group_totals () + |> List.map (fun (g, tokens, calls) -> + Printf.sprintf "%s:%.0f:%d" g tokens calls + ) + |> List.sort String.compare + in + (* g1 = a1 (1) + a2 (2); g2 = a2 (2); a3 is in no group. *) + Alcotest.(check (list string)) + "per-group token/call totals" ["g1:3:3"; "g2:2:2"] summary + ) + +let test = + [ + ( "test_evicts_least_recently_called" + , `Quick + , test_evicts_least_recently_called + ) + ; ( "test_group_totals_aggregate_callers" + , `Quick + , test_group_totals_aggregate_callers + ) + ; ("test_manual_callers_not_evicted", `Quick, test_manual_callers_not_evicted) + ; ( "test_zero_limit_disables_autoregistration" + , `Quick + , test_zero_limit_disables_autoregistration + ) + ; ( "test_negative_limit_is_unbounded" + , `Quick + , test_negative_limit_is_unbounded + ) + ] diff --git a/ocaml/tests/test_datamodel_lifecycle.ml b/ocaml/tests/test_datamodel_lifecycle.ml index ea008d17180..676daa7ee0a 100644 --- a/ocaml/tests/test_datamodel_lifecycle.ml +++ b/ocaml/tests/test_datamodel_lifecycle.ml @@ -49,6 +49,15 @@ module SuccessfulLifecycleCreation = Generic.MakeStateless (struct ] , Removed_s ) + ; (* A removed element can be reintroduced by publishing it again *) + ( [ + (Published, "release1", "") + ; (Deprecated, "release2", "") + ; (Removed, "release3", "") + ; (Published, "release4", "") + ] + , Published_s + ) ] end) @@ -82,14 +91,6 @@ module FailingLifecycleCreation = Generic.MakeStateless (struct ( [(Removed, "release1", "")] , Invalid "Invalid transition Removed from Unreleased_s" ) - ; ( [ - (Published, "release1", "") - ; (Deprecated, "release2", "") - ; (Removed, "release3", "") - ; (Published, "release4", "") - ] - , Invalid "Invalid transition Published from Removed_s" - ) ] end) diff --git a/ocaml/tests/test_extauth_plugin_ADwinbind.ml b/ocaml/tests/test_extauth_plugin_ADwinbind.ml index 6b3e58e3b34..a844a1eadc7 100644 --- a/ocaml/tests/test_extauth_plugin_ADwinbind.ml +++ b/ocaml/tests/test_extauth_plugin_ADwinbind.ml @@ -18,12 +18,11 @@ module ExtractOuConfig = Generic.MakeStateless (struct module Io = struct type input_t = (string * string) list - type output_t = (string * string) list * string list + type output_t = string option * string list let string_of_input_t = Test_printers.(assoc_list string string) - let string_of_output_t = - Test_printers.(pair (assoc_list string string) (list string)) + let string_of_output_t = Test_printers.(pair (option string) (list string)) end let transform x = Extauth_plugin_ADwinbind.extract_ou_config ~config_params:x @@ -31,13 +30,13 @@ module ExtractOuConfig = Generic.MakeStateless (struct let tests = `QuickAndAutoDocumented [ - ([("auth-type", "AD"); ("service-name", "conappada.local")], ([], [])) + ([("auth-type", "AD"); ("service-name", "conappada.local")], (None, [])) ; ( [ ("auth-type", "AD") ; ("service-name", "conappada.local") ; ("ou", "TOU") ] - , ([("ou", "TOU")], ["createcomputer=TOU"]) + , (Some "TOU", ["createcomputer=TOU"]) ) ] end) @@ -91,6 +90,14 @@ module Errtag = Generic.MakeStateless (struct "E_INVALID_OU" | E_INVALID_ACCOUNT -> "E_INVALID_ACCOUNT" + | E_INVALID_TRUSTED_CERTS -> + "E_INVALID_TRUSTED_CERTS" + | E_NO_TRUSTED_CERTS -> + "E_NO_TRUSTED_CERTS" + | E_FAILED_SETUP_TLS_CONNECTION -> + "E_FAILED_SETUP_TLS_CONNECTION" + | E_NO_SUPPORT_ENCRYPT_TYPE -> + "E_NO_SUPPORT_ENCRYPT_TYPE" end let transform = Extauth_plugin_ADwinbind.tag_from_err_msg diff --git a/ocaml/tests/test_vdi_allowed_operations.ml b/ocaml/tests/test_vdi_allowed_operations.ml index 001774202cf..e9f4dff6904 100644 --- a/ocaml/tests/test_vdi_allowed_operations.ml +++ b/ocaml/tests/test_vdi_allowed_operations.ml @@ -621,6 +621,60 @@ let test_revert = ; ("Revert: Cannot revert live", `Quick, test_cannot_revert_live) ] +(* A VDI attached to a running VM (i.e. with an active RW VBD) can only be + resized via VDI.resize_online, and only when the SM backend advertises the + VDI_RESIZE_ONLINE capability. Offline VDI.resize remains disallowed while the + VDI is attached. *) +let test_online_resize = + let features_with_online_resize = + ("VDI_RESIZE_ONLINE", 1L) :: Test_common.default_sm_features + in + let with_attached_rw_vbd __context vdi_ref = + make_vbd ~__context ~vDI:vdi_ref ~currently_attached:true ~mode:`RW () + in + (* Offline resize of an attached VDI is still refused. *) + let test_offline_resize_blocked_when_attached () = + let __context = Mock.make_context_with_new_db "Mock context" in + run_assert_equal_with_vdi ~__context + ~vdi_fun:(with_attached_rw_vbd __context) + `resize + (Error (Api_errors.vdi_in_use, [])) + in + (* Online resize is refused unless the SM backend supports it. *) + let test_resize_online_blocked_without_feature () = + let __context = Mock.make_context_with_new_db "Mock context" in + run_assert_equal_with_vdi ~__context + ~vdi_fun:(with_attached_rw_vbd __context) + `resize_online + (Error (Api_errors.sr_operation_not_supported, [])) + in + (* Online resize of an attached VDI is allowed when the SM backend advertises + VDI_RESIZE_ONLINE. *) + let test_resize_online_allowed_with_feature () = + let __context = Mock.make_context_with_new_db "Mock context" in + run_assert_equal_with_vdi ~__context + ~sm_fun:(fun sm -> + Db.SM.set_features ~__context ~self:sm + ~value:features_with_online_resize + ) + ~vdi_fun:(with_attached_rw_vbd __context) + `resize_online (Ok ()) + in + [ + ( "test_offline_resize_blocked_when_attached" + , `Quick + , test_offline_resize_blocked_when_attached + ) + ; ( "test_resize_online_blocked_without_feature" + , `Quick + , test_resize_online_blocked_without_feature + ) + ; ( "test_resize_online_allowed_with_feature" + , `Quick + , test_resize_online_allowed_with_feature + ) + ] + let test = [ ("test_ca98944", `Quick, test_ca98944) @@ -635,3 +689,4 @@ let test = ; ("test_update_allowed_operations", `Quick, test_update_allowed_operations) ] @ test_revert + @ test_online_resize diff --git a/ocaml/tests/test_vif_helpers.ml b/ocaml/tests/test_vif_helpers.ml index 2e92a3d7f01..7262a669176 100644 --- a/ocaml/tests/test_vif_helpers.ml +++ b/ocaml/tests/test_vif_helpers.ml @@ -21,12 +21,12 @@ let create ~__context ~device ~network ~vM ?(mAC = "00:00:00:00:00:00") ?(locking_mode = `unlocked) ?(ipv4_allowed = []) ?(ipv6_allowed = []) ?(ipv4_configuration_mode = `None) ?(ipv4_addresses = []) ?(ipv4_gateway = "") ?(ipv6_configuration_mode = `None) - ?(ipv6_addresses = []) ?(ipv6_gateway = "") () = + ?(ipv6_addresses = []) ?(ipv6_gateway = "") ?(trunks = []) () = Xapi_vif_helpers.create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config ~qos_algorithm_type ~qos_algorithm_params ~currently_attached ~locking_mode ~ipv4_allowed ~ipv6_allowed ~ipv4_configuration_mode ~ipv4_addresses ~ipv4_gateway ~ipv6_configuration_mode ~ipv6_addresses - ~ipv6_gateway + ~ipv6_gateway ~trunks let test_create_ok () = let __context = T.make_test_database () in diff --git a/ocaml/tests/test_vif_trunks.ml b/ocaml/tests/test_vif_trunks.ml new file mode 100644 index 00000000000..bf2b1ea2635 --- /dev/null +++ b/ocaml/tests/test_vif_trunks.ml @@ -0,0 +1,203 @@ +(* + * Copyright (C) 2026 Vates + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module T = Test_common + +let test_trunks_parameter () = + let __context = T.make_test_database () in + let vM = T.make_vm ~__context () in + let network = T.make_network ~__context () in + let vif = T.make_vif ~__context ~device:"1" ~vM ~network ~trunks:[2201L] () in + Alcotest.(check (list int64)) + "test_trunks_parameter testing add_trunks" [3201L; 2201L] + ( Xapi_vif.add_trunks ~__context ~self:vif ~value:3201L ; + Db.VIF.get_trunks ~__context ~self:vif + ) ; + Alcotest.(check (list int64)) + "test_trunks_parameter testing remove_trunks" [2201L] + ( Xapi_vif.remove_trunks ~__context ~self:vif ~value:3201L ; + Db.VIF.get_trunks ~__context ~self:vif + ) ; + Alcotest.(check (list int64)) + "test_trunks_parameter testing set_trunks" [3201L] + ( Xapi_vif.set_trunks ~__context ~self:vif ~value:[3201L] ; + Db.VIF.get_trunks ~__context ~self:vif + ) ; + Alcotest.(check (list int64)) + "test_trunks_parameter testing set_trunks empty" [] + ( Xapi_vif.set_trunks ~__context ~self:vif ~value:[] ; + Db.VIF.get_trunks ~__context ~self:vif + ) ; + Alcotest.(check_raises) + "test_trunks_parameter testing invalid VLAN tag" + Api_errors.(Server_error (Api_errors.vlan_tag_invalid, ["9999"])) + (fun () -> Xapi_vif.add_trunks ~__context ~self:vif ~value:9999L) + +(** try to set trunks on VIF on incompatible network *) +let test_trunks_coherence_vif_set () = + let __context = T.make_test_database () in + (* create a VLAN *) + let host = T.make_host ~__context () in + let network = T.make_network ~__context () in + let tagged_PIF = T.make_pif ~__context ~network ~host () in + let tag = 3201L in + let vlan_network = T.make_network ~__context ~bridge:"xapi0" () in + let untagged_PIF = + T.make_pif ~__context ~network:vlan_network ~host ~vLAN:tag () + in + let _vlan = T.make_vlan ~__context ~tagged_PIF ~untagged_PIF ~tag () in + (* create VM + VIF using this network *) + let vM = T.make_vm ~__context () in + let vif = T.make_vif ~__context ~device:"1" ~vM ~network:vlan_network () in + Alcotest.(check_raises) + "test_trunks_coherence_vif_set testing (add_trunks)" + Api_errors.( + Server_error + ( Api_errors.network_incompatible_with_trunks + , [Ref.string_of vlan_network] + ) + ) + (fun () -> Xapi_vif.add_trunks ~__context ~self:vif ~value:2201L) ; + Alcotest.(check_raises) + "test_trunks_coherence_vif_set testing (set_trunks)" + Api_errors.( + Server_error + ( Api_errors.network_incompatible_with_trunks + , [Ref.string_of vlan_network] + ) + ) + (fun () -> Xapi_vif.set_trunks ~__context ~self:vif ~value:[2201L]) + +(** try to add VIF (with trunks) on incompatible network *) +let test_trunks_coherence_vif_add () = + let __context = T.make_test_database () in + (* create a VLAN *) + let host = T.make_host ~__context () in + let network = T.make_network ~__context () in + let tagged_PIF = T.make_pif ~__context ~network ~host () in + let tag = 3201L in + let vlan_network = T.make_network ~__context ~bridge:"xapi0" () in + let untagged_PIF = + T.make_pif ~__context ~network:vlan_network ~host ~vLAN:tag () + in + let _vlan = T.make_vlan ~__context ~tagged_PIF ~untagged_PIF ~tag () in + (* create VM + VIF using this network *) + let vM = T.make_vm ~__context () in + Alcotest.(check_raises) + "test_trunks_coherence_vif_add testing" + Api_errors.( + Server_error + ( Api_errors.network_incompatible_with_trunks + , [Ref.string_of vlan_network] + ) + ) + (fun () -> + let _ : API.ref_VIF = + Xapi_vif.create ~__context ~device:"1" ~network:vlan_network ~vM + ~mAC:"00:00:00:00:00:00" ~mTU:1500L ~other_config:[] + ~currently_attached:true ~qos_algorithm_type:"" + ~qos_algorithm_params:[] ~locking_mode:`unlocked ~ipv4_allowed:[] + ~ipv6_allowed:[] ~trunks:[2201L] + in + () + ) + +(** try to associate PIF (with VLAN) on Network with trunked-VIF *) +let test_trunks_coherence_pif_vlan () = + let __context = T.make_test_database () in + (* create VM + VIF on plain network *) + let network = T.make_network ~__context () in + let vM = T.make_vm ~__context () in + let _vif = + T.make_vif ~__context ~device:"1" ~vM ~network ~trunks:[3201L] () + in + (* prepare to create a VLAN *) + let host = T.make_host ~__context () in + let network2 = T.make_network ~__context () in + let tagged_PIF = T.make_pif ~__context ~network:network2 ~host () in + let tag = 2201L in + Alcotest.(check_raises) + "test_trunks_coherence_pif_vlan testing via T.make_pif" + Api_errors.( + Server_error + (Api_errors.network_incompatible_with_trunks, [Ref.string_of network]) + ) + (fun () -> + let untagged_PIF = T.make_pif ~__context ~network ~host ~vLAN:tag () in + let _vlan = T.make_vlan ~__context ~tagged_PIF ~untagged_PIF ~tag () in + () + ) +(* can't call Xapi_vlan.create in test: it is hanging while trying to contact networkd *) +(* ; + Alcotest.(check_raises) + "test_trunks_coherence_pif_vlan testing via Xapi_vlan.create" + Api_errors.( + Server_error + (Api_errors.network_incompatible_with_trunks, [Ref.string_of network]) + ) + (fun () -> + let _vlan = Xapi_vlan.create ~__context ~tagged_PIF ~tag ~network in + () + ) + *) + +let test_trunks_move () = + let __context = T.make_test_database () in + (* create VM + VIF using this network *) + let network1 = T.make_network ~__context () in + let vM = T.make_vm ~__context () in + let vif = T.make_vif ~__context ~network:network1 ~vM () in + let network2 = T.make_network ~__context () in + Alcotest.(check unit) + "test_trunks_move testing" () + (Xapi_vif.move ~__context ~self:vif ~network:network2) + +(** try to move a VIF (with trunks) to VLAN *) +let test_trunks_move_to_vlan () = + let __context = T.make_test_database () in + (* create VM + VIF (with trunks) *) + let network1 = T.make_network ~__context () in + let vM = T.make_vm ~__context () in + let vif = T.make_vif ~__context ~network:network1 ~vM ~trunks:[3201L] () in + (* create a VLAN *) + let host = T.make_host ~__context () in + let network2 = T.make_network ~__context () in + let tagged_PIF = T.make_pif ~__context ~network:network2 ~host () in + let tag = 3201L in + let vlan_network2 = T.make_network ~__context ~bridge:"xapi0" () in + let untagged_PIF = + T.make_pif ~__context ~network:vlan_network2 ~host ~vLAN:tag () + in + let _vlan = T.make_vlan ~__context ~tagged_PIF ~untagged_PIF ~tag () in + (* move the VIF to the vlan_network *) + Alcotest.(check_raises) + "test_trunks_move_to_vlan testing" + Api_errors.( + Server_error + ( Api_errors.network_incompatible_with_trunks + , [Ref.string_of vlan_network2] + ) + ) + (fun () -> Xapi_vif.move ~__context ~self:vif ~network:vlan_network2) + +let test = + [ + ("test_trunks_parameter", `Quick, test_trunks_parameter) + ; ("test_trunks_coherence_vif_set", `Quick, test_trunks_coherence_vif_set) + ; ("test_trunks_coherence_vif_add", `Quick, test_trunks_coherence_vif_add) + ; ("test_trunks_coherence_pif_vlan", `Quick, test_trunks_coherence_pif_vlan) + ; ("test_trunks_move", `Quick, test_trunks_move) + ; ("test_trunks_move_to_vlan", `Quick, test_trunks_move_to_vlan) + ] diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 10234aebc10..f5d360b744b 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -283,6 +283,17 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "pool-external-auth-set-ldaps" + , { + reqd= ["ldaps"] + ; optn= ["uuid"; "force"] + ; help= + "Sets or unsets ldaps for external authentication in all the hosts \ + in a pool" + ; implementation= No_fd Cli_operations.pool_external_auth_set_ldaps + ; flags= [] + } + ) ; ( "pool-initialize-wlb" , { reqd= @@ -1033,6 +1044,15 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [Hidden] } ) + ; ( "host-external-auth-set-ldaps" + , { + reqd= ["host-uuid"; "ldaps"] + ; optn= ["force"] + ; help= "Sets or unsets ldaps for external authentication in a host" + ; implementation= No_fd Cli_operations.host_external_auth_set_ldaps + ; flags= [Hidden] + } + ) ; ( "host-refresh-pack-info" , { reqd= ["host-uuid"] @@ -3913,6 +3933,85 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "caller-create" + , { + reqd= [] + ; optn= ["name-label"; "name-description"; "user-agent"; "client-ip"] + ; help= + "Create a caller record. Either user-agent or client-ip must be \ + non-empty." + ; implementation= No_fd Cli_operations.Caller.create + ; flags= [] + } + ) + ; ( "caller-destroy" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Destroy the given caller." + ; implementation= No_fd Cli_operations.Caller.destroy + ; flags= [] + } + ) + ; ( "caller-query-usage" + , { + reqd= [] + ; optn= ["uuid"; "group"] + ; help= + "Return cumulative token and call count statistics for a caller. \ + Specify exactly one of uuid= or group=. Counters are taken from the \ + in-memory table since XAPI startup." + ; implementation= No_fd Cli_operations.Caller.query_usage + ; flags= [] + } + ) + ; ( "caller-list-usage" + , { + reqd= [] + ; optn= [] + ; help= + "List every known caller (uuid, name-label, tokens, calls) ranked by \ + token use, highest first." + ; implementation= No_fd Cli_operations.Caller.list_usage + ; flags= [] + } + ) + ; ( "rate-limit-create" + , { + reqd= ["burst-size"; "fill-rate"] + ; optn= ["name-label"; "name-description"; "caller-uuids"] + ; help= "Create a rate limiter." + ; implementation= No_fd Cli_operations.Rate_limit.create + ; flags= [] + } + ) + ; ( "rate-limit-destroy" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Destroy the given rate limiter." + ; implementation= No_fd Cli_operations.Rate_limit.destroy + ; flags= [] + } + ) + ; ( "rate-limit-add-caller" + , { + reqd= ["uuid"; "caller-uuid"] + ; optn= [] + ; help= "Attach a caller to a rate limiter." + ; implementation= No_fd Cli_operations.Rate_limit.add_caller + ; flags= [] + } + ) + ; ( "rate-limit-remove-caller" + , { + reqd= ["uuid"; "caller-uuid"] + ; optn= [] + ; help= "Detach a caller from a rate limiter." + ; implementation= No_fd Cli_operations.Rate_limit.remove_caller + ; flags= [] + } + ) ] let cmdtable : (string, cmd_spec) Hashtbl.t = Hashtbl.create 50 diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 99e843f4d99..077479d539c 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -1410,6 +1410,25 @@ let gen_cmds rpc session_id = ["uuid"; "vendor-name"; "device-name"; "pci-id"] rpc session_id ) + ; Client.Caller.( + mk get_all_records_where get_by_uuid caller_record "caller" [] + [ + "uuid" + ; "name-label" + ; "name-description" + ; "user-agent" + ; "client-ip" + ; "last-access" + ; "groups" + ; "rate-limit" + ] + rpc session_id + ) + ; Client.Rate_limit.( + mk get_all_records_where get_by_uuid rate_limit_record "rate-limit" [] + ["uuid"; "name-label"; "callers"; "burst-size"; "fill-rate"] + rpc session_id + ) ] let message_create (_ : printer) rpc session_id params = @@ -2859,7 +2878,7 @@ let vif_create printer rpc session_id params = Client.VIF.create ~rpc ~session_id ~device ~network ~vM ~mAC ~mTU ~other_config:[] ~currently_attached:false ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~locking_mode:`network_default ~ipv4_allowed:[] - ~ipv6_allowed:[] + ~ipv6_allowed:[] ~trunks:[] in let uuid = Client.VIF.get_uuid ~rpc ~session_id ~self:vif in printer (Cli_printer.PList [uuid]) @@ -7023,6 +7042,12 @@ let pool_disable_external_auth _printer rpc session_id params = let config = read_map_params "config" params in Client.Pool.disable_external_auth ~rpc ~session_id ~pool ~config +let pool_external_auth_set_ldaps _printer rpc session_id params = + let pool = get_pool_with_default rpc session_id params "uuid" in + let ldaps = get_bool_param params "ldaps" in + let force = get_bool_param params ~default:false "force" in + Client.Pool.external_auth_set_ldaps ~rpc ~session_id ~pool ~ldaps ~force + let pool_get_guest_secureboot_readiness printer rpc session_id params = let pool = get_pool_with_default rpc session_id params "uuid" in let result = @@ -7201,6 +7226,13 @@ let host_disable_external_auth _printer rpc session_id params = let config = read_map_params "config" params in Client.Host.disable_external_auth ~rpc ~session_id ~host ~config ~force:true +let host_external_auth_set_ldaps _printer rpc session_id params = + let host_uuid = List.assoc "host-uuid" params in + let host = Client.Host.get_by_uuid ~rpc ~session_id ~uuid:host_uuid in + let ldaps = get_bool_param params "ldaps" in + let force = get_bool_param params ~default:false "force" in + Client.Host.external_auth_set_ldaps ~rpc ~session_id ~host ~ldaps ~force + let host_refresh_pack_info _printer rpc session_id params = let host_uuid = List.assoc "host-uuid" params in let host = Client.Host.get_by_uuid ~rpc ~session_id ~uuid:host_uuid in @@ -8385,3 +8417,145 @@ module VM_group = struct in Client.VM_group.destroy ~rpc ~session_id ~self:ref end + +module Caller = struct + let create printer rpc session_id params = + let user_agent = get_param params "user-agent" ~default:"" in + let client_ip = get_param params "client-ip" ~default:"" in + + if user_agent = "" && client_ip = "" then + failwith "Either user-agent or client-ip must be specified" ; + + let name_label = get_param params "name-label" ~default:"" in + let name_description = get_param params "name-description" ~default:"" in + let ref = + Client.Caller.create ~rpc ~session_id ~name_label ~name_description + ~user_agent ~client_ip + in + let uuid = Client.Caller.get_uuid ~rpc ~session_id ~self:ref in + printer (Cli_printer.PMsg uuid) + + let destroy _printer rpc session_id params = + let ref = + Client.Caller.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) + in + Client.Caller.destroy ~rpc ~session_id ~self:ref + + let query_usage printer rpc session_id params = + let uuid = List.assoc_opt "uuid" params in + let group = List.assoc_opt "group" params in + let result = + match (uuid, group) with + | Some _, Some _ -> + failwith "Specify exactly one of uuid= or group=, not both" + | None, None -> + failwith "Specify exactly one of uuid= or group=" + | Some uuid, None -> + let self = Client.Caller.get_by_uuid ~rpc ~session_id ~uuid in + let tokens = Client.Caller.query_token_usage ~rpc ~session_id ~self in + let call_count = + Client.Caller.query_call_count ~rpc ~session_id ~self + in + [ + ("tokens", Float.to_string tokens) + ; ("call_count", Int64.to_string call_count) + ] + | None, Some group -> + let tokens = + Client.Caller.query_group_token_usage ~rpc ~session_id ~group + in + let call_count = + Client.Caller.query_group_call_count ~rpc ~session_id ~group + in + [ + ("tokens", Float.to_string tokens) + ; ("call_count", Int64.to_string call_count) + ] + in + printer (Cli_printer.PTable [result]) + + let list_usage printer rpc session_id _params = + let rows = Client.Caller.query_all_usage ~rpc ~session_id in + let headers = ["uuid"; "name-label"; "tokens"; "calls"] in + let table = + List.map + (fun row -> + try List.combine headers row + with Invalid_argument _ -> + (* Defensive: server schema mismatch *) + List.mapi (fun i v -> (string_of_int i, v)) row + ) + rows + in + printer (Cli_printer.PTable table) +end + +module Rate_limit = struct + let create printer rpc session_id params = + let name_label = get_param params "name-label" ~default:"" in + let name_description = get_param params "name-description" ~default:"" in + let burst_size = float_of_string (List.assoc "burst-size" params) in + let fill_rate = float_of_string (List.assoc "fill-rate" params) in + let ref = + Client.Rate_limit.create ~rpc ~session_id ~name_label ~name_description + ~burst_size ~fill_rate + in + ( match List.assoc_opt "caller-uuids" params with + | None | Some "" -> + () + | Some uuids -> + String.split_on_char ',' uuids + |> List.map String.trim + |> List.iter (fun uuid -> + let caller = Client.Caller.get_by_uuid ~rpc ~session_id ~uuid in + Client.Rate_limit.add_caller ~rpc ~session_id ~self:ref ~caller + ) + ) ; + let uuid = Client.Rate_limit.get_uuid ~rpc ~session_id ~self:ref in + printer (Cli_printer.PMsg uuid) + + let destroy _printer rpc session_id params = + let ref = + Client.Rate_limit.get_by_uuid ~rpc ~session_id + ~uuid:(List.assoc "uuid" params) + in + Client.Rate_limit.destroy ~rpc ~session_id ~self:ref + + let add_caller _printer rpc session_id params = + let self = + Client.Rate_limit.get_by_uuid ~rpc ~session_id + ~uuid:(List.assoc "uuid" params) + in + let caller = + Client.Caller.get_by_uuid ~rpc ~session_id + ~uuid:(List.assoc "caller-uuid" params) + in + Client.Rate_limit.add_caller ~rpc ~session_id ~self ~caller + + let remove_caller _printer rpc session_id params = + let self = + Client.Rate_limit.get_by_uuid ~rpc ~session_id + ~uuid:(List.assoc "uuid" params) + in + let caller = + Client.Caller.get_by_uuid ~rpc ~session_id + ~uuid:(List.assoc "caller-uuid" params) + in + Client.Rate_limit.remove_caller ~rpc ~session_id ~self ~caller + + let set_burst_size _printer rpc session_id params = + let self = + Client.Rate_limit.get_by_uuid ~rpc ~session_id + ~uuid:(List.assoc "uuid" params) + in + let value = float_of_string (List.assoc "value" params) in + Client.Rate_limit.set_burst_size ~rpc ~session_id ~self ~value + + let set_fill_rate _printer rpc session_id params = + let self = + Client.Rate_limit.get_by_uuid ~rpc ~session_id + ~uuid:(List.assoc "uuid" params) + in + let value = float_of_string (List.assoc "value" params) in + Client.Rate_limit.set_fill_rate ~rpc ~session_id ~self ~value +end diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index dab007a9194..3436663d182 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -1014,6 +1014,23 @@ let vif_record rpc session_id vif = ; make_field ~name:"ipv6-gateway" ~get:(fun () -> (x ()).API.vIF_ipv6_gateway) () + ; make_field ~name:"trunks" + ~get:(fun () -> map_and_concat Int64.to_string (x ()).API.vIF_trunks) + ~get_set:(fun () -> List.map Int64.to_string (x ()).API.vIF_trunks) + ~add_to_set:(fun value -> + let value = safe_i64_of_string "value" value in + Client.VIF.add_trunks ~rpc ~session_id ~self:vif ~value + ) + ~remove_from_set:(fun value -> + let value = safe_i64_of_string "value" value in + Client.VIF.remove_trunks ~rpc ~session_id ~self:vif ~value + ) + ~set:(fun value -> + Client.VIF.set_trunks ~rpc ~session_id ~self:vif + ~value: + (List.map (safe_i64_of_string "value") (get_words ',' value)) + ) + () ] } @@ -1516,6 +1533,16 @@ let pool_record rpc session_id pool = ; make_field ~name:"update-sync-enabled" ~get:(fun () -> (x ()).API.pool_update_sync_enabled |> string_of_bool) () + ; make_field ~name:"auto-update-vm-secureboot-certificates" + ~get:(fun () -> + (x ()).API.pool_auto_update_vm_secureboot_certificates + |> string_of_bool + ) + ~set:(fun x -> + Client.Pool.set_auto_update_vm_secureboot_certificates ~rpc + ~session_id ~self:pool ~value:(bool_of_string x) + ) + () ; make_field ~name:"recommendations" ~get:(fun () -> get_from_map (x ()).API.pool_recommendations) ~get_map:(fun () -> (x ()).API.pool_recommendations) @@ -6048,3 +6075,126 @@ let pci_record rpc session_id pci = () ] } + +let caller_record rpc session_id caller = + let _ref = ref caller in + let empty_record = + ToGet (fun () -> Client.Caller.get_record ~rpc ~session_id ~self:!_ref) + in + let record = ref empty_record in + let x () = lzy_get record in + { + setref= + (fun r -> + _ref := r ; + record := empty_record + ) + ; setrefrec= + (fun (a, b) -> + _ref := a ; + record := Got b + ) + ; record= x + ; getref= (fun () -> !_ref) + ; fields= + [ + make_field ~name:"uuid" ~get:(fun () -> (x ()).API.caller_uuid) () + ; make_field ~name:"name-label" + ~get:(fun () -> (x ()).API.caller_name_label) + ~set:(fun s -> + Client.Caller.set_name_label ~rpc ~session_id ~self:!_ref ~value:s + ) + () + ; make_field ~name:"name-description" + ~get:(fun () -> (x ()).API.caller_name_description) + ~set:(fun s -> + Client.Caller.set_name_description ~rpc ~session_id ~self:!_ref + ~value:s + ) + () + ; make_field ~name:"user-agent" + ~get:(fun () -> (x ()).API.caller_user_agent) + () + ; make_field ~name:"client-ip" + ~get:(fun () -> (x ()).API.caller_client_ip) + () + ; make_field ~name:"last-access" + ~get:(fun () -> Date.to_rfc3339 (x ()).API.caller_last_access) + () + ; make_field ~name:"groups" + ~get:(fun () -> String.concat "; " (x ()).API.caller_groups) + ~get_set:(fun () -> (x ()).API.caller_groups) + ~add_to_set:(fun s -> + Client.Caller.add_group ~rpc ~session_id ~self:!_ref ~group:s + ) + ~remove_from_set:(fun s -> + Client.Caller.remove_group ~rpc ~session_id ~self:!_ref ~group:s + ) + () + ; make_field ~name:"rate-limit" + ~get:(fun () -> Ref.string_of (x ()).API.caller_rate_limit) + () + ] + } + +let rate_limit_record rpc session_id rate_limit = + let _ref = ref rate_limit in + let empty_record = + ToGet (fun () -> Client.Rate_limit.get_record ~rpc ~session_id ~self:!_ref) + in + let record = ref empty_record in + let x () = lzy_get record in + { + setref= + (fun r -> + _ref := r ; + record := empty_record + ) + ; setrefrec= + (fun (a, b) -> + _ref := a ; + record := Got b + ) + ; record= x + ; getref= (fun () -> !_ref) + ; fields= + [ + make_field ~name:"uuid" ~get:(fun () -> (x ()).API.rate_limit_uuid) () + ; make_field ~name:"name-label" + ~get:(fun () -> (x ()).API.rate_limit_name_label) + ~set:(fun value -> + Client.Rate_limit.set_name_label ~rpc ~session_id ~self:!_ref ~value + ) + () + ; make_field ~name:"name-description" + ~get:(fun () -> (x ()).API.rate_limit_name_description) + ~set:(fun value -> + Client.Rate_limit.set_name_description ~rpc ~session_id ~self:!_ref + ~value + ) + () + ; make_field ~name:"callers" + ~get:(fun () -> + String.concat "; " + (List.map Ref.string_of (x ()).API.rate_limit_callers) + ) + ~get_set:(fun () -> + List.map Ref.string_of (x ()).API.rate_limit_callers + ) + () + ; make_field ~name:"burst-size" + ~get:(fun () -> string_of_float (x ()).API.rate_limit_burst_size) + ~set:(fun value -> + Client.Rate_limit.set_burst_size ~rpc ~session_id ~self:!_ref + ~value:(float_of_string value) + ) + () + ; make_field ~name:"fill-rate" + ~get:(fun () -> string_of_float (x ()).API.rate_limit_fill_rate) + ~set:(fun value -> + Client.Rate_limit.set_fill_rate ~rpc ~session_id ~self:!_ref + ~value:(float_of_string value) + ) + () + ] + } diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index b0dd9a52321..7d5bdd23a29 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -214,6 +214,9 @@ let network_has_incompatible_sriov_pifs = let network_has_incompatible_vlan_on_sriov_pifs = add_error "NETWORK_HAS_INCOMPATIBLE_VLAN_ON_SRIOV_PIFS" +let network_incompatible_with_trunks = + add_error "NETWORK_INCOMPATIBLE_WITH_TRUNKS" + let operation_not_allowed = add_error "OPERATION_NOT_ALLOWED" let operation_blocked = add_error "OPERATION_BLOCKED" @@ -1007,6 +1010,9 @@ let cannot_evacuate_host = add_error "CANNOT_EVACUATE_HOST" let host_evacuate_in_progress = add_error "HOST_EVACUATE_IN_PROGRESS" +let host_evacuate_vm_not_ha_protected = + add_error "HOST_EVACUATE_VM_NOT_HA_PROTECTED" + let system_status_retrieval_failed = add_error "SYSTEM_STATUS_RETRIEVAL_FAILED" let system_status_must_use_tar_on_oem = @@ -1032,6 +1038,10 @@ let auth_unknown_type = add_error "AUTH_UNKNOWN_TYPE" let auth_is_disabled = add_error "AUTH_IS_DISABLED" +let auth_invalid_trusted_certs = add_error "AUTH_INVALID_TRUSTED_CERTS" + +let auth_no_trusted_certs = add_error "AUTH_NO_TRUSTED_CERTS" + let auth_suffix_wrong_credentials = "_WRONG_CREDENTIALS" let auth_suffix_permission_denied = "_PERMISSION_DENIED" @@ -1044,6 +1054,16 @@ let auth_suffix_invalid_ou = "_INVALID_OU" let auth_suffix_invalid_account = "_INVALID_ACCOUNT" +let auth_suffix_invalid_trusted_certs = "_INVALID_TRUSTED_CERTS" + +let auth_suffix_no_trusted_certs = "_NO_TRUSTED_CERTS" + +let auth_suffix_setup_tls_connection = "_SETUP_TLS_CONNECTION" + +let auth_suffix_no_support_encrypt_type = "_NO_SUPPORT_ENCRYPT_TYPE" + +let auth_setup_tls_connection = add_error "AUTH_SETUP_TLS_CONNECTION" + let auth_enable_failed = add_error "AUTH_ENABLE_FAILED" let auth_enable_failed_wrong_credentials = @@ -1064,6 +1084,15 @@ let auth_enable_failed_invalid_ou = let auth_enable_failed_invalid_account = add_error $ auth_enable_failed ^ auth_suffix_invalid_account +let auth_enable_failed_invalid_trusted_certs = + add_error $ auth_enable_failed ^ auth_suffix_invalid_trusted_certs + +let auth_enable_failed_no_trusted_certs = + add_error $ auth_enable_failed ^ auth_suffix_no_trusted_certs + +let auth_enable_failed_no_supp_encrypt_type = + add_error $ auth_enable_failed ^ auth_suffix_no_support_encrypt_type + let auth_disable_failed = add_error "AUTH_DISABLE_FAILED" let auth_disable_failed_wrong_credentials = @@ -1096,9 +1125,23 @@ let pool_auth_enable_failed_invalid_ou = let pool_auth_enable_failed_invalid_account = add_error $ pool_auth_enable_failed ^ auth_suffix_invalid_account +let pool_auth_enable_failed_invalid_trusted_certs = + add_error $ pool_auth_enable_failed ^ auth_suffix_invalid_trusted_certs + +let pool_auth_enable_failed_no_trusted_certs = + add_error $ pool_auth_enable_failed ^ auth_suffix_no_trusted_certs + +let pool_auth_enable_failed_no_supp_encrypt_type = + add_error $ pool_auth_enable_failed ^ auth_suffix_no_support_encrypt_type + +let pool_auth_enable_failed_setup_tls_connection = + add_error $ pool_auth_enable_failed ^ auth_suffix_setup_tls_connection + let pool_auth_enable_failed_duplicate_hostname = add_error $ pool_auth_enable_failed ^ "_DUPLICATE_HOSTNAME" +let auth_set_ldaps_failed = add_error "AUTH_SET_LDAPS_FAILED" + let pool_auth_disable_failed = add_error $ pool_auth_prefix ^ auth_disable_failed diff --git a/ocaml/xapi-consts/constants.ml b/ocaml/xapi-consts/constants.ml index af8c5356bfc..fb623fbe1e9 100644 --- a/ocaml/xapi-consts/constants.ml +++ b/ocaml/xapi-consts/constants.ml @@ -429,10 +429,6 @@ let gencert = ref "/opt/xensource/libexec/gencert" let openssl_path = ref "/usr/bin/openssl" -let good_ciphersuites = - String.concat ":" - ["ECDHE-RSA-AES256-GCM-SHA384"; "ECDHE-RSA-AES128-GCM-SHA256"] - let verify_certificates_path = "/var/xapi/verify-certificates" let python3_path = "/usr/bin/python3" diff --git a/ocaml/xapi-idl/storage/storage_interface.ml b/ocaml/xapi-idl/storage/storage_interface.ml index 0d9b72566d5..d409d99854c 100644 --- a/ocaml/xapi-idl/storage/storage_interface.ml +++ b/ocaml/xapi-idl/storage/storage_interface.ml @@ -231,6 +231,7 @@ type vdi_info = { persistent: bool [@default true] ; sharable: bool [@default false] ; sm_config: (string * string) list [@default []] + ; tags: string list [@default []] } [@@deriving rpcty] @@ -1018,6 +1019,16 @@ module StorageAPI (R : RPC) = struct declare "VDI.remove_from_sm_config" [] (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> returning unit_p err) + (** [add_tags] task sr vdi key value] adds [key] to [vdi] tags *) + let add_tags = + declare "VDI.add_tags" [] + (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> returning unit_p err) + + (** [remove_tags dbg sr vdi key] removes [key] from [vdi] tags *) + let remove_tags = + declare "VDI.remove_tags" [] + (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> returning unit_p err) + (** [enable_cbt dbg sr vdi] enables changed block tracking for [vdi] *) let enable_cbt = declare "VDI.enable_cbt" [] @@ -1193,7 +1204,6 @@ module StorageAPI (R : RPC) = struct @-> sr_p @-> VDI.vdi_info_p @-> id_p - @-> image_format_p @-> similar_p @-> returning result err ) @@ -1211,7 +1221,6 @@ module StorageAPI (R : RPC) = struct @-> sr_p @-> VDI.vdi_info_p @-> id_p - @-> image_format_p @-> similar_p @-> vm_p @-> returning result err @@ -1375,7 +1384,6 @@ module type MIRROR = sig -> sr:sr -> vdi_info:vdi_info -> id:Mirror.id - -> image_format:string -> similar:Mirror.similars -> Mirror.mirror_receive_result @@ -1385,7 +1393,6 @@ module type MIRROR = sig -> sr:sr -> vdi_info:vdi_info -> id:Mirror.id - -> image_format:string -> similar:Mirror.similars -> vm:vm -> Mirror.mirror_receive_result @@ -1679,6 +1686,12 @@ module type Server_impl = sig val remove_from_sm_config : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> key:string -> unit + val add_tags : + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> key:string -> unit + + val remove_tags : + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> key:string -> unit + val enable_cbt : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit val disable_cbt : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit @@ -1892,6 +1905,12 @@ module Server (Impl : Server_impl) () = struct S.VDI.remove_from_sm_config (fun dbg sr vdi key -> Impl.VDI.remove_from_sm_config () ~dbg ~sr ~vdi ~key ) ; + S.VDI.add_tags (fun dbg sr vdi key -> + Impl.VDI.add_tags () ~dbg ~sr ~vdi ~key + ) ; + S.VDI.remove_tags (fun dbg sr vdi key -> + Impl.VDI.remove_tags () ~dbg ~sr ~vdi ~key + ) ; S.VDI.enable_cbt (fun dbg sr vdi -> Impl.VDI.enable_cbt () ~dbg ~sr ~vdi) ; S.VDI.disable_cbt (fun dbg sr vdi -> Impl.VDI.disable_cbt () ~dbg ~sr ~vdi) ; S.VDI.data_destroy (fun dbg sr vdi -> Impl.VDI.data_destroy () ~dbg ~sr ~vdi) ; @@ -1933,14 +1952,11 @@ module Server (Impl : Server_impl) () = struct ~mirror_vm ~mirror_id ~local_vdi ~copy_vm ~live_vm ~url ~remote_mirror ~dest_sr ~verify_dest ) ; - S.DATA.MIRROR.receive_start (fun dbg sr vdi_info id image_format similar -> - Impl.DATA.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~image_format - ~similar + S.DATA.MIRROR.receive_start (fun dbg sr vdi_info id similar -> + Impl.DATA.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~similar ) ; - S.DATA.MIRROR.receive_start2 - (fun dbg sr vdi_info id image_format similar vm -> - Impl.DATA.MIRROR.receive_start2 () ~dbg ~sr ~vdi_info ~id ~image_format - ~similar ~vm + S.DATA.MIRROR.receive_start2 (fun dbg sr vdi_info id similar vm -> + Impl.DATA.MIRROR.receive_start2 () ~dbg ~sr ~vdi_info ~id ~similar ~vm ) ; S.DATA.MIRROR.receive_start3 (fun dbg sr vdi_info mirror_id image_format similar vm url verify_dest -> diff --git a/ocaml/xapi-idl/storage/storage_skeleton.ml b/ocaml/xapi-idl/storage/storage_skeleton.ml index 2c5db9f20ce..9ee5180fe8d 100644 --- a/ocaml/xapi-idl/storage/storage_skeleton.ml +++ b/ocaml/xapi-idl/storage/storage_skeleton.ml @@ -168,6 +168,12 @@ module VDI = struct let remove_from_sm_config ctx ~dbg ~sr ~vdi ~key = Storage_interface.unimplemented __FUNCTION__ + let add_tags ctx ~dbg ~sr ~vdi ~key = + Storage_interface.unimplemented __FUNCTION__ + + let remove_tags ctx ~dbg ~sr ~vdi ~key = + Storage_interface.unimplemented __FUNCTION__ + let enable_cbt ctx ~dbg ~sr ~vdi = Storage_interface.unimplemented __FUNCTION__ @@ -210,10 +216,10 @@ module DATA = struct ~verify_dest = Storage_interface.unimplemented __FUNCTION__ - let receive_start ctx ~dbg ~sr ~vdi_info ~id ~image_format ~similar = + let receive_start ctx ~dbg ~sr ~vdi_info ~id ~similar = Storage_interface.unimplemented __FUNCTION__ - let receive_start2 ctx ~dbg ~sr ~vdi_info ~id ~image_format ~similar ~vm = + let receive_start2 ctx ~dbg ~sr ~vdi_info ~id ~similar ~vm = Storage_interface.unimplemented __FUNCTION__ let receive_start3 ctx ~dbg ~sr ~vdi_info ~mirror_id ~image_format ~similar diff --git a/ocaml/xapi-idl/xen/xenops_interface.ml b/ocaml/xapi-idl/xen/xenops_interface.ml index 2e93d2c2afe..64c05742867 100644 --- a/ocaml/xapi-idl/xen/xenops_interface.ml +++ b/ocaml/xapi-idl/xen/xenops_interface.ml @@ -363,6 +363,8 @@ module Vif = struct type t = site * server list * interface [@@deriving rpcty] end + type trunks = int64 list [@@deriving rpcty] + type t = { id: id [@default "", ""] ; position: int [@default 0] @@ -380,6 +382,7 @@ module Vif = struct [@default default_ipv6_configuration] ; pvs_proxy: PVS_proxy.t option [@default None] ; vlan: int64 option [@default None] + ; trunks: trunks [@default []] } [@@deriving rpcty] @@ -1078,6 +1081,11 @@ module XenopsAPI (R : RPC) = struct let proxy_p = Param.mk ~name:"proxy" (option Vif.PVS_proxy.t) in declare "VIF.set_pvs_proxy" [] (debug_info_p @-> vif_id_p @-> proxy_p @-> returning task_id_p err) + + let set_trunks = + let trunks_p = Param.mk ~name:"trunks" Vif.trunks in + declare "VIF.set_trunks" [] + (debug_info_p @-> vif_id_p @-> trunks_p @-> returning task_id_p err) end module VGPU = struct diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 4e87ffcf113..406b6d929f4 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -367,6 +367,8 @@ let _is_a_snapshot_key = "is_a_snapshot" let _snapshot_of_key = "snapshot_of" +let _vdi_tags_key = "tags" + module Script = struct (** We cache (lowercase script name -> original script name) mapping for the scripts in the root directory of every registered plugin. *) @@ -740,6 +742,19 @@ let vdi_of_volume x = v |> of_string in let find_string = find ~of_string:Fun.id in + let extract_prefixed_list prefix = + List.filter_map + (fun (k, _) -> + if String.starts_with ~prefix k then + Some + (String.sub k (String.length prefix) + (String.length k - String.length prefix) + ) + else + None + ) + x.Xapi_storage.Control.keys + in let open Storage_interface in { vdi= Vdi.of_string x.Xapi_storage.Control.key @@ -777,6 +792,7 @@ let vdi_of_volume x = x.Xapi_storage.Control.keys ; sharable= x.Xapi_storage.Control.sharable ; persistent= true + ; tags= extract_prefixed_list _vdi_tags_key } let choose_datapath ?(persistent = true) response = @@ -1477,6 +1493,14 @@ module VDIImpl (M : META) = struct set ~dbg ~sr ~vdi:response.Xapi_storage.Control.key ~key:_vdi_type_key ~value:vdi_info.ty >>>= fun () -> + let rec f = function + | key :: x -> + let* _ = set ~dbg ~sr ~vdi ~key:(_vdi_tags_key ^ key) ~value:key in + f x + | [] -> + return () + in + f vdi_info.tags >>>= fun () -> let response = { (vdi_of_volume response) with @@ -1790,6 +1814,22 @@ module VDIImpl (M : META) = struct let* () = unset ~dbg ~sr ~vdi ~key:(_sm_config_prefix_key ^ key) in return () + let vdi_add_tags_impl dbg sr vdi key = + wrap + @@ + let* sr = Attached_SRs.find sr in + let vdi = Storage_interface.Vdi.string_of vdi in + let* () = set ~dbg ~sr ~vdi ~key:(_vdi_tags_key ^ key) ~value:key in + return () + + let vdi_remove_tags_impl dbg sr vdi key = + wrap + @@ + let* sr = Attached_SRs.find sr in + let vdi = Storage_interface.Vdi.string_of vdi in + let* () = unset ~dbg ~sr ~vdi ~key:(_vdi_tags_key ^ key) in + return () + let similar_content_impl _dbg _sr _vdi = wrap @@ return [] end @@ -2009,6 +2049,8 @@ let bind ~volume_script_dir = S.VDI.set_snapshot_metadata VDI.vdi_set_snapshot_metadata_impl ; S.VDI.add_to_sm_config VDI.vdi_add_to_sm_config_impl ; S.VDI.remove_from_sm_config VDI.vdi_remove_from_sm_config_impl ; + S.VDI.add_tags VDI.vdi_add_tags_impl ; + S.VDI.remove_tags VDI.vdi_remove_tags_impl ; S.VDI.similar_content VDI.similar_content_impl ; S.VDI.revert VDI.revert_impl ; @@ -2217,6 +2259,7 @@ let self_test_plugin ~root_dir plugin = ; persistent= false ; sm_config= [] ; sharable= false + ; tags= [] } in Test.VDI.create rpc dbg sr vdi_info >>= fun vdi_info -> diff --git a/ocaml/xapi-storage-script/python-self-test.t b/ocaml/xapi-storage-script/python-self-test.t index 7be4876c6a7..4741e4f5821 100644 --- a/ocaml/xapi-storage-script/python-self-test.t +++ b/ocaml/xapi-storage-script/python-self-test.t @@ -21,16 +21,16 @@ pids and uuids [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/SR.stat[PID] succeeded: {"sr": "file:///tmp/dummy", "name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "total_space": 0, "free_space": 0, "datasources": [], "clustered": false, "health": ["Healthy", ""]} [INFO] {"method":"Volume.create","params":[{"sharable":false,"size":0,"description":"vdi description","name":"vdi name","sr":"file:///tmp/dummy","dbg":"debug"}],"id":12} - [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Volume.create[PID] succeeded: {"name": "vdi name", "description": "vdi description", "key": "UUID", "uuid": "UUID", "read_write": true, "sharable": false, "virtual_size": 0, "physical_utilisation": 0, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}} + [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Volume.create[PID] succeeded: {"name": "vdi name", "description": "vdi description", "key": "UUID", "uuid": "UUID", "read_write": true, "sharable": false, "virtual_size": 0, "physical_utilisation": 0, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}, "tags": ["tag1"]} [INFO] {"method":"Volume.set","params":[{"v":"redolog","k":"vdi-type","key":"UUID","sr":"file:///tmp/dummy","dbg":"debug"}],"id":13} [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Volume.set[PID] succeeded: null [INFO] {"method":"Volume.stat","params":[{"key":"UUID","sr":"file:///tmp/dummy","dbg":"debug"}],"id":15} - [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Volume.stat[PID] succeeded: {"name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "key": "UUID", "uuid": "UUID", "read_write": true, "virtual_size": 0, "physical_utilisation": 0, "sharable": false, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}} + [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Volume.stat[PID] succeeded: {"name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "key": "UUID", "uuid": "UUID", "read_write": true, "virtual_size": 0, "physical_utilisation": 0, "sharable": false, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}, "tags": ["tag1"]} [INFO] {"method":"Volume.stat","params":[{"key":"UUID","sr":"file:///tmp/dummy","dbg":"debug"}],"id":17} - [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Volume.stat[PID] succeeded: {"name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "key": "UUID", "uuid": "UUID", "read_write": true, "virtual_size": 0, "physical_utilisation": 0, "sharable": false, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}} + [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Volume.stat[PID] succeeded: {"name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "key": "UUID", "uuid": "UUID", "read_write": true, "virtual_size": 0, "physical_utilisation": 0, "sharable": false, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}, "tags": ["tag1"]} [INFO] {"method":"Volume.destroy","params":[{"key":"UUID","sr":"file:///tmp/dummy","dbg":"debug"}],"id":18} [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Volume.destroy[PID] succeeded: null @@ -39,7 +39,7 @@ pids and uuids [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/SR.stat[PID] succeeded: {"sr": "file:///tmp/dummy", "name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "total_space": 0, "free_space": 0, "datasources": [], "clustered": false, "health": ["Healthy", ""]} [INFO] {"method":"SR.ls","params":[{"sr":"file:///tmp/dummy","dbg":"debug"}],"id":22} - [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/SR.ls[PID] succeeded: [{"name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "key": "file1", "uuid": "file1", "read_write": true, "virtual_size": 0, "physical_utilisation": 0, "sharable": false, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}}] + [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/SR.ls[PID] succeeded: [{"name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "key": "file1", "uuid": "file1", "read_write": true, "virtual_size": 0, "physical_utilisation": 0, "sharable": false, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}, "tags": ["tag1"]}] [INFO] {"method":"SR.probe","params":[{"configuration":{"uri":"file:///tmp/dummy"},"dbg":"debug"}],"id":24} [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/SR.probe[PID] succeeded: [{"configuration": {"uri": "file:///tmp/dummy"}, "complete": true, "extra_info": {}}, {"configuration": {"uri": "file:///tmp/dummy", "sr_uuid": "myuuid"}, "sr": {"sr": "file:///tmp/dummy", "name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "total_space": 0, "free_space": 0, "datasources": [], "clustered": false, "health": ["Healthy", ""]}, "complete": true, "extra_info": {}}] diff --git a/ocaml/xapi-storage-script/test/volume/org.xen.xapi.storage.dummyv5/sr.py b/ocaml/xapi-storage-script/test/volume/org.xen.xapi.storage.dummyv5/sr.py index 3c649423d15..9667a788690 100755 --- a/ocaml/xapi-storage-script/test/volume/org.xen.xapi.storage.dummyv5/sr.py +++ b/ocaml/xapi-storage-script/test/volume/org.xen.xapi.storage.dummyv5/sr.py @@ -39,6 +39,7 @@ def ls(self, dbg, sr): "sharable": False, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}, + "tags": ["tag1"], }] def stat(self, dbg, sr): diff --git a/ocaml/xapi-storage-script/test/volume/org.xen.xapi.storage.dummyv5/volume.py b/ocaml/xapi-storage-script/test/volume/org.xen.xapi.storage.dummyv5/volume.py index fcf52ce3883..13f22794ad5 100755 --- a/ocaml/xapi-storage-script/test/volume/org.xen.xapi.storage.dummyv5/volume.py +++ b/ocaml/xapi-storage-script/test/volume/org.xen.xapi.storage.dummyv5/volume.py @@ -30,6 +30,7 @@ def create(self, dbg, sr, name, description, size, sharable): "physical_utilisation": 0, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}, + "tags": ["tag1"], } def destroy(self, dbg, sr, key): @@ -50,6 +51,7 @@ def stat(self, dbg, sr, key): "sharable": False, "uri": ["raw+file:///tmp/disk.raw"], "keys": {}, + "tags": ["tag1"], } def set(self, dbg, sr, key, k, v): diff --git a/ocaml/xapi-storage/rpc-light/SR.ls/response b/ocaml/xapi-storage/rpc-light/SR.ls/response index 7f989e33066..b3ca5475f65 100644 --- a/ocaml/xapi-storage/rpc-light/SR.ls/response +++ b/ocaml/xapi-storage/rpc-light/SR.ls/response @@ -14,6 +14,7 @@ keys volume_typeData cbt_enabledfalse + tagstag1 diff --git a/ocaml/xapi-storage/rpc-light/Volume.clone/response b/ocaml/xapi-storage/rpc-light/Volume.clone/response index dc4036f599d..f6b23b83f93 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.clone/response +++ b/ocaml/xapi-storage/rpc-light/Volume.clone/response @@ -13,6 +13,7 @@ keys volume_typeData cbt_enabledfalse + tagstag1 diff --git a/ocaml/xapi-storage/rpc-light/Volume.create/response b/ocaml/xapi-storage/rpc-light/Volume.create/response index dc4036f599d..f6b23b83f93 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.create/response +++ b/ocaml/xapi-storage/rpc-light/Volume.create/response @@ -13,6 +13,7 @@ keys volume_typeData cbt_enabledfalse + tagstag1 diff --git a/ocaml/xapi-storage/rpc-light/Volume.snapshot/response b/ocaml/xapi-storage/rpc-light/Volume.snapshot/response index dc4036f599d..f6b23b83f93 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.snapshot/response +++ b/ocaml/xapi-storage/rpc-light/Volume.snapshot/response @@ -13,6 +13,7 @@ keys volume_typeData cbt_enabledfalse + tagstag1 diff --git a/ocaml/xapi/api_server_common.ml b/ocaml/xapi/api_server_common.ml index ef3e1f4bbc3..ad8887101a7 100644 --- a/ocaml/xapi/api_server_common.ml +++ b/ocaml/xapi/api_server_common.ml @@ -132,6 +132,8 @@ module Actions = struct module Observer = Xapi_observer module Host_driver = Xapi_host_driver module Driver_variant = Xapi_host_driver.Variant + module Caller = Xapi_caller + module Rate_limit = Xapi_rate_limit end (** Use the server functor to make an XML-RPC dispatcher. *) diff --git a/ocaml/xapi/auth_signature.ml b/ocaml/xapi/auth_signature.ml index 037be44827d..00d57f670c3 100644 --- a/ocaml/xapi/auth_signature.ml +++ b/ocaml/xapi/auth_signature.ml @@ -31,6 +31,10 @@ type auth_service_error_tag = | E_UNAVAILABLE | E_INVALID_OU | E_INVALID_ACCOUNT + | E_INVALID_TRUSTED_CERTS + | E_NO_TRUSTED_CERTS + | E_FAILED_SETUP_TLS_CONNECTION + | E_NO_SUPPORT_ENCRYPT_TYPE exception Auth_service_error of auth_service_error_tag * string @@ -52,6 +56,14 @@ let suffix_of_tag errtag = Api_errors.auth_suffix_invalid_ou | E_INVALID_ACCOUNT -> Api_errors.auth_suffix_invalid_account + | E_INVALID_TRUSTED_CERTS -> + Api_errors.auth_suffix_invalid_trusted_certs + | E_NO_TRUSTED_CERTS -> + Api_errors.auth_suffix_no_trusted_certs + | E_FAILED_SETUP_TLS_CONNECTION -> + Api_errors.auth_suffix_setup_tls_connection + | E_NO_SUPPORT_ENCRYPT_TYPE -> + Api_errors.auth_suffix_no_support_encrypt_type (* required fields in subject.other_config *) let subject_information_field_subject_name = "subject-name" @@ -140,6 +152,15 @@ type t = { Called internally when xapi is doing a clean exit. *) on_xapi_exit: __context:Context.t -> unit -> unit + ; (* unit set_ldaps(__context, bool ldaps, bool force) + + Called to enable or disable LDAPS for external authentication. Takes the context, + whether to enable/disable LDAPS, and whether to force the operation. + Gets the localhost from context, reads the current config from the database, + performs the update, and writes it back. + Raises Auth_service_error if the operation fails. + *) + set_ldaps: __context:Context.t -> ldaps:bool -> force:bool -> unit } (* Auth modules must implement this signature:*) diff --git a/ocaml/xapi/authx.ml b/ocaml/xapi/authx.ml index d6449fe1087..e0349e9d81e 100644 --- a/ocaml/xapi/authx.ml +++ b/ocaml/xapi/authx.ml @@ -360,6 +360,10 @@ module AuthX : Auth_signature.AUTH_MODULE = struct (* nothing to do here in this unix plugin *) () + let set_ldaps ~__context:_ ~ldaps:_ ~force:_ = + (* ldaps not applicable for PAM auth *) + () + (* Implement the single value required for the module signature *) let methods = Auth_signature. @@ -373,5 +377,6 @@ module AuthX : Auth_signature.AUTH_MODULE = struct ; on_disable ; on_xapi_initialize ; on_xapi_exit + ; set_ldaps } end diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 2adf2774f6e..293e1d381d0 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -336,22 +336,23 @@ end = struct end) let add_cert ~__context ~type' ~purpose certificate = - let name, host, _type, post_action = + let name, host, _type, post_action, is_trusted = match type' with | `host host -> - ("", host, `host, Fun.id) + ("", host, `host, Fun.id, false) | `host_internal host -> - ("", host, `host_internal, Fun.id) + ("", host, `host_internal, Fun.id, false) | `ca name when name <> "" -> + (* Legacy CA *) let certs = get_ca_certs ~__context name in let remove_obsoleted_copies () = List.iter (remove_cert_by_ref ~__context) certs in - (name, Ref.null, `ca, remove_obsoleted_copies) + (name, Ref.null, `ca, remove_obsoleted_copies, false) | `ca _name -> - ("", Ref.null, `ca, Fun.id) + ("", Ref.null, `ca, Fun.id, true) | `pinned -> - ("", Ref.null, `pinned, Fun.id) + ("", Ref.null, `pinned, Fun.id, true) in let date_of_ptime time = Date.of_unix_time (Ptime.to_float_s time) in let dates_of_ptimes (a, b) = (date_of_ptime a, date_of_ptime b) in @@ -360,26 +361,28 @@ end = struct in let fingerprint_sha256 = pp_fingerprint ~hash_type:`SHA256 certificate in let fingerprint_sha1 = pp_fingerprint ~hash_type:`SHA1 certificate in - let expr = - let open Xapi_database.Db_filter_types in - let type' = Record_util.certificate_type_to_string _type in - let type' = Eq (Field "type", Literal type') in - let fingerprint_sha256 = - Eq (Field "fingerprint_sha256", Literal fingerprint_sha256) - in - And (type', fingerprint_sha256) - in - Db.Certificate.get_records_where ~__context ~expr - |> List.filter (fun (_, cert_rec) -> cert_rec.API.certificate_name = "") - |> List.filter (fun (_, cert_rec) -> - let open PurposeSet in - let s1 = of_list purpose in - let s2 = of_list cert_rec.API.certificate_purpose in - equal s1 s2 || not (is_empty (inter s1 s2)) - ) - |> List.iter (fun _ -> - raise_server_error [fingerprint_sha256] - trusted_certificate_already_exists + ( if is_trusted then + (* Legacy CA is not applicable to this check. *) + let expr = + let open Xapi_database.Db_filter_types in + let type' = Record_util.certificate_type_to_string _type in + let type' = Eq (Field "type", Literal type') in + let fingerprint_sha256 = + Eq (Field "fingerprint_sha256", Literal fingerprint_sha256) + in + And (type', fingerprint_sha256) + in + Db.Certificate.get_records_where ~__context ~expr + |> List.filter (fun (_, cert_rec) -> + let open PurposeSet in + let s1 = of_list purpose in + let s2 = of_list cert_rec.API.certificate_purpose in + equal s1 s2 || not (is_empty (inter s1 s2)) + ) + |> List.iter (fun _ -> + raise_server_error [fingerprint_sha256] + trusted_certificate_already_exists + ) ) ; let uuid = Uuidx.(to_string (make ())) in let ref' = Ref.make () in diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index 3fc4d3bdb16..7507a98a276 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -88,6 +88,8 @@ let task_in_database ctx = Ref.is_real ctx.task_id let get_origin ctx = string_of_origin ctx.origin +let is_internal_origin ctx = ctx.origin = Internal + let database_of x = x.database (** Calls coming in from the main unix socket are pre-authenticated. @@ -520,7 +522,7 @@ let get_test_clusterd_rpc context = context.test_clusterd_rpc let get_client context = context.client |> Option.map Http_svr.string_of_client let get_client_ip context = - context.client |> Option.map (fun (_, ip) -> Ipaddr.to_string ip) + context.client |> Option.map (fun (_, ip) -> Http_svr.canonical_ip_string ip) let get_user_agent context = match context.origin with diff --git a/ocaml/xapi/context.mli b/ocaml/xapi/context.mli index f5bb3ed3524..a2956ecca08 100644 --- a/ocaml/xapi/context.mli +++ b/ocaml/xapi/context.mli @@ -90,6 +90,9 @@ val task_in_database : t -> bool val get_origin : t -> string (** [get_origin __context] returns a string containing the origin of [__context]. *) +val is_internal_origin : t -> bool +(** [is_internal_origin __context] returns true if the context originated from an internal operation. *) + val database_of : t -> Xapi_database.Db_ref.t (** [database_of __context] returns a database handle, which can be used by Db.* *) diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index 3b949ea9703..5adf2bb8f1d 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -24,8 +24,12 @@ open D let valid_ref x = Db.is_valid_ref x -let gc_connector ~__context get_all get_record valid_ref1 valid_ref2 - delete_record = +(* [valid_ref1]/[valid_ref2] each check one field of the connector object. + They take the object's own reference and fetch only the field they need, + rather than materialising the whole record via [get_record]: every caller + here only looks at two ref fields, and this runs every 30s under the global + DB lock once per connector object. *) +let gc_connector ~__context get_all valid_ref1 valid_ref2 delete_record = let db = Context.database_of __context in let module DB = (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS2) @@ -38,9 +42,8 @@ let gc_connector ~__context get_all get_record valid_ref1 valid_ref2 else "INVALID" in - let record = get_record ~__context ~self:ref in - let ref_1_valid = valid_ref1 record in - let ref_2_valid = valid_ref2 record in + let ref_1_valid = valid_ref1 ~__context ~self:ref in + let ref_2_valid = valid_ref2 ~__context ~self:ref in if not (ref_1_valid && ref_2_valid) then ( let table, reference, valid1, valid2 = ( ( match DB.get_table_from_ref db (Ref.string_of ref) with @@ -98,9 +101,13 @@ let gc_Host_driver_variants ~__context = variants let gc_PIFs ~__context = - gc_connector ~__context Db.PIF.get_all Db.PIF.get_record - (fun x -> valid_ref __context x.pIF_host) - (fun x -> valid_ref __context x.pIF_network) + gc_connector ~__context Db.PIF.get_all + (fun ~__context ~self -> + valid_ref __context (Db.PIF.get_host ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.PIF.get_network ~__context ~self) + ) (fun ~__context ~self -> (* We need to destroy the PIF, it's metrics and any VLAN/bond records that this PIF was a master of. *) (* bonds/tunnels/sriovs_to_gc is actually a list which is either empty (not part of a bond/tunnel/sriov) @@ -132,9 +139,14 @@ let gc_PIFs ~__context = ) let gc_VBDs ~__context = - gc_connector ~__context Db.VBD.get_all Db.VBD.get_record - (fun x -> valid_ref __context x.vBD_VM) - (fun x -> valid_ref __context x.vBD_VDI || x.vBD_empty) + gc_connector ~__context Db.VBD.get_all + (fun ~__context ~self -> + valid_ref __context (Db.VBD.get_VM ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.VBD.get_VDI ~__context ~self) + || Db.VBD.get_empty ~__context ~self + ) (fun ~__context ~self -> (* When GCing VBDs that are CDs, set them to empty rather than destroy them entirely *) if @@ -151,15 +163,23 @@ let gc_VBDs ~__context = ) let gc_crashdumps ~__context = - gc_connector ~__context Db.Crashdump.get_all Db.Crashdump.get_record - (fun x -> valid_ref __context x.crashdump_VM) - (fun x -> valid_ref __context x.crashdump_VDI) + gc_connector ~__context Db.Crashdump.get_all + (fun ~__context ~self -> + valid_ref __context (Db.Crashdump.get_VM ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.Crashdump.get_VDI ~__context ~self) + ) Db.Crashdump.destroy let gc_VIFs ~__context = - gc_connector ~__context Db.VIF.get_all Db.VIF.get_record - (fun x -> valid_ref __context x.vIF_VM) - (fun x -> valid_ref __context x.vIF_network) + gc_connector ~__context Db.VIF.get_all + (fun ~__context ~self -> + valid_ref __context (Db.VIF.get_VM ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.VIF.get_network ~__context ~self) + ) (fun ~__context ~self -> let metrics = Db.VIF.get_metrics ~__context ~self in (try Db.VIF_metrics.destroy ~__context ~self:metrics with _ -> ()) ; @@ -167,27 +187,43 @@ let gc_VIFs ~__context = ) let gc_PBDs ~__context = - gc_connector ~__context Db.PBD.get_all Db.PBD.get_record - (fun x -> valid_ref __context x.pBD_host) - (fun x -> valid_ref __context x.pBD_SR) + gc_connector ~__context Db.PBD.get_all + (fun ~__context ~self -> + valid_ref __context (Db.PBD.get_host ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.PBD.get_SR ~__context ~self) + ) Db.PBD.destroy let gc_PUSBs ~__context = - gc_connector ~__context Db.PUSB.get_all Db.PUSB.get_record - (fun x -> valid_ref __context x.pUSB_host) - (fun x -> valid_ref __context x.pUSB_USB_group) + gc_connector ~__context Db.PUSB.get_all + (fun ~__context ~self -> + valid_ref __context (Db.PUSB.get_host ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.PUSB.get_USB_group ~__context ~self) + ) Db.PUSB.destroy let gc_Cluster_hosts ~__context = - gc_connector ~__context Db.Cluster_host.get_all Db.Cluster_host.get_record - (fun x -> valid_ref __context x.cluster_host_host) - (fun x -> valid_ref __context x.cluster_host_PIF) + gc_connector ~__context Db.Cluster_host.get_all + (fun ~__context ~self -> + valid_ref __context (Db.Cluster_host.get_host ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.Cluster_host.get_PIF ~__context ~self) + ) Db.Cluster_host.destroy let gc_VGPUs ~__context = - gc_connector ~__context Db.VGPU.get_all Db.VGPU.get_record - (fun x -> valid_ref __context x.vGPU_VM) - (fun x -> valid_ref __context x.vGPU_GPU_group) + gc_connector ~__context Db.VGPU.get_all + (fun ~__context ~self -> + valid_ref __context (Db.VGPU.get_VM ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.VGPU.get_GPU_group ~__context ~self) + ) (fun ~__context ~self -> Db.VGPU.destroy ~__context ~self) let gc_PGPUs ~__context = @@ -255,9 +291,13 @@ let gc_Features ~__context = ) let gc_Host_patches ~__context = - gc_connector ~__context Db.Host_patch.get_all Db.Host_patch.get_record - (fun x -> valid_ref __context x.host_patch_host) - (fun x -> valid_ref __context x.host_patch_pool_patch) + gc_connector ~__context Db.Host_patch.get_all + (fun ~__context ~self -> + valid_ref __context (Db.Host_patch.get_host ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.Host_patch.get_pool_patch ~__context ~self) + ) Db.Host_patch.destroy let gc_host_cpus ~__context = @@ -600,25 +640,34 @@ let gc_consoles ~__context = (Db.Console.get_all ~__context) let gc_PVS_proxies ~__context = - gc_connector ~__context Db.PVS_proxy.get_all Db.PVS_proxy.get_record - (fun x -> valid_ref __context x.pVS_proxy_VIF) - (fun x -> valid_ref __context x.pVS_proxy_site) + gc_connector ~__context Db.PVS_proxy.get_all + (fun ~__context ~self -> + valid_ref __context (Db.PVS_proxy.get_VIF ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.PVS_proxy.get_site ~__context ~self) + ) Db.PVS_proxy.destroy (* A PVS server refers to a PVS site. We delete it, if the reference * becomes invalid. At creation, the server is connected to a site and * hence we never GC a server right after it was created. *) let gc_PVS_servers ~__context = - gc_connector ~__context Db.PVS_server.get_all Db.PVS_server.get_record - (fun _ -> true) - (fun x -> valid_ref __context x.pVS_server_site) + gc_connector ~__context Db.PVS_server.get_all + (fun ~__context:_ ~self:_ -> true) + (fun ~__context ~self -> + valid_ref __context (Db.PVS_server.get_site ~__context ~self) + ) Db.PVS_server.destroy let gc_PVS_cache_storage ~__context = gc_connector ~__context Db.PVS_cache_storage.get_all - Db.PVS_cache_storage.get_record - (fun x -> valid_ref __context x.pVS_cache_storage_site) - (fun x -> valid_ref __context x.pVS_cache_storage_host) + (fun ~__context ~self -> + valid_ref __context (Db.PVS_cache_storage.get_site ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.PVS_cache_storage.get_host ~__context ~self) + ) Db.PVS_cache_storage.destroy let gc_updates_requiring_reboot ~__context = @@ -637,6 +686,21 @@ let gc_updates_requiring_reboot ~__context = ) (Db.Host.get_all ~__context) +let gc_tunnels ~__context = + gc_connector ~__context Db.Tunnel.get_all + (fun ~__context ~self -> + valid_ref __context (Db.Tunnel.get_access_PIF ~__context ~self) + ) + (fun ~__context ~self -> + valid_ref __context (Db.Tunnel.get_transport_PIF ~__context ~self) + ) + (fun ~__context ~self -> + let access = Db.Tunnel.get_access_PIF ~__context ~self in + Db.Tunnel.destroy ~__context ~self ; + if valid_ref __context access then + try Db.PIF.destroy ~__context ~self:access with _ -> () + ) + (* do VDIs first because this will cause some VBDs to be affected *) let gc_subtask_list = [ @@ -669,4 +733,5 @@ let gc_subtask_list = ; ("Updates requiring reboot", gc_updates_requiring_reboot) ; ("Host drivers", gc_Host_drivers) ; ("Host driver variants", gc_Host_driver_variants) + ; ("Tunnels", gc_tunnels) ] diff --git a/ocaml/xapi/dbsync_master.ml b/ocaml/xapi/dbsync_master.ml index 7e944ca2b29..fb6aa377de1 100644 --- a/ocaml/xapi/dbsync_master.ml +++ b/ocaml/xapi/dbsync_master.ml @@ -55,6 +55,7 @@ let create_pool_record ~__context = ~ext_auth_cache_size:50L ~ext_auth_cache_expiry:300L ~recommendations:[] ~license_server:[] ~ha_reboot_vm_on_internal_shutdown:true ~limit_console_sessions:false ~vm_console_idle_timeout:0L + ~auto_update_vm_secureboot_certificates:false let set_master_ip ~__context = let ip = diff --git a/ocaml/xapi/debug_populate.ml b/ocaml/xapi/debug_populate.ml index 793076f26e1..1401547b892 100644 --- a/ocaml/xapi/debug_populate.ml +++ b/ocaml/xapi/debug_populate.ml @@ -100,7 +100,7 @@ let rec make_vifs __context vmref i = ~network:(get_random nws) ~vM:vmref ~mAC:"de:ad:be:ef:99:88" ~mTU:Int64.zero ~other_config:[] ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~locking_mode:`network_default - ~ipv4_allowed:[] ~ipv6_allowed:[] ~currently_attached:false + ~ipv4_allowed:[] ~ipv6_allowed:[] ~currently_attached:false ~trunks:[] ) ; make_vifs __context vmref (i - 1) ) diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 9afbe9c27c0..ba904c14617 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -65,6 +65,8 @@ exnHelper rbac_static xapi_role + xapi_caller + xapi_rate_limit xapi_extensions db) (modes best) @@ -92,7 +94,11 @@ forkexec unix xapi-idl + xapi-idl.rrd + xapi-rrd + rrdd-plugin xapi_aux + xapi-rate-limit xapi-stdext-std xapi-stdext-pervasives xapi-log.backtrace @@ -129,6 +135,8 @@ locking_helpers exnHelper xapi_role + xapi_caller + xapi_rate_limit xapi_extensions db)) (libraries @@ -166,6 +174,7 @@ psq ptime ptime.clock.os + xapi-rate-limit rpclib.core rpclib.json rpclib.xml diff --git a/ocaml/xapi/extauth.ml b/ocaml/xapi/extauth.ml index d660b6a708b..73f423f5548 100644 --- a/ocaml/xapi/extauth.ml +++ b/ocaml/xapi/extauth.ml @@ -203,6 +203,14 @@ let call_with_exception_handler fn = raise (Api_errors.Server_error (Api_errors.auth_unknown_type, [msg])) | Not_found | Auth_signature.Subject_cannot_be_resolved -> raise (Api_errors.Server_error (Api_errors.subject_cannot_be_resolved, [])) + | Auth_signature.Auth_service_error (E_INVALID_TRUSTED_CERTS, msg) -> + raise + (Api_errors.Server_error (Api_errors.auth_invalid_trusted_certs, [msg])) + | Auth_signature.Auth_service_error (E_NO_TRUSTED_CERTS, msg) -> + raise (Api_errors.Server_error (Api_errors.auth_no_trusted_certs, [msg])) + | Auth_signature.Auth_service_error (E_FAILED_SETUP_TLS_CONNECTION, msg) -> + raise + (Api_errors.Server_error (Api_errors.auth_setup_tls_connection, [msg])) | Auth_signature.Auth_service_error (_, msg) -> raise (Api_errors.Server_error (Api_errors.auth_service_error, [msg])) | e -> diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index ad3dae6941b..95f9f3fa2f9 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -21,15 +21,31 @@ end) open D open Auth_signature +module Listext = Xapi_stdext_std.Listext module Scheduler = Xapi_stdext_threads_scheduler.Scheduler let finally = Xapi_stdext_pervasives.Pervasiveext.finally let krbtgt = "KRBTGT" -let ( let* ) = Result.bind +let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute + +(* Mutex for serializing AD external auth operations. + * Write ops (enable/disable/set_ldaps) modify winbind config and domain state. + * Read ops (authenticate/query) query AD via wbinfo. + * A plain Mutex serializes both. The [serialize_auth_service] config key + * (default: true) can be set to false to skip locking under concurrent load, + * but only when configure and authenticate calls are never concurrent. *) +let serialize_ext_auth_lock = Mutex.create () + +let cond_sync_ext_auth f = + match !Xapi_globs.serialize_auth_service with + | true -> + with_lock serialize_ext_auth_lock f + | false -> + f () -let ( let@ ) = ( @@ ) +let ( let* ) = Result.bind let ( ) x f = Rresult.R.reword_error f x @@ -58,11 +74,13 @@ let auth_ex uname = let msg = Printf.sprintf "failed to authenticate user '%s'" uname in Auth_signature.(Auth_failure msg) -let generic_ex fmt = +let gen_ex tag fmt = Printf.ksprintf - (fun msg -> Auth_signature.(Auth_service_error (E_GENERIC, msg))) + (fun msg -> Auth_signature.(Auth_service_error (tag, msg))) fmt +let generic_ex fmt = gen_ex E_GENERIC fmt + let net_cmd = !Xapi_globs.net_cmd let wb_cmd = !Xapi_globs.wb_cmd @@ -71,6 +89,34 @@ let tdb_tool = !Xapi_globs.tdb_tool let domain_krb5_dir = Filename.concat Xapi_globs.samba_dir "lock/smb_krb5" +let ca_bundle_for_purpose purpose = + Printf.sprintf "%s/%s-%s.pem" Constants.trusted_certs_by_purpose_dir + Constants.trusted_certs_root_prefix purpose + +let ldaps_ca_bundle = ca_bundle_for_purpose "ldaps" + +let general_ca_bundle = ca_bundle_for_purpose "general" + +(** Return the best available CA bundle path, in priority order: + ldaps-specific bundle > general bundle. + Returns [None] if none exist. *) +let ca_bundle_path () = + [ldaps_ca_bundle; general_ca_bundle] |> List.find_opt Sys.file_exists + +let assert_ca_exists = function + | true -> + ca_bundle_path () + |> Option.to_result + ~none: + (gen_ex E_NO_TRUSTED_CERTS + "No trusted certs to setup TLS connection to DC. Note: ldaps \ + does not support non-CA certs" + ) + |> maybe_raise + |> ignore + | false -> + () + let debug_level () = clamp !Xapi_globs.winbind_debug_level @@ -78,19 +124,101 @@ let debug_level () = |> string_of_int let err_msg_to_tag_map = + let open Auth_signature in [ - ("not a properly formed account name", Auth_signature.E_INVALID_ACCOUNT) - ; ("bad username or authentication", Auth_signature.E_CREDENTIALS) + ("not a properly formed account name", E_INVALID_ACCOUNT) + ; ("bad username or authentication", E_CREDENTIALS) + ; ( "Windows cannot verify the digital signature for this file" + , E_INVALID_TRUSTED_CERTS + ) + ; ("tstream_tls_sync_setup: GNUTLS ERROR", E_FAILED_SETUP_TLS_CONNECTION) + ; ("KDC has no support for encryption type", E_NO_SUPPORT_ENCRYPT_TYPE) (* Some other errors *) ] -type domain_info = { +module DomainInfo = struct + type t = { + service_name: string + ; user: string option + ; workgroup: string option + (* For upgrade case, the legacy db does not contain workgroup *) + ; netbios_name: string option + (* Persist netbios_name to support hostname change *) + ; ldaps: bool option (* Use LDAPS instead of LDAP *) + ; machine_pwd_last_change_time: float option + ; ou: string option + } + + let of_db ~__context = + let host = Helpers.get_localhost ~__context in + let service_name = + Db.Host.get_external_auth_service_name ~__context ~self:host + in + let config = + Db.Host.get_external_auth_configuration ~__context ~self:host + in + let user = List.assoc_opt "user" config in + let workgroup = List.assoc_opt "workgroup" config in + let netbios_name = List.assoc_opt "netbios_name" config in + let machine_pwd_last_change_time = + List.assoc_opt "machine_pwd_last_change_time" config + |> Option.map (fun s -> float_of_string s) + in + let ldaps = Some (Helpers.ldaps_enabled_in_config ~config) in + let ou = List.assoc_opt "ou" config in + { + service_name + ; user + ; workgroup + ; netbios_name + ; ldaps + ; machine_pwd_last_change_time + ; ou + } + + let to_db ~__context ~domain_info = + let value = + match domain_info with + | None -> + [] + | Some + { + service_name + ; user + ; workgroup + ; netbios_name + ; machine_pwd_last_change_time + ; ldaps + ; ou + } -> + [ + Some ("domain", service_name) + ; user |> Option.map (fun u -> ("user", u)) + ; workgroup |> Option.map (fun w -> ("workgroup", w)) + ; netbios_name |> Option.map (fun nn -> ("netbios_name", nn)) + ; machine_pwd_last_change_time + |> Option.map (fun t -> + ("machine_pwd_last_change_time", string_of_float t) + ) + ; ldaps |> Option.map (fun l -> ("ldaps", string_of_bool l)) + ; ou |> Option.map (fun ou -> ("ou", ou)) + ] + |> List.concat_map (function Some x -> [x] | None -> []) + in + Helpers.get_localhost ~__context |> fun self -> + Db.Host.set_external_auth_configuration ~__context ~self ~value ; + Db.Host.get_name_label ~__context ~self + |> debug "update external_auth_configuration for host %s" +end + +type domain_info = DomainInfo.t = { service_name: string + ; user: string option ; workgroup: string option - (* For upgrade case, the legacy db does not contain workgroup *) ; netbios_name: string option - (* Persist netbios_name to support hostname change *) + ; ldaps: bool option ; machine_pwd_last_change_time: float option + ; ou: string option } let generic_error msg = @@ -186,23 +314,11 @@ let tag_from_err_msg msg = | None -> Auth_signature.E_GENERIC -let get_domain_info_from_db () = - Server_helpers.exec_with_new_task "retrieving external auth domain workgroup" - @@ fun __context -> - let host = Helpers.get_localhost ~__context in - let service_name = - Db.Host.get_external_auth_service_name ~__context ~self:host - in - let workgroup, netbios_name, machine_pwd_last_change_time = - Db.Host.get_external_auth_configuration ~__context ~self:host - |> fun config -> - ( List.assoc_opt "workgroup" config - , List.assoc_opt "netbios_name" config - , List.assoc_opt "machine_pwd_last_change_time" config - |> Option.map (fun s -> float_of_string s) - ) - in - {service_name; workgroup; netbios_name; machine_pwd_last_change_time} +let auth_ex_of_msg errmsg fmt = + let tag = tag_from_err_msg errmsg in + Printf.ksprintf + (fun msg -> Auth_signature.(Auth_service_error (tag, msg))) + fmt let update_extauth_configuration ~__context ~k ~v = let self = Helpers.get_localhost ~__context in @@ -210,6 +326,41 @@ let update_extauth_configuration ~__context ~k ~v = (k, v) :: List.remove_assoc k value |> fun value -> Db.Host.set_external_auth_configuration ~__context ~self ~value +let kdcs_of_domain domain = + try + Helpers.call_script ~log_output:On_failure net_cmd + ["lookup"; "kdc"; domain; "-d"; debug_level ()] + (* Result like 10.71.212.25:88\n10.62.1.25:88\n*) + |> String.split_on_char '\n' + |> List.filter (fun x -> String.trim x <> "") (* Remove empty lines *) + |> List.map KDC.from_lookup + with _ -> fail "%s: failed to lookup kdcs of domain %s" __FUNCTION__ domain + +let workgroup_from_server kdc = + let err_msg = + Printf.sprintf "Failed to lookup workgroup from server %s" (KDC.server kdc) + in + let key = "Pre-Win2k Domain" in + try + Helpers.call_script ~log_output:On_failure net_cmd + ["ads"; "lookup"; "-S"; KDC.server kdc; "-d"; debug_level ()] + |> Xapi_cmd_result.of_output ~sep:':' ~key + |> Result.ok + with _ -> + debug "Unable to query info from kdc %s, probably is broken down" + (KDC.to_msg kdc) ; + Error (Auth_service_error (E_LOOKUP, err_msg)) + +let kdc_of_domain_checked domain = + kdcs_of_domain domain + (* Does not trust DNS as it may cache some invalid kdcs, CA-360951 *) + |> List.find_opt (fun kdc -> workgroup_from_server kdc |> Result.is_ok) + |> function + | Some x -> + x + | None -> + raise (generic_ex "No valid kdc found for domain %s" domain) + module Ldap = struct module Escape = struct (* @@ -439,26 +590,55 @@ module Ldap = struct |> fun x -> Ok x with _ -> Error (generic_ex "ldap query domain name failed") - let query_sid ~name ~kdc = + let query_sid ~name ?duser ?dpass kdc = let key = "objectSid" in let name = escape name in (* Escape name to avoid injection detection *) let query = Printf.sprintf "(|(sAMAccountName=%s)(name=%s))" name name in + (* When both a username and password are supplied, authenticate with those + credentials, passed via the environment, instead of the machine + account. *) + let auth_args, env = + match (duser, dpass) with + | Some duser, Some dpass -> + let env = + [|Printf.sprintf "USER=%s" duser; Printf.sprintf "PASSWD=%s" dpass|] + in + ([], Some env) + | _ -> + (["--machine-pass"], None) + in let args = - ["ads"; "search"; "-d"; debug_level (); "--server"; kdc; "--machine-pass"] + ["ads"; "search"; "-d"; debug_level (); "--server"; kdc] + @ auth_args @ [query; key] in try - Helpers.call_script !Xapi_globs.net_cmd args + Helpers.call_script ?env !Xapi_globs.net_cmd args |> Xapi_cmd_result.of_output ~sep:':' ~key |> fun x -> Ok x with - | Forkhelpers.Spawn_internal_error (_, stdout, _) -> - Error (generic_ex "Ldap query sid failed: %s" stdout) + | Forkhelpers.Spawn_internal_error (err, out, _) -> + Error + (auth_ex_of_msg err "Failed to do ldap(s) query for AD user %s %s" + name out + ) | Not_found -> Error (generic_ex "%s not found in ldap result" key) | _ -> Error (generic_ex "Failed to lookup sid from username %s" name) + + let ping_domain domain = + kdcs_of_domain domain + |> Listext.List.try_map_any (fun kdc -> + query_sid ~name:krbtgt (KDC.server kdc) + ) + |> Result.map_error (function + | e :: _ -> + e + | [] -> + generic_ex "Failed to LDAP(s) ping domain %s" domain + ) end module Wbinfo = struct @@ -771,39 +951,6 @@ module Migrate_from_pbis = struct netbios_name end -let kdcs_of_domain domain = - try - Helpers.call_script ~log_output:On_failure net_cmd - ["lookup"; "kdc"; domain; "-d"; debug_level ()] - (* Result like 10.71.212.25:88\n10.62.1.25:88\n*) - |> String.split_on_char '\n' - |> List.filter (fun x -> String.trim x <> "") (* Remove empty lines *) - |> List.map KDC.from_lookup - with _ -> fail "%s: failed to lookup kdcs of domain %s" __FUNCTION__ domain - -let workgroup_from_server kdc = - let err_msg = - Printf.sprintf "Failed to lookup workgroup from server %s" (KDC.server kdc) - in - let key = "Pre-Win2k Domain" in - try - Helpers.call_script ~log_output:On_failure net_cmd - ["ads"; "lookup"; "-S"; KDC.server kdc; "-d"; debug_level ()] - |> Xapi_cmd_result.of_output ~sep:':' ~key - |> Result.ok - with _ -> - debug "Unable to query info from kdc %s, probably is broken down" - (KDC.to_msg kdc) ; - Error (Auth_service_error (E_LOOKUP, err_msg)) - -let kdc_of_domain_checked domain = - try - kdcs_of_domain domain - (* Does not trust DNS as it may cache some invalid kdcs, CA-360951 *) - |> List.find (fun kdc -> workgroup_from_server kdc |> Result.is_ok) - with Not_found -> - raise (generic_ex "No valid kdc found for domain %s" domain) - let query_domain_workgroup ~domain = let err_msg = Printf.sprintf "Failed to look up domain %s workgroup" domain in try @@ -811,16 +958,36 @@ let query_domain_workgroup ~domain = workgroup_from_server kdc |> Result.get_ok with _ -> raise (Auth_service_error (E_LOOKUP, err_msg)) -let config_winbind_daemon ~workgroup ~netbios_name ~domain = +let config_winbind_daemon domain_info = let smb_config = "/etc/samba/smb.conf" in let extra_conf = "/etc/samba/smb.extra.conf" in let string_of_bool = function true -> "yes" | false -> "no" in - let scan_trusted_domains = string_of_bool !Xapi_globs.winbind_scan_trusted_domains in - ( match (workgroup, netbios_name, domain) with - | Some wkgroup, Some netbios, Some dom -> + ( match domain_info with + | Some + { + service_name= dom + ; workgroup= Some wkgroup + ; netbios_name= Some netbios + ; ldaps + ; _ + } -> + let ldaps_conf = + match ldaps with Some true -> "ldaps" | _ -> "seal" + in + let tls_ca = + match ca_bundle_path () with + | Some path when Sys.is_directory path -> + Printf.sprintf "tls ca directories = %s" path + | Some path -> + Printf.sprintf "tls cafile = %s" path + | None -> + (* Presuming assert_ca_exists is called before reach here, + so ldaps is not enabled here, this item does not matter *) + Printf.sprintf "tls cafile = %s" ldaps_ca_bundle + in [ Printf.sprintf "# This file is managed by xapi, update %s instead" extra_conf @@ -835,6 +1002,12 @@ let config_winbind_daemon ~workgroup ~netbios_name ~domain = ; "winbind refresh tickets = yes" ; "winbind enum groups = no" ; "winbind enum users = no" + ; Printf.sprintf "client ldap sasl wrapping = %s" ldaps_conf + ; "tls trust system cas = yes" + ; "tls verify peer = ca_and_name_if_available" + ; tls_ca + ; Printf.sprintf "tls priority = %s" + (Tls_policy.Gnutls.default_policy ()) ; Printf.sprintf "winbind scan trusted domains = %s" scan_trusted_domains ; "winbind use krb5 enterprise principals = yes" @@ -865,7 +1038,7 @@ let clear_winbind_config () = if !Xapi_globs.winbind_keep_configuration then () else - config_winbind_daemon ~workgroup:None ~netbios_name:None ~domain:None + config_winbind_daemon None let from_config ~name ~err_msg ~config_params = match List.assoc_opt name config_params with @@ -876,8 +1049,7 @@ let from_config ~name ~err_msg ~config_params = let all_number_re = Re.Perl.re {|^\d+$|} |> Re.Perl.compile -let get_localhost_name () = - Server_helpers.exec_with_new_task "retrieving hostname" @@ fun __context -> +let get_localhost_name ~__context = Helpers.get_localhost ~__context |> fun host -> Db.Host.get_hostname ~__context ~self:host @@ -898,33 +1070,8 @@ let assert_domain_equal_service_name ~service_name ~config_params = let extract_ou_config ~config_params = try let ou = from_config ~name:"ou" ~err_msg:"" ~config_params in - ([("ou", ou)], [Printf.sprintf "createcomputer=%s" ou]) - with Auth_service_error _ -> ([], []) - -let persist_extauth_config ~domain ~user ~ou_conf ~workgroup ~netbios_name - ~machine_pwd_last_change_time = - let value = - match - (domain, user, workgroup, netbios_name, machine_pwd_last_change_time) - with - | Some dom, Some u, Some wkg, Some netbios, Some pwd_time -> - [ - ("domain", dom) - ; ("user", u) - ; ("workgroup", wkg) - ; ("netbios_name", netbios) - ; ("machine_pwd_last_change_time", pwd_time) - ] - @ ou_conf - | _ -> - [] - in - Server_helpers.exec_with_new_task "update external_auth_configuration" - @@ fun __context -> - Helpers.get_localhost ~__context |> fun self -> - Db.Host.set_external_auth_configuration ~__context ~self ~value ; - Db.Host.get_name_label ~__context ~self - |> debug "update external_auth_configuration for host %s" + (Some ou, [Printf.sprintf "createcomputer=%s" ou]) + with Auth_service_error _ -> (None, []) let clear_machine_account ~service_name = function | Some u, Some p -> ( @@ -982,12 +1129,6 @@ module Winbind = struct Helpers.call_script ~log_output:On_failure net_cmd args |> ignore with _ -> debug "Failed to flush winbind cache, ignoring" - let is_ad_enabled ~__context = - ( Helpers.get_localhost ~__context |> fun self -> - Db.Host.get_external_auth_type ~__context ~self - ) - |> fun x -> x = Xapi_globs.auth_type_AD - let update_workgroup ~__context ~workgroup = update_extauth_configuration ~__context ~k:"workgroup" ~v:workgroup @@ -1000,59 +1141,66 @@ module Winbind = struct let stop ~timeout ~wait_until_success = Xapi_systemctl.stop ~timeout ~wait_until_success name - let configure ~__context = + let check_ready_to_serve ~timeout = + (* we _need_ to use a username contained in our domain, otherwise the following tests won't work. + Microsoft KB/Q243330 article provides the KRBTGT account as a well-known built-in SID in AD + Microsoft KB/Q229909 article says that KRBTGT account cannot be renamed or enabled, making + it the perfect target for such a test using a username (Administrator account can be renamed) *) + try + Helpers.retry_until_timeout ~timeout + (Printf.sprintf "%s: Checking if %s is ready" __FUNCTION__ name) + Wbinfo.can_resolve_krbtgt ; + debug "%s: Service %s is ready" __FUNCTION__ name + with e -> + let msg = + Printf.sprintf + "%s: %s is not ready after checking for %f seconds, error: %s" + __FUNCTION__ name timeout + (ExnHelper.string_of_exn e) + in + error "%s: Service not ready error: %s" __FUNCTION__ msg ; + raise (Auth_service_error (E_GENERIC, msg)) + + let configure ~__context ?(domain_info = DomainInfo.of_db ~__context) () = (* Refresh winbind configuration to handle upgrade from PBIS * The winbind configuration needs to be refreshed before start winbind daemon *) - let {service_name; workgroup; netbios_name; _} = - get_domain_info_from_db () - in let netbios_name = - match netbios_name with + match domain_info.netbios_name with | None -> Migrate_from_pbis.migrate_netbios_name ~__context | Some name -> name in let workgroup = - match workgroup with + match domain_info.workgroup with | None -> - let workgroup = query_domain_workgroup ~domain:service_name in + let workgroup = + query_domain_workgroup ~domain:domain_info.service_name + in (* Persist the workgroup to avoid lookup again on next startup *) update_workgroup ~__context ~workgroup ; workgroup | Some workgroup -> workgroup in - config_winbind_daemon ~domain:(Some service_name) - ~workgroup:(Some workgroup) ~netbios_name:(Some netbios_name) + let domain_info = + { + domain_info with + netbios_name= Some netbios_name + ; workgroup= Some workgroup + } + in + config_winbind_daemon (Some domain_info) ; + restart ~wait_until_success:false ~timeout:5. ; + check_ready_to_serve ~timeout:300. let init_service ~__context = - if is_ad_enabled ~__context then ( - configure ~__context ; - restart ~wait_until_success:false ~timeout:5. - ) else + let host = Helpers.get_localhost ~__context in + if Helpers.is_ad_enabled ~__context ~host then + configure ~__context () + else debug "Skip starting %s as AD is not enabled" name - let check_ready_to_serve ~timeout = - (* we _need_ to use a username contained in our domain, otherwise the following tests won't work. - Microsoft KB/Q243330 article provides the KRBTGT account as a well-known built-in SID in AD - Microsoft KB/Q229909 article says that KRBTGT account cannot be renamed or enabled, making - it the perfect target for such a test using a username (Administrator account can be renamed) *) - try - Helpers.retry_until_timeout ~timeout - (Printf.sprintf "Checking if %s is ready" name) - Wbinfo.can_resolve_krbtgt ; - debug "Service %s is ready" name - with e -> - let msg = - Printf.sprintf - "%s is not ready after checking for %f seconds, error: %s" name - timeout - (ExnHelper.string_of_exn e) - in - error "Service not ready error: %s" msg ; - raise (Auth_service_error (E_GENERIC, msg)) - let random_string len = let upper_char_start = Char.code 'A' in let upper_char_len = 26 in @@ -1119,34 +1267,60 @@ module Winbind = struct debug "Skip setting machine account encryption type to DC" end +(* Enable or disable LDAPS for external authentication *) +let set_ldaps ~__context ~ldaps ~force = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + cond_sync_ext_auth @@ fun () -> + debug "%s:%d set_ldaps ldaps=%b force=%b" __FUNCTION__ __LINE__ ldaps force ; + let old_domain_info = DomainInfo.of_db ~__context in + + (* Check if LDAPS is already set to the desired value *) + if old_domain_info.ldaps = Some ldaps && not force then + raise (generic_ex "ldaps is already %s" (string_of_bool ldaps)) ; + + assert_ca_exists ldaps ; + + let new_domain_info = {old_domain_info with ldaps= Some ldaps} in + (* Apply new configuration to winbind daemon for trial *) + Winbind.configure ~__context ~domain_info:new_domain_info () ; + (* Verify the new LDAP(S) setting works *) + match Ldap.ping_domain new_domain_info.service_name with + | Ok _ -> + (* Ping succeeded, persist the new domain_info *) + debug "%s ping domain succeed" __FUNCTION__ ; + DomainInfo.to_db ~__context ~domain_info:(Some new_domain_info) + | Error e -> + (* Ping failed, restore the old configuration *) + Winbind.configure ~__context ~domain_info:old_domain_info () ; + debug "%s ldap(s) verification failed, restored old configure" + __FUNCTION__ ; + raise e + module RotateMachinePassword = struct let task_name = "Rotating machine password" - let rotate () = + let rotate ~__context () = let now = Unix.time () in let now_str = string_of_float now in try let machine_pwd_last_change_time = - (get_domain_info_from_db ()).machine_pwd_last_change_time + (DomainInfo.of_db ~__context).machine_pwd_last_change_time in match machine_pwd_last_change_time with | Some time when now < time +. !Xapi_globs.winbind_machine_pwd_timeout -> () | _ -> Wbinfo.call_wbinfo ["--change-secret"] |> maybe_raise |> ignore ; - - Server_helpers.exec_with_new_task - "update machine password last change time" - @@ fun __context -> update_extauth_configuration ~__context ~k:"machine_pwd_last_change_time" ~v:now_str with e -> debug "Failed to rotate machine password %s " (ExnHelper.string_of_exn e) - let trigger_rotate ~start = + let trigger_rotate ~__context ~start = debug "Trigger task: %s" task_name ; Scheduler.add_to_queue task_name - (Scheduler.Periodic !Xapi_globs.winbind_machine_pwd_timeout) start rotate + (Scheduler.Periodic !Xapi_globs.winbind_machine_pwd_timeout) start + (rotate ~__context) let stop_rotate () = Scheduler.remove_from_queue task_name end @@ -1247,7 +1421,7 @@ module ConfigHosts = struct |> write_string_to_file path end -let build_netbios_name ~config_params = +let build_netbios_name ~__context ~config_params = let key = "netbios-name" in match List.assoc_opt key config_params with | Some name -> @@ -1256,7 +1430,7 @@ let build_netbios_name ~config_params = else name | None -> - get_localhost_name () |> Winbind.build_netbios_name + get_localhost_name ~__context |> Winbind.build_netbios_name let build_dns_hostname_option ~config_params = let key = "dns-hostname" in @@ -1266,7 +1440,7 @@ let build_dns_hostname_option ~config_params = | _ -> [] -let domain_name_of_netbios netbios = +let domain_name_of_netbios ~__context netbios = (* * Query the domain name from netbios name with caching * Check cache first, if not found, perform LDAP query and cache the result @@ -1286,7 +1460,7 @@ let domain_name_of_netbios netbios = debug "Cache hit for netbios '%s' -> domain '%s'" netbios domain_name ; Ok domain_name | None -> ( - let {service_name; workgroup; _} = get_domain_info_from_db () in + let {service_name; workgroup; _} = DomainInfo.of_db ~__context in match netbios = Option.value workgroup ~default:"" with | true -> cache_domain netbios service_name current_map ; @@ -1305,7 +1479,7 @@ let domain_name_of_netbios netbios = ) module AuthADWinbind : Auth_signature.AUTH_MODULE = struct - let get_subject_identifier' subject_name = + let get_subject_identifier' ~__context subject_name = (* Called in the login path with a yet unauthenticated user *) match Wbinfo.sid_of_name subject_name with | Ok sid -> @@ -1317,7 +1491,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct match user_of_sam subject_name with | Ok (domain_netbios, name) -> debug "Found user with SAM format: %s" subject_name ; - (domain_name_of_netbios domain_netbios, name) + (domain_name_of_netbios ~__context domain_netbios, name) | Error _ -> ( match user_of_upn subject_name with | Ok (domain, name) -> @@ -1326,13 +1500,13 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct | Error _ -> debug "User '%s' not in SAM or UPN format, use default domain" subject_name ; - let {service_name; _} = get_domain_info_from_db () in + let {service_name; _} = DomainInfo.of_db ~__context in (Ok service_name, subject_name) ) in (* Query kdc of the domain, so user in trusted domain is supported as well *) let* kdc = Wbinfo.kdc_of_domain (domain |> maybe_raise) in - Ldap.query_sid ~name ~kdc + Ldap.query_sid ~name kdc (* subject_id get_subject_identifier(string subject_name) @@ -1342,8 +1516,9 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Raises Not_found (*Subject_cannot_be_resolved*) if authentication is not succesful. *) let get_subject_identifier ~__context subject_name = - let@ __context = Context.with_tracing ~__context __FUNCTION__ in - maybe_raise (get_subject_identifier' subject_name) + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + cond_sync_ext_auth @@ fun () -> + maybe_raise (get_subject_identifier' ~__context subject_name) (* subject_id Authenticate_username_password(string username, string password) @@ -1357,7 +1532,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct *) let authenticate_username_password ~__context uname password = - let@ __context = Context.with_tracing ~__context __FUNCTION__ in + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + cond_sync_ext_auth @@ fun () -> (* the `wbinfo --krb5auth` expects the username to be in either SAM or UPN format. * we use wbinfo to try to convert the provided [uname] into said format. * as a last ditch attempt, we try to auth with the provided [uname] @@ -1367,7 +1543,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct (let* sid = (* we change the exception, since otherwise we get an (incorrect) error * message saying that credentials are correct, but we are not authorized *) - get_subject_identifier' uname function + get_subject_identifier' ~__context uname function | Auth_failure _ as e -> e | Auth_service_error (E_GENERIC, msg) -> @@ -1409,13 +1585,15 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct ; ("subject-is-group", string_of_bool true) ] - let query_subject_information_user (uid : int) (sid : string) = + let query_subject_information_user ~__context (uid : int) (sid : string) = (* user_name like DOMAIN\user_1 *) let* {user_name; gecos; gid; _} = Wbinfo.uid_info_of_uid uid in let sam_uname = user_name in let* domain_netbios, user = user_of_sam user_name in - (* permit unnkown domain if ldap query failed, update subject task will update it later *) - let domain = domain_name_of_netbios domain_netbios |> Result.to_option in + (* permit unknown domain if LDAP query failed, update subject task will update it later *) + let domain = + domain_name_of_netbios ~__context domain_netbios |> Result.to_option + in let default_account = Ldap. { @@ -1445,9 +1623,11 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct information" ; Ok default_account | Some domain -> ( - let* dc = Wbinfo.kdc_of_domain domain in let timeout = !Xapi_globs.winbind_ldap_query_subject_timeout in - match Ldap.query_user sid domain_netbios dc ~timeout with + match + let* dc = Wbinfo.kdc_of_domain domain in + Ldap.query_user sid domain_netbios dc ~timeout + with | Ok user -> Ok user | _ -> @@ -1497,12 +1677,13 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct let invalid_id = -1 let query_subject_information ~__context (sid : string) = - let@ __context = Context.with_tracing ~__context __FUNCTION__ in + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + cond_sync_ext_auth @@ fun () -> let res = match Subject.of_sid ~__context sid with | Subject.User _ -> let uid = Wbinfo.uid_of_sid sid |> Result.value ~default:invalid_id in - query_subject_information_user uid sid + query_subject_information_user ~__context uid sid | Subject.Group name -> (* if the name doesn't correspond to a user then it ought to be a group *) let gid = Wbinfo.gid_of_sid sid |> Result.value ~default:invalid_id in @@ -1519,7 +1700,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct supports nested groups (as AD does for example) *) let query_group_membership ~__context subject_identifier = - let@ __context = Context.with_tracing ~__context __FUNCTION__ in + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + cond_sync_ext_auth @@ fun () -> maybe_raise (Wbinfo.user_domgroups subject_identifier) let assert_join_domain_user_format uname = @@ -1546,7 +1728,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct does not need long-term.] *) let on_enable ~__context config_params = - let@ __context = Context.with_tracing ~__context __FUNCTION__ in + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + cond_sync_ext_auth @@ fun () -> let user = from_config ~name:"user" ~err_msg:"enable requires user" ~config_params in @@ -1556,23 +1739,64 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct assert_join_domain_user_format user ; - let netbios_name = build_netbios_name ~config_params in + let netbios_name = build_netbios_name ~__context ~config_params in let dns_hostname_option = build_dns_hostname_option ~config_params in assert_hostname_valid ~hostname:netbios_name ; - let {service_name; _} = get_domain_info_from_db () in + let service_name = + Helpers.get_localhost ~__context |> fun self -> + Db.Host.get_external_auth_service_name ~__context ~self + in assert_domain_equal_service_name ~service_name ~config_params ; let workgroup = (* Query new domain workgroup during join domain *) query_domain_workgroup ~domain:service_name in - config_winbind_daemon ~domain:(Some service_name) - ~workgroup:(Some workgroup) ~netbios_name:(Some netbios_name) ; + let ldaps = Helpers.ldaps_enabled_in_config ~config:config_params in + assert_ca_exists ldaps ; + + let ou, ou_param = extract_ou_config ~config_params in + let domain_info = + { + service_name + ; user= Some user + ; workgroup= Some workgroup + ; netbios_name= Some netbios_name + ; machine_pwd_last_change_time= Some (Unix.time ()) + ; ldaps= Some ldaps + ; ou + } + in - let ou_conf, ou_param = extract_ou_config ~config_params in + config_winbind_daemon (Some domain_info) ; + + (* When LDAPS is enabled the machine account does not exist yet, so probe + the candidate DCs with the supplied credentials and remember the first + one whose LDAPS certificate validates against the trusted CAs. We then + pin the join to that DC, instead of letting "net ads join" auto-select a + DC whose certificate may not be trusted (CA-428436). *) + let server_param = + if ldaps then + kdcs_of_domain service_name + |> Listext.List.try_map_any (fun kdc -> + Ldap.query_sid ~name:krbtgt ~duser:user ~dpass:pass (KDC.server kdc) + |> Result.map (fun _sid -> kdc) + ) + |> function + | Ok kdc -> + debug "Joining via DC %s with a valid LDAPS certificate" + (KDC.to_msg kdc) ; + ["-S"; KDC.server kdc] + | Error (e :: _) -> + raise e + | Error [] -> + raise (generic_ex "No KDC found for domain %s" service_name) + else + [] + in let args = [ @@ -1587,6 +1811,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct ; debug_level () ; "--no-dns-updates" ] + @ server_param @ ou_param @ dns_hostname_option in @@ -1598,32 +1823,28 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct (* Need to restart to refresh cache *) Winbind.restart ~timeout:5. ~wait_until_success:true ; Winbind.check_ready_to_serve ~timeout:300. ; - let machine_pwd_last_change_time = Unix.time () |> string_of_float in - persist_extauth_config ~domain:(Some service_name) ~user:(Some user) - ~ou_conf ~workgroup:(Some workgroup) - ~machine_pwd_last_change_time:(Some machine_pwd_last_change_time) - ~netbios_name:(Some netbios_name) ; + DomainInfo.to_db ~__context ~domain_info:(Some domain_info) ; (* Trigger right now *) - RotateMachinePassword.trigger_rotate ~start:0. ; + RotateMachinePassword.trigger_rotate ~__context ~start:0. ; ConfigHosts.join ~domain:service_name ~name:netbios_name ; let _, _ = Forkhelpers.execute_command_get_output !Xapi_globs.set_hostname - [get_localhost_name ()] + [get_localhost_name ~__context] in (* Trigger right now *) Winbind.set_machine_account_encryption_type netbios_name ; debug "Succeed to join domain %s" service_name with - | Forkhelpers.Spawn_internal_error (_, stdout, _) -> + | Forkhelpers.Spawn_internal_error (stderr, stdout, _) -> error "Join domain: %s error: %s" service_name stdout ; clear_winbind_config () ; ConfigHosts.leave ~domain:service_name ~name:netbios_name ; (* The configure is kept for debug purpose with max level *) - raise (Auth_service_error (stdout |> tag_from_err_msg, stdout)) + raise (Auth_service_error (stderr |> tag_from_err_msg, stdout)) | Xapi_systemctl.Systemctl_fail _ -> let msg = Printf.sprintf "Failed to start %s" Winbind.name in error "Start daemon error: %s" msg ; - config_winbind_daemon ~domain:None ~workgroup:None ~netbios_name:None ; + config_winbind_daemon None ; ConfigHosts.leave ~domain:service_name ~name:netbios_name ; raise (Auth_service_error (E_GENERIC, msg)) | e -> @@ -1646,10 +1867,11 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct within the body of the on_disable method) *) let on_disable ~__context config_params = - let@ __context = Context.with_tracing ~__context __FUNCTION__ in + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + cond_sync_ext_auth @@ fun () -> let user = List.assoc_opt "user" config_params in let pass = List.assoc_opt "pass" config_params in - let {service_name; netbios_name; _} = get_domain_info_from_db () in + let {service_name; netbios_name; _} = DomainInfo.of_db ~__context in ( match netbios_name with | Some netbios -> ConfigHosts.leave ~domain:service_name ~name:netbios @@ -1658,8 +1880,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct ) ; (* Clean extauth config *) - persist_extauth_config ~domain:None ~user:None ~ou_conf:[] ~workgroup:None - ~machine_pwd_last_change_time:None ~netbios_name:None ; + DomainInfo.to_db ~__context ~domain_info:None ; RotateMachinePassword.stop_rotate () ; (* The caller disable external auth even disable machine account failed, * We run clear_machine_account after some necessary resources get cleared *) @@ -1675,14 +1896,14 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct starting for the first time after a host boot *) let on_xapi_initialize ~__context _system_boot = - let@ __context = Context.with_tracing ~__context __FUNCTION__ in - + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + cond_sync_ext_auth @@ fun () -> Winbind.start ~timeout:5. ~wait_until_success:true ; - RotateMachinePassword.trigger_rotate ~start:5. ; + RotateMachinePassword.trigger_rotate ~__context ~start:5. ; Winbind.check_ready_to_serve ~timeout:300. ; Winbind.flush_cache () ; - let {service_name; netbios_name; _} = get_domain_info_from_db () in + let {service_name; netbios_name; _} = DomainInfo.of_db ~__context in match netbios_name with | Some name -> ConfigHosts.join ~domain:service_name ~name @@ -1708,5 +1929,6 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct ; on_disable ; on_xapi_initialize ; on_xapi_exit + ; set_ldaps } end diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.mli b/ocaml/xapi/extauth_plugin_ADwinbind.mli index 718b22f5ded..6f0e8d4018e 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.mli +++ b/ocaml/xapi/extauth_plugin_ADwinbind.mli @@ -34,7 +34,7 @@ module AuthADWinbind : sig val methods : Auth_signature.t end (* Expose function to make compiler happy for unittest *) val extract_ou_config : - config_params:(string * string) list -> (string * string) list * string list + config_params:(string * string) list -> string option * string list val domainify_uname : domain:string -> string -> string diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index f4bd5e56701..5f1bdae2fd7 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -2469,6 +2469,19 @@ module AuthenticationCache = struct end end +let ldaps_enabled_in_config ~config = + match List.assoc_opt "ldaps" config with + (* Default to false, true iff v = true (case-insensitive) *) + | Some v when bool_of_string_opt (String.lowercase_ascii v) = Some true -> + true + | _ -> + false + +(* Check if Active Directory external authentication is enabled on a host *) +let is_ad_enabled ~__context ~host = + let auth_type = Db.Host.get_external_auth_type ~__context ~self:host in + auth_type = Xapi_globs.auth_type_AD + (* Simple trie data structure that performs a favoured lookup to implement a simple form of wildcard key matching. The trie is not pruned during (or after) construction. *) diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index eb3e71d7b2b..5fe49e26bb2 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -619,12 +619,6 @@ module VM : HandlerTools = struct else {vm_record with API.vM_has_vendor_device= false} in - (* Always default secureboot_certificates_state to ok in the record - passed to create_from_record -- the actual state will be recomputed - below against the importing pool's certificates. *) - let vm_record = - {vm_record with API.vM_secureboot_certificates_state= `ok} - in let vm_record = { vm_record with @@ -781,19 +775,6 @@ module VM : HandlerTools = struct ) ; Db.VM.set_bios_strings ~__context ~self:vm ~value:vm_record.API.vM_bios_strings ; - (* Always recompute secureboot_certificates_state against the - importing pool's certificates, since the exporting pool's state - is not meaningful here. *) - ( if not vm_record.API.vM_is_default_template then - let state = - ( Xapi_vm_helpers.check_secureboot_certificates_state ~__context - ~self:vm - :> API.vm_secureboot_certificates_state - ) - in - Db.VM.set_secureboot_certificates_state ~__context ~self:vm - ~value:state - ) ; debug "Created VM: %s (was %s)" (Ref.string_of vm) x.id ; (* Although someone could sneak in here and attempt to power on the VM, it doesn't really matter since no VBDs have been created yet. @@ -2254,7 +2235,7 @@ module TarHeaderReader = Tar.HeaderReader (Direct) (BufferOrFile) (** Takes an fd and a function, tries first to read the first tar block and checks for the existence of 'ova.xml'. If that fails then pipe the lot through an appropriate decompressor and try again *) -let with_open_archive fd ?length f = +let with_open_archive fd ?length ?(drain = false) f = (* Read the first header's worth into a buffer *) let buffer = Cstruct.create Tar.Header.length in let retry_with_compression = ref true in @@ -2269,8 +2250,31 @@ let with_open_archive fd ?length f = (* successfully opened uncompressed stream *) retry_with_compression := false ; let xml = read_xml hdr fd in - Tar_helpers.skip fd (Tar.Header.compute_zero_padding_length hdr) ; - f xml fd + let zero_pad = Tar.Header.compute_zero_padding_length hdr in + Tar_helpers.skip fd zero_pad ; + let result = f xml fd in + ( match (length, drain) with + | Some len, true -> ( + (* When [drain] is set, the bytes left after [f] returns (the tar + end-of-archive markers and the trailing record padding) are consumed + off the socket so the whole request body is read and the connection + can be closed cleanly; this must only be used when [f] does not + itself read from the archive after the initial ova.xml. Only the + uncompressed path needs this: on the compressed path the feeder + thread already reads the whole body off [fd], and the trailing + padding left in the decompressor pipe is discarded when the pipe is + closed. *) + let consumed = + Tar.Header.length + Int64.to_int hdr.Tar.Header.file_size + zero_pad + in + let remaining = Int64.to_int len - consumed in + if remaining > 0 then + try Tar_helpers.skip fd remaining with End_of_file -> () + ) + | _ -> + () + ) ; + result with e -> if not !retry_with_compression then raise e ; let decompress = @@ -2466,11 +2470,9 @@ let metadata_handler (req : Request.t) s _ = ] in Http_svr.headers s headers ; - with_open_archive s ?length:req.Request.content_length - (fun metadata s -> + with_open_archive s ?length:req.Request.content_length ~drain:true + (fun metadata _s -> debug "Got XML" ; - (* Skip trailing two zero blocks *) - Tar_helpers.skip s (Tar.Header.length * 2) ; let header = metadata |> Xmlrpc.of_string |> header_of_rpc in assert_compatible ~__context header.version ; if full_restore then diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index de676426936..11ec8730e54 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -975,6 +975,12 @@ functor (pool_uuid ~__context pool) ; Local.Pool.disable_external_auth ~__context ~pool + let external_auth_set_ldaps ~__context ~pool ~ldaps ~force = + info "Pool.external_auth_set_ldaps: pool = '%s'; ldaps = %b; force = %b" + (pool_uuid ~__context pool) + ldaps force ; + Local.Pool.external_auth_set_ldaps ~__context ~pool ~ldaps ~force + let enable_redo_log ~__context ~sr = info "Pool.enable_redo_log: pool = '%s'; sr_uuid = '%s'" (current_pool_uuid ~__context) @@ -1268,6 +1274,21 @@ functor (certificate_uuid ~__context certificate) ; Local.Pool.uninstall_trusted_certificate ~__context ~self ~certificate + let sync_trusted_certificates_from ~__context ~self ~remote_pool + ~remote_session ~remote_certificate ~ca = + Xapi_pool_helpers.with_pool_operation ~__context + ~op:`copy_primary_host_certs + ~doc:"Pool.sync_trusted_certificates_from" + ~self:(Helpers.get_pool ~__context) + @@ fun () -> + info + "Pool.sync_trusted_certificates_from: pool=%S remote_pool=%S \ + remote_certificate=%S ca=%b" + (pool_uuid ~__context self) + remote_pool remote_certificate ca ; + Local.Pool.sync_trusted_certificates_from ~__context ~self ~remote_pool + ~remote_session ~remote_certificate ~ca + let exchange_trusted_certificates_on_join ~__context ~self ~ca ~import ~export = Xapi_pool_helpers.with_pool_operation ~__context @@ -3863,6 +3884,16 @@ functor in do_op_on ~local_fn ~__context ~host ~remote_fn + let external_auth_set_ldaps ~__context ~host ~ldaps ~force = + info "Host.external_auth_set_ldaps: host = '%s'; ldaps = %b; force = %b" + (host_uuid ~__context host) + ldaps force ; + let local_fn = Local.Host.external_auth_set_ldaps ~host ~ldaps ~force in + let remote_fn = + Client.Host.external_auth_set_ldaps ~host ~ldaps ~force + in + do_op_on ~local_fn ~__context ~host ~remote_fn + let install_ca_certificate ~__context ~host ~name ~cert = info "Host.install_ca_certificate: host = '%s'; name = '%s'" (host_uuid ~__context host) @@ -4698,6 +4729,28 @@ functor Client.VIF.configure_ipv6 ~self ~mode ~address ~gateway in forward_vif_op ~local_fn ~__context ~self ~remote_fn + + let add_trunks ~__context ~self ~value = + info "VIF.add_trunks: VIF = '%s'; vlan = '%s'" + (vif_uuid ~__context self) (Int64.to_string value) ; + let local_fn = Local.VIF.add_trunks ~self ~value in + let remote_fn = Client.VIF.add_trunks ~self ~value in + forward_vif_op ~local_fn ~__context ~self ~remote_fn + + let remove_trunks ~__context ~self ~value = + info "VIF.remove_trunks: VIF = '%s'; vlan = '%s'" + (vif_uuid ~__context self) (Int64.to_string value) ; + let local_fn = Local.VIF.remove_trunks ~self ~value in + let remote_fn = Client.VIF.remove_trunks ~self ~value in + forward_vif_op ~local_fn ~__context ~self ~remote_fn + + let set_trunks ~__context ~self ~value = + info "VIF.set_trunks: VIF = '%s'; vlans = '%s'" + (vif_uuid ~__context self) + (String.concat "," (List.map Int64.to_string value)) ; + let local_fn = Local.VIF.set_trunks ~self ~value in + let remote_fn = Client.VIF.set_trunks ~self ~value in + forward_vif_op ~local_fn ~__context ~self ~remote_fn end module VIF_metrics = struct end @@ -5694,6 +5747,17 @@ functor forward_vdi_op ~local_fn ~__context ~self:vdi ~remote_fn ) + let resize_online ~__context ~vdi ~size = + info "VDI.resize_online: VDI = '%s'; size = %Ld" + (vdi_uuid ~__context vdi) size ; + let local_fn = Local.VDI.resize_online ~vdi ~size in + let remote_fn = Client.VDI.resize_online ~vdi ~size in + let sR = Db.VDI.get_SR ~__context ~self:vdi in + with_sr_andor_vdi ~__context ~sr:(sR, `vdi_resize) + ~vdi:(vdi, `resize_online) ~doc:"VDI.resize_online" (fun () -> + forward_vdi_op ~local_fn ~__context ~self:vdi ~remote_fn + ) + let generate_config ~__context ~host ~vdi = info "VDI.generate_config: VDI = '%s'; host = '%s'" (vdi_uuid ~__context vdi) @@ -6951,6 +7015,9 @@ functor in Xapi_pool_helpers.call_fn_on_slaves_then_master ~__context fn end + + module Caller = Xapi_caller + module Rate_limit = Xapi_rate_limit end (* for unit tests *) diff --git a/ocaml/xapi/nm.ml b/ocaml/xapi/nm.ml index a2aeb72d55f..6a73a0d04bf 100644 --- a/ocaml/xapi/nm.ml +++ b/ocaml/xapi/nm.ml @@ -537,7 +537,15 @@ let bring_pif_up ~__context ?(management_interface = false) (pif : API.ref_PIF) let bond_record = Db.Bond.get_record ~__context ~self:bond in List.iter (fun self -> - Db.PIF.set_currently_attached ~__context ~self ~value:false + Db.PIF.set_currently_attached ~__context ~self ~value:false ; + let slave_net = Db.PIF.get_network ~__context ~self in + let bond_mtu = net_rc.API.network_MTU in + if Db.Network.get_MTU ~__context ~self:slave_net <> bond_mtu + then ( + debug "Setting MTU of slave network MTU to %Ld" bond_mtu ; + Db.Network.set_MTU ~__context ~self:slave_net + ~value:bond_mtu + ) ) bond_record.API.bond_slaves ; maybe_update_master_pif_mac ~__context bond_record rc pif diff --git a/ocaml/xapi/server_helpers.ml b/ocaml/xapi/server_helpers.ml index 17657c752f6..326e47ee463 100644 --- a/ocaml/xapi/server_helpers.ml +++ b/ocaml/xapi/server_helpers.ml @@ -185,20 +185,50 @@ let do_dispatch ?session_id ?forward_op ?self:_ supports_async called_fn_name ~marshaller op_fn ) () - ) ; - (* Return task id immediately *) - Rpc.success (API.rpc_of_ref_task (Context.get_task_id __context)) + ) in - match sync_ty with - | `Sync -> - sync () - | `Async -> - let need_complete = not (Context.forwarded_task __context) in - async ~need_complete - | `InternalAsync -> - async ~need_complete:true - -(* regardless of forwarding, we are expected to complete the task *) + let handle_request_internal () = + match sync_ty with + | `Sync -> + sync () + | `Async -> + let need_complete = not (Context.forwarded_task __context) in + async ~need_complete ; + Rpc.success (API.rpc_of_ref_task (Context.get_task_id __context)) + | `InternalAsync -> + async ~need_complete:true ; + Rpc.success (API.rpc_of_ref_task (Context.get_task_id __context)) + in + let handle_request_external () = + let token_cost = Xapi_caller.get_token_cost called_fn_name in + let user_agent = Option.value http_req.user_agent ~default:"" in + let client_ip = + Option.value (Context.get_client_ip __context) ~default:"" + in + match sync_ty with + | `Sync -> + Xapi_caller.submit_sync + ?parent:(Context.tracing_of __context) + ~user_agent ~client_ip ~callback:sync + ~task_create:(fun f -> f __context) + token_cost + | `Async -> + let need_complete = not (Context.forwarded_task __context) in + Xapi_caller.submit_async + ?parent:(Context.tracing_of __context) + ~user_agent ~client_ip + ~callback:(fun () -> async ~need_complete) + ~task_create:(fun f -> f __context) + token_cost ; + Rpc.success (API.rpc_of_ref_task (Context.get_task_id __context)) + | `InternalAsync -> + async ~need_complete:true ; + Rpc.success (API.rpc_of_ref_task (Context.get_task_id __context)) + in + if Context.is_internal_origin __context then + handle_request_internal () + else + handle_request_external () (* in the following functions, it is our responsibility to complete any tasks we create *) let exec_with_new_task ?http_other_config ?quiet ?subtask_of ?session_id diff --git a/ocaml/xapi/sparse_dd_wrapper.ml b/ocaml/xapi/sparse_dd_wrapper.ml index c7d8992830d..dba82aae448 100644 --- a/ocaml/xapi/sparse_dd_wrapper.ml +++ b/ocaml/xapi/sparse_dd_wrapper.ml @@ -122,7 +122,7 @@ let dd_internal progress_cb base prezeroed verify_cert ?(proto = None) infile ; "-size" ; Int64.to_string size ; "-good-ciphersuites" - ; Constants.good_ciphersuites + ; Tls_policy.Openssl.default_ciphers ] ; ( if prezeroed then ["-prezeroed"] diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 1dc8695a031..c487b748792 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -766,6 +766,24 @@ module Mux = struct end)) in C.VDI.remove_from_sm_config (Debug_info.to_string di) sr vdi key + let add_tags () ~dbg ~sr ~vdi ~key = + with_dbg ~name:"VDI.add_tags" ~dbg @@ fun di -> + info "VDI.add_tags dbg:%s sr:%s vdi:%s key:%s" dbg (s_of_sr sr) + (s_of_vdi vdi) key ; + let module C = StorageAPI (Idl.Exn.GenClient (struct + let rpc = of_sr sr + end)) in + C.VDI.add_tags (Debug_info.to_string di) sr vdi key + + let remove_tags () ~dbg ~sr ~vdi ~key = + with_dbg ~name:"VDI.remove_tags" ~dbg @@ fun di -> + info "VDI.remove_tags dbg:%s sr:%s vdi:%s key:%s" dbg (s_of_sr sr) + (s_of_vdi vdi) key ; + let module C = StorageAPI (Idl.Exn.GenClient (struct + let rpc = of_sr sr + end)) in + C.VDI.remove_tags (Debug_info.to_string di) sr vdi key + let get_url () ~dbg ~sr ~vdi = with_dbg ~name:"VDI.get_url" ~dbg @@ fun di -> info "VDI.get_url dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; @@ -899,35 +917,31 @@ module Mux = struct Storage_interface.unimplemented __FUNCTION__ (* see storage_smapi{v1,v3}_migrate.ml *) - let receive_start () ~dbg ~sr ~vdi_info ~id ~image_format ~similar = + let receive_start () ~dbg ~sr ~vdi_info ~id ~similar = with_dbg ~name:"DATA.MIRROR.receive_start" ~dbg @@ fun _di -> - info - "%s dbg: %s sr: %s vdi_info: %s mirror_id: %s image_format: %s \ - similar: %s" + info "%s dbg: %s sr: %s vdi_info: %s mirror_id: %s similar: %s" __FUNCTION__ dbg (s_of_sr sr) (string_of_vdi_info vdi_info) - id image_format + id (String.concat ";" similar) ; (* This goes straight to storage_smapiv1_migrate for backwards compatability reasons, new code should not call receive_start any more *) Storage_smapiv1_migrate.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id - ~image_format ~similar + ~similar - let receive_start2 () ~dbg ~sr ~vdi_info ~id ~image_format ~similar ~vm = + let receive_start2 () ~dbg ~sr ~vdi_info ~id ~similar ~vm = with_dbg ~name:"DATA.MIRROR.receive_start2" ~dbg @@ fun _di -> - info - "%s dbg: %s sr: %s vdi_info: %s mirror_id: %s image_format: %s \ - similar: %s vm: %s" + info "%s dbg: %s sr: %s vdi_info: %s mirror_id: %s similar: %s vm: %s" __FUNCTION__ dbg (s_of_sr sr) (string_of_vdi_info vdi_info) - id image_format + id (String.concat ";" similar) (s_of_vm vm) ; info "%s dbg:%s" __FUNCTION__ dbg ; (* This goes straight to storage_smapiv1_migrate for backwards compatability reasons, new code should not call receive_start any more *) Storage_smapiv1_migrate.MIRROR.receive_start2 () ~dbg ~sr ~vdi_info ~id - ~image_format ~similar ~vm + ~similar ~vm (** see storage_smapiv{1,3}_migrate.receive_start3 *) let receive_start3 () ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index 23c6492441c..69a9954112b 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -80,6 +80,7 @@ let vdi_info_of_vdi_rec __context vdi_rec = ; persistent= vdi_rec.API.vDI_on_boot = `persist ; sharable= vdi_rec.API.vDI_sharable ; sm_config= vdi_rec.API.vDI_sm_config + ; tags= vdi_rec.API.vDI_tags } let redirect _sr = @@ -1056,6 +1057,28 @@ module SMAPIv1 : Server_impl = struct Db.VDI.remove_from_sm_config ~__context ~self ~key ) + let add_tags _context ~dbg ~sr ~vdi ~key = + with_dbg ~name:"VDI.add_to_tags" ~dbg @@ fun di -> + info "VDI.add_tags dbg:%s sr:%s vdi:%s key:[%s]" di.log (s_of_sr sr) + (s_of_vdi vdi) key ; + let dbg = Debug_info.to_string di in + Server_helpers.exec_with_new_task "VDI.add_tags" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi, _ = find_vdi ~__context sr vdi in + Db.VDI.add_tags ~__context ~self:vdi ~value:key + ) + + let remove_tags _context ~dbg ~sr ~vdi ~key = + with_dbg ~name:"VDI.remove_tags" ~dbg @@ fun di -> + info "VDI.remove_tags dbg:%s sr:%s vdi:%s key:%s" di.log (s_of_sr sr) + (s_of_vdi vdi) key ; + let dbg = Debug_info.to_string di in + Server_helpers.exec_with_new_task "VDI.remove_tags" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let self = find_vdi ~__context sr vdi |> fst in + Db.VDI.remove_tags ~__context ~self ~value:key + ) + let get_url _context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.get_url" ~dbg @@ fun di -> info "VDI.get_url dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; @@ -1173,12 +1196,11 @@ module SMAPIv1 : Server_impl = struct ~remote_mirror:_ ~dest_sr:_ ~verify_dest:_ = assert false - let receive_start _context ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~image_format:_ - ~similar:_ = + let receive_start _context ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ = assert false - let receive_start2 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~image_format:_ - ~similar:_ ~vm:_ = + let receive_start2 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ + ~vm:_ = assert false let receive_start3 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ diff --git a/ocaml/xapi/storage_smapiv1_migrate.ml b/ocaml/xapi/storage_smapiv1_migrate.ml index 12684fdcb19..8f63cebe000 100644 --- a/ocaml/xapi/storage_smapiv1_migrate.ml +++ b/ocaml/xapi/storage_smapiv1_migrate.ml @@ -650,6 +650,11 @@ module MIRROR : SMAPIv2_MIRROR = struct add_to_sm_config vdi_info "image-format" fmt in let leaf = SMAPI.VDI.create dbg sr vdi_info in + + List.iter + (fun tag -> Local.VDI.add_tags dbg sr leaf.vdi tag) + vdi_info.tags ; + D.info "Created leaf VDI for mirror receive: %s" (string_of_vdi_info leaf) ; on_fail := (fun () -> SMAPI.VDI.destroy dbg sr leaf.vdi) :: !on_fail ; (* dummy VDI is created so that the leaf VDI becomes a differencing disk, @@ -757,21 +762,19 @@ module MIRROR : SMAPIv2_MIRROR = struct !on_fail ; raise e - let receive_start _ctx ~dbg ~sr ~vdi_info ~id ~image_format ~similar = - D.debug "%s dbg: %s sr: %s vdi: %s id: %s image_format: %s" __FUNCTION__ dbg - (s_of_sr sr) + let receive_start _ctx ~dbg ~sr ~vdi_info ~id ~similar = + D.debug "%s dbg: %s sr: %s vdi: %s id: %s" __FUNCTION__ dbg (s_of_sr sr) (string_of_vdi_info vdi_info) - id image_format ; - receive_start_common ~dbg ~sr ~vdi_info ~id ~image_format ~similar + id ; + receive_start_common ~dbg ~sr ~vdi_info ~id ~image_format:"" ~similar ~vm:(Vm.of_string "0") ~url:"" ~verify_dest:false (module Local) - let receive_start2 _ctx ~dbg ~sr ~vdi_info ~id ~image_format ~similar ~vm = - D.debug "%s dbg: %s sr: %s vdi: %s id: %s image_format: %s" __FUNCTION__ dbg - (s_of_sr sr) + let receive_start2 _ctx ~dbg ~sr ~vdi_info ~id ~similar ~vm = + D.debug "%s dbg: %s sr: %s vdi: %s id: %s" __FUNCTION__ dbg (s_of_sr sr) (string_of_vdi_info vdi_info) - id image_format ; - receive_start_common ~dbg ~sr ~vdi_info ~id ~image_format ~similar ~vm + id ; + receive_start_common ~dbg ~sr ~vdi_info ~id ~image_format:"" ~similar ~vm ~url:"" ~verify_dest:false (module Local) diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 3bc6eed4652..84be65f2929 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -924,6 +924,20 @@ functor let dbg = Debug_info.to_string di in Impl.VDI.remove_from_sm_config context ~dbg ~sr ~vdi ~key + let add_tags context ~dbg ~sr ~vdi ~key = + with_dbg ~name:"VDI.add_tags" ~dbg @@ fun di -> + info "VDI.add_tags dbg:%s sr:%s vdi:%s key:%s" di.log (s_of_sr sr) + (s_of_vdi vdi) key ; + let dbg = Debug_info.to_string di in + Impl.VDI.add_tags context ~dbg ~sr ~vdi ~key + + let remove_tags context ~dbg ~sr ~vdi ~key = + with_dbg ~name:"VDI.remove_tags" ~dbg @@ fun di -> + info "VDI.remove_tags dbg:%s sr:%s vdi:%s key:%s" di.log (s_of_sr sr) + (s_of_vdi vdi) key ; + let dbg = Debug_info.to_string di in + Impl.VDI.remove_tags context ~dbg ~sr ~vdi ~key + let get_url context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.get_url" ~dbg @@ fun di -> info "VDI.get_url dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; @@ -1227,26 +1241,20 @@ functor ~remote_mirror:_ ~dest_sr:_ ~verify_dest:_ = Storage_interface.unimplemented __FUNCTION__ - let receive_start context ~dbg ~sr ~vdi_info ~id ~image_format ~similar - = - info - "DATA.MIRROR.receive_start dbg:%s sr:%s id:%s image_format:%s \ - similar:[%s]" - dbg (s_of_sr sr) id image_format + let receive_start context ~dbg ~sr ~vdi_info ~id ~similar = + info "DATA.MIRROR.receive_start dbg:%s sr:%s id:%s similar:[%s]" dbg + (s_of_sr sr) id (String.concat "," similar) ; - Impl.DATA.MIRROR.receive_start context ~dbg ~sr ~vdi_info ~id - ~image_format ~similar + Impl.DATA.MIRROR.receive_start context ~dbg ~sr ~vdi_info ~id ~similar - let receive_start2 context ~dbg ~sr ~vdi_info ~id ~image_format ~similar - ~vm = + let receive_start2 context ~dbg ~sr ~vdi_info ~id ~similar ~vm = info - "DATA.MIRROR.receive_start2 dbg:%s sr:%s id:%s image_format:%s \ - similar:[%s] vm:%s" - dbg (s_of_sr sr) id image_format + "DATA.MIRROR.receive_start2 dbg:%s sr:%s id:%s similar:[%s] vm:%s" + dbg (s_of_sr sr) id (String.concat "," similar) (s_of_vm vm) ; Impl.DATA.MIRROR.receive_start2 context ~dbg ~sr ~vdi_info ~id - ~image_format ~similar ~vm + ~similar ~vm let receive_start3 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ ~image_format:_ ~similar:_ ~vm:_ = diff --git a/ocaml/xapi/storage_smapiv3_migrate.ml b/ocaml/xapi/storage_smapiv3_migrate.ml index fd30cd21a70..2bff094e844 100644 --- a/ocaml/xapi/storage_smapiv3_migrate.ml +++ b/ocaml/xapi/storage_smapiv3_migrate.ml @@ -190,12 +190,10 @@ module MIRROR : SMAPIv2_MIRROR = struct ) ) - let receive_start _ctx ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~image_format:_ - ~similar:_ = + let receive_start _ctx ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ = Storage_interface.unimplemented __FUNCTION__ - let receive_start2 _ctx ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~image_format:_ - ~similar:_ ~vm:_ = + let receive_start2 _ctx ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ ~vm:_ = Storage_interface.unimplemented __FUNCTION__ let receive_start3 _ctx ~dbg ~sr ~vdi_info ~mirror_id ~image_format ~similar:_ diff --git a/ocaml/xapi/vm_sysprep.ml b/ocaml/xapi/vm_sysprep.ml index ae6b62276a4..80f14ebe6c4 100644 --- a/ocaml/xapi/vm_sysprep.ml +++ b/ocaml/xapi/vm_sysprep.ml @@ -72,12 +72,27 @@ module SR = struct end (** This is called on xapi startup. Opportunity to set up or clean up. - We destroy all VDIs that are unused. *) + We destroy all VDIs that are unused. If the SR's backing directory doesn't + exist, it should be forgotten completely. *) let on_startup ~__context = let host = Helpers.get_localhost ~__context in let hostname = Db.Host.get_hostname ~__context ~self:host in - match SR.find_opt ~__context ~label:(SR.name hostname) with - | Some sr when !Xapi_globs.vm_sysprep_enabled -> ( + let sr = SR.find_opt ~__context ~label:(SR.name hostname) in + match (Sys.file_exists SR.dir, sr) with + | false, Some sr -> + info "%s: %s doesn't exist; forgetting sysprep SR %s" __FUNCTION__ SR.dir + (Ref.string_of sr) ; + (* On a host reboot the PBDs are unplugged, and can't be plugged again + because the SR directory doesn't exist, so the cleanup always + succeeds. On a xapi restart (the host stays up) the PBDs may still be + attached, and unplugging here can race with the other PBD-plugging + tasks in the startup sequence; failing to clean up in that case is + acceptable. *) + call ~__context @@ fun rpc session_id -> + Db.SR.get_PBDs ~__context ~self:sr + |> List.iter (fun self -> Client.PBD.unplug ~rpc ~session_id ~self) ; + Client.SR.forget ~rpc ~session_id ~sr + | true, Some sr -> ( Db.SR.get_VDIs ~__context ~self:sr |> List.iter @@ fun self -> match Db.VDI.get_record ~__context ~self with diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 193d7475b72..f0fb93463db 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -887,11 +887,9 @@ let listen_unix_socket sock_path = Unixext.mkdir_safe (Filename.dirname sock_path) 0o700 ; Unixext.unlink_safe sock_path ; let domain_sock = Xapi_http.bind (Unix.ADDR_UNIX sock_path) in - ignore - (Http_svr.start - ~conn_limit:!Xapi_globs.conn_limit_unix - Xapi_http.server domain_sock - ) + Http_svr.start + ~conn_limit:!Xapi_globs.conn_limit_unix + Xapi_http.server domain_sock let set_stunnel_timeout () = try @@ -1108,7 +1106,6 @@ let server_init () = , [Startup.OnlyMaster] , Storage_access.start_smapiv1_servers ) - ; ("Starting SM service", [], Storage_access.start) ; ("Starting SM xapi event service", [], Storage_access.events_from_sm) ; ("Killing stray sparse_dd processes", [], Sparse_dd_wrapper.killall) ; ( "Registering http handlers" @@ -1172,6 +1169,14 @@ let server_init () = , [] , fun () -> report_tls_verification ~__context ) + ; ( "Registering rate limits" + , [Startup.OnlyMaster] + , fun () -> Xapi_rate_limit.register ~__context + ) + ; ( "Registering callers" + , [Startup.OnlyMaster] + , fun () -> Xapi_caller.register ~__context + ) ; ( "Remote requests" , [Startup.OnThread] , Remote_requests.handle_requests @@ -1254,7 +1259,16 @@ let server_init () = ) ; Startup.run ~__context [ - ("Checking emergency network reset", [], check_network_reset) + (* SM must listen on org.xen.xapi.storage after dbsync. Registering the queue + earlier means a message from deamon like xenopsd (which restarts and reposts + pending operations, e.g. a DP.destroy) is handled immediatly and can take a + per-VDI lock that can deadlocks refresh_local_vdi_activations during dbsync. + Messages stay safely queued in message-switch until we register here. Dbsync + itself doesn't need the queue since internal storage calls go directly through + Storage_mux.Server.process. + *) + ("Starting SM service", [], Storage_access.start) + ; ("Checking emergency network reset", [], check_network_reset) ; ( "Upgrade bonds to Boston" , [Startup.NoExnRaising] , Sync_networking.fix_bonds ~__context diff --git a/ocaml/xapi/xapi_caller.ml b/ocaml/xapi/xapi_caller.ml new file mode 100644 index 00000000000..bbc69882d50 --- /dev/null +++ b/ocaml/xapi/xapi_caller.ml @@ -0,0 +1,804 @@ +(* + * Copyright (C) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module D = Debug.Make (struct let name = "xapi_caller" end) + +open D +module Rate_limit = Rate_limit_lib.Rate_limit +module Caller_table = Rate_limit_lib.Caller_table +module Caller_statistics = Rate_limit_lib.Caller_statistics +module Config_file = Xcp_service.Config_file +module Unixext = Xapi_stdext_unix.Unixext + +(* Monotonically increasing logical clock, bumped once per matched call. Each + entry records the value it last saw in [last_call]; the smallest value + therefore identifies the caller with the least recent call. A single atomic + fetch-and-add per call keeps the dispatch path lock-free - we deliberately + avoid a real time source (and its dependency) here since only the relative + ordering matters for eviction. *) +let call_sequence = Atomic.make 0 + +let next_call_sequence () = Atomic.fetch_and_add call_sequence 1 + +(** A single in-memory caller_table entry. The pattern_key is the table's + primary key; [caller_ref] records which DB row this entry mirrors; + [stats] tracks call counts and token use since startup; + [rate_limit_ref] points at the rate-limit row (Ref.null when none), + resolved to a live bucket via [Xapi_rate_limit.find_bucket] at dispatch + time; [auto_registered] is true for callers created by [maybe_autocreate] + rather than by an administrator; [last_call] is the [call_sequence] value + seen on this caller's most recent call, used to pick the eviction victim; + [groups] mirrors the caller's DB [groups] field so the RRD reporter can + aggregate usage per group without touching the database. *) +type entry = { + caller_ref: API.ref_Caller + ; pattern_key: Caller_table.Key.pattern_key + ; stats: Caller_statistics.t + ; rate_limit_ref: API.ref_Rate_limit + ; auto_registered: bool + ; last_call: int Atomic.t + ; groups: string list +} + +let caller_table : entry Caller_table.t = Caller_table.create () + +(* Number of auto-registered entries currently in [caller_table]. Mutated only + under [caller_table_mutex] (or single-threaded in [register]) so it stays in + step with the table. Lets [maybe_autocreate] decide in O(1) whether the cap + has been reached without scanning the table. *) +let auto_registered_count = ref 0 + +(* Serialises ALL mutations of [caller_table] on the master. Caller_table + itself uses Atomic for lock-free reads, but its writers are non-CAS + Atomic.get/set pairs and its higher-level "delete then insert" refresh + is not atomic - two concurrent refreshes for the same caller can + otherwise interleave so that the later insert is silently refused + as a duplicate, leaving the table with stale state. Held around + create/destroy/refresh_caller_rate_limit and the auto-create path. + NOT held by [register] because that runs single-threaded at startup. *) +let caller_table_mutex = Mutex.create () + +let with_caller_table_mutex f = + Mutex.lock caller_table_mutex ; + Fun.protect ~finally:(fun () -> Mutex.unlock caller_table_mutex) f + +let pattern_of_db_string : string -> Caller_table.Key.match_pattern = + fun s -> + let len = String.length s in + if len = 0 then + Caller_table.Key.Prefix "" + else if s.[len - 1] = '*' then + Caller_table.Key.Prefix (String.sub s 0 (len - 1)) + else + Caller_table.Key.Full s + +let pattern_key_of_record (record : API.caller_t) : Caller_table.Key.pattern_key + = + Caller_table.Key. + { + user_agent_pattern= pattern_of_db_string record.caller_user_agent + ; client_ip_pattern= pattern_of_db_string record.caller_client_ip + } + +let pattern_key_of_fields ~user_agent ~client_ip : Caller_table.Key.pattern_key + = + Caller_table.Key. + { + user_agent_pattern= pattern_of_db_string user_agent + ; client_ip_pattern= pattern_of_db_string client_ip + } + +let target_of_request ~user_agent ~client_ip : Caller_table.Key.t = + Caller_table.Key.{user_agent; client_ip} + +(** A pattern is "fully specified" when neither field is a wildcard prefix. + Auto-create only triggers if no fully-specified match is found. *) +let pattern_fully_specified + ({user_agent_pattern; client_ip_pattern} : Caller_table.Key.pattern_key) = + let open Caller_table.Key in + let field_full = function Full _ -> true | Prefix _ -> false in + field_full user_agent_pattern && field_full client_ip_pattern + +let any_fully_specified entries = + List.exists (fun e -> pattern_fully_specified e.pattern_key) entries + +let validate_request_fields ~user_agent ~client_ip = + if user_agent = "" && client_ip = "" then + raise + Api_errors.( + Server_error + ( invalid_value + , [ + "user_agent/client_ip" + ; "at least one of user_agent or client_ip must be set" + ] + ) + ) + +(* All [insert_entry_locked] callers must hold [caller_table_mutex], except + [register] which runs single-threaded at startup. Does not touch + [auto_registered_count]; the create/destroy helpers own that counter so a + delete-then-insert refresh does not perturb it. A freshly inserted entry is + stamped with the current [call_sequence] so a just-registered caller is + treated as recently used rather than an immediate eviction candidate. *) +let insert_entry_locked ~caller_ref ~stats ~pattern_key ~rate_limit_ref + ~auto_registered ~groups ?last_call () = + let last_call = + match last_call with + | Some v -> + v + | None -> + Atomic.make (next_call_sequence ()) + in + let entry = + { + caller_ref + ; pattern_key + ; stats + ; rate_limit_ref + ; auto_registered + ; last_call + ; groups + } + in + if not (Caller_table.insert caller_table ~pattern:pattern_key entry) then + debug + "Caller_table.insert refused entry (duplicate or all-wildcard) for \ + caller %s" + (Ref.string_of caller_ref) + +(* Promote an auto-registered entry to an administrator-owned one: an explicit + admin action (creating a caller for the same pattern, or attaching a + rate-limit rule) has taken ownership of it, so it should no longer count + against the auto-registration cap or be a candidate for LRU eviction. + Assumes [caller_table_mutex] is held and that [entry] is the live table entry + for its pattern with [auto_registered = true]. Preserves the existing stats + and recency stamp across the swap. *) +let promote_entry_locked ~__context entry = + Db.Caller.set_auto_registered ~__context ~self:entry.caller_ref ~value:false ; + decr auto_registered_count ; + Caller_table.delete caller_table ~pattern:entry.pattern_key ; + insert_entry_locked ~caller_ref:entry.caller_ref ~stats:entry.stats + ~pattern_key:entry.pattern_key ~rate_limit_ref:entry.rate_limit_ref + ~auto_registered:false ~groups:entry.groups ~last_call:entry.last_call () + +(* Body of [create]; assumes [caller_table_mutex] is held and that + [pattern_key] has already been validated. [auto_registered] marks whether the + new row is created by the rate limiter (subject to the cap) or by an + administrator. *) +let create_locked ~__context ~name_label ~name_description ~user_agent + ~client_ip ~pattern_key ~auto_registered = + match Caller_table.get_exact caller_table ~pattern:pattern_key with + | Some entry -> + (* Idempotent: an in-memory entry already mirrors this pattern. Update + the DB-side name fields and return the existing ref. *) + Db.Caller.set_name_label ~__context ~self:entry.caller_ref + ~value:name_label ; + Db.Caller.set_name_description ~__context ~self:entry.caller_ref + ~value:name_description ; + (* An explicit admin [create] for a pattern already held by an + auto-registered caller takes ownership of it. *) + if (not auto_registered) && entry.auto_registered then + promote_entry_locked ~__context entry ; + entry.caller_ref + | None -> + let uuid = Uuidx.(to_string (make () : [`Caller] t)) in + let ref = Ref.make () in + Db.Caller.create ~__context ~ref ~uuid ~name_label ~name_description + ~user_agent ~client_ip ~last_access:Clock.Date.epoch ~groups:[] + ~rate_limit:Ref.null ~auto_registered ; + insert_entry_locked ~caller_ref:ref + ~stats:(Caller_statistics.create ~caller_uuid:uuid) + ~pattern_key ~rate_limit_ref:Ref.null ~auto_registered ~groups:[] () ; + if auto_registered then incr auto_registered_count ; + ref + +let create ~__context ~name_label ~name_description ~user_agent ~client_ip = + validate_request_fields ~user_agent ~client_ip ; + let pattern_key = pattern_key_of_fields ~user_agent ~client_ip in + if Caller_table.Key.is_all_wildcard pattern_key then + raise + Api_errors.( + Server_error + ( invalid_value + , ["user_agent/client_ip"; "all-wildcard pattern not allowed"] + ) + ) ; + with_caller_table_mutex (fun () -> + create_locked ~__context ~name_label ~name_description ~user_agent + ~client_ip ~pattern_key ~auto_registered:false + ) + +(* Body of [destroy]; assumes [caller_table_mutex] is held. Also used by the + eviction path. Keeps [auto_registered_count] in step with the table. *) +let destroy_locked ~__context ~self = + let record = Db.Caller.get_record ~__context ~self in + let pattern_key = pattern_key_of_record record in + ( match Caller_table.get_exact caller_table ~pattern:pattern_key with + | Some entry when entry.auto_registered -> + decr auto_registered_count + | _ -> + () + ) ; + Caller_table.delete caller_table ~pattern:pattern_key ; + Db.Caller.destroy ~__context ~self + +let destroy ~__context ~self = + with_caller_table_mutex (fun () -> destroy_locked ~__context ~self) + +let entries_of_table () = Caller_table.to_list caller_table |> List.map snd + +let find_entry_by_ref self = + entries_of_table () |> List.find_opt (fun entry -> entry.caller_ref = self) + +let query_token_usage ~__context:_ ~self = + match find_entry_by_ref self with + | None -> + 0.0 + | Some entry -> + Caller_statistics.get_token_count entry.stats + +let query_call_count ~__context:_ ~self = + match find_entry_by_ref self with + | None -> + 0L + | Some entry -> + Int64.of_int (Caller_statistics.get_call_count entry.stats) + +(* Entries for every caller currently assigned to [group]. Raises if the group + name is empty. *) +let group_entries ~__context ~group = + if group = "" then + raise + Api_errors.(Server_error (invalid_value, ["group"; "empty group name"])) ; + let in_group entry = + try List.mem group (Db.Caller.get_groups ~__context ~self:entry.caller_ref) + with _ -> false + in + entries_of_table () |> List.filter in_group + +let query_group_token_usage ~__context ~group = + group_entries ~__context ~group + |> List.fold_left + (fun tot entry -> tot +. Caller_statistics.get_token_count entry.stats) + 0.0 + +let query_group_call_count ~__context ~group = + group_entries ~__context ~group + |> List.fold_left + (fun tot entry -> + Int64.add tot + (Int64.of_int (Caller_statistics.get_call_count entry.stats)) + ) + 0L + +let query_all_usage ~__context = + entries_of_table () + |> List.filter_map (fun entry -> + let tokens = Caller_statistics.get_token_count entry.stats in + let calls = float_of_int (Caller_statistics.get_call_count entry.stats) in + let uuid, name_label = + try + let record = Db.Caller.get_record ~__context ~self:entry.caller_ref in + (record.API.caller_uuid, record.API.caller_name_label) + with _ -> (Caller_statistics.get_uuid entry.stats, "") + in + Some (uuid, name_label, tokens, calls) + ) + |> List.sort (fun (_, _, t1, _) (_, _, t2, _) -> compare t2 t1) + |> List.map (fun (uuid, name_label, tokens, calls) -> + [ + uuid + ; name_label + ; Printf.sprintf "%.3f" tokens + ; Printf.sprintf "%.0f" calls + ] + ) + +(** Re-read the caller's record from DB and rebuild its in-memory entry. Called + by Xapi_rate_limit whenever the caller's rate_limit field changes, and + whenever its group membership changes. + + Held under [caller_table_mutex] so the DB read + delete + insert are + seen as one step: concurrent refreshes for the same caller can + otherwise both start from the DB state seen before either mutation, + and the later insert then silently loses to the earlier one. + + User_agent and client_ip are StaticRO in the datamodel, so a caller's + pattern_key never changes; we preserve the existing [stats] and recency + stamp across the swap so that attaching or detaching a rate_limit (or + changing groups) doesn't reset the "calls / tokens since Xapi startup" + counters. The rate_limit ref and group membership are taken from the freshly + read record; the auto-registered flag likewise, except that attaching a + rate-limit rule to an auto-registered caller promotes it (see below). *) +let refresh_caller_entry ~__context caller_ref = + with_caller_table_mutex (fun () -> + match + try Some (Db.Caller.get_record ~__context ~self:caller_ref) + with _ -> None + with + | None -> + () + | Some record -> + let pattern_key = pattern_key_of_record record in + let existing = + Caller_table.get_exact caller_table ~pattern:pattern_key + in + let stats, last_call = + match existing with + | Some existing -> + (existing.stats, Some existing.last_call) + | None -> + (Caller_statistics.create ~caller_uuid:record.caller_uuid, None) + in + (* Attaching a rate-limit rule is an explicit admin action: promote an + auto-registered caller so it is no longer subject to the + auto-registration cap or LRU eviction. This is the one refresh path + where the flag can flip true -> false, so keep + [auto_registered_count] in step here - both the delete below and + [insert_entry_locked] leave the counter untouched. *) + let promote = + record.API.caller_auto_registered + && record.API.caller_rate_limit <> Ref.null + in + let auto_registered = + record.API.caller_auto_registered && not promote + in + if promote then ( + Db.Caller.set_auto_registered ~__context ~self:caller_ref + ~value:false ; + match existing with + | Some e when e.auto_registered -> + decr auto_registered_count + | _ -> + () + ) ; + Caller_table.delete caller_table ~pattern:pattern_key ; + insert_entry_locked ~caller_ref ~stats ~pattern_key + ~rate_limit_ref:record.API.caller_rate_limit ~auto_registered + ~groups:record.API.caller_groups ?last_call () + ) + +(* Group names are administrator-supplied and flow verbatim into RRD data source + names (see [make_group_dss]), so constrain them at the point of entry: + restrict to characters that are safe in a data source name, and bound the + length so a single group cannot blow the reporter's per-data-source size + estimate (see [reporter_bytes_per_ds]) and reintroduce the "not enough + memory" failure. Rejecting bad names here (rather than mangling them at report + time) also keeps names collision-free, so distinct groups never merge into one + data source. *) +let max_group_name_length = 64 + +let valid_group_name_char = function + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '-' | '.' -> + true + | _ -> + false + +let validate_group_name group = + let invalid reason = + raise Api_errors.(Server_error (invalid_value, ["group"; reason])) + in + if group = "" then invalid "empty group name" ; + if String.length group > max_group_name_length then + invalid + (Printf.sprintf "group name must be at most %d characters" + max_group_name_length + ) ; + if not (String.for_all valid_group_name_char group) then + invalid + "group name may only contain alphanumerics and '_', '-' or '.' characters" + +let add_group ~__context ~self ~group = + validate_group_name group ; + Db.Caller.add_groups ~__context ~self ~value:group ; + (* Keep the in-memory entry's [groups] in step so the RRD reporter aggregates + correctly. *) + refresh_caller_entry ~__context self + +let remove_group ~__context ~self ~group = + Db.Caller.remove_groups ~__context ~self ~value:group ; + refresh_caller_entry ~__context self + +(* Install the caller_table refresh callback at module load time. The API + server can accept requests before [register] runs, and any + [Rate_limit.add_caller] that lands in that window would otherwise leave + the caller_table entry with rate_limit_ref = Ref.null (because + [notify_caller_changed] would fall through to the default no-op). *) +let () = Xapi_rate_limit.set_caller_refresh_callback refresh_caller_entry + +(* One token corresponds to a cheap DB read; expensive services cost multiples. + The costs are loaded at startup from [Xapi_globs.call_costs_file], one + "Class.method = cost" per line (key=value, '#' comments), so the values can be + tweaked and new calls added without recompiling xapi. Calls without an entry + fall back to [default_token_cost]. *) +let token_costs : (string, float) Hashtbl.t = Hashtbl.create 256 + +let default_token_cost = 1. + +let add_cost_line line = + match Config_file.parse_line line with + | Some (name, value) -> ( + match float_of_string_opt (String.trim value) with + | Some cost -> + Hashtbl.replace token_costs name cost + | None -> + warn "Ignoring call cost for %s: %S is not a number" name value + ) + | None -> + () + +(* Reload [token_costs] from [path]. On any failure the table is left empty and + every call falls back to [default_token_cost]. *) +let load_token_costs ?(path = !Xapi_globs.call_costs_file) () = + Hashtbl.reset token_costs ; + ( try Unixext.file_lines_iter add_cost_line path + with e -> + warn + "Could not load call costs from %s (%s); all calls will use the \ + default cost of %g" + path (Printexc.to_string e) default_token_cost + ) ; + debug "Loaded %d call costs from %s" (Hashtbl.length token_costs) path + +let get_token_cost name = + Option.value ~default:default_token_cost (Hashtbl.find_opt token_costs name) + +let bookkeeping_and_bucket ~task_create ~user_agent ~client_ip ~cost = + let target = target_of_request ~user_agent ~client_ip in + let matches = Caller_table.get caller_table ~caller_id:target in + (* Stamp recency lock-free on the dispatch path: one atomic write per matched + entry, using the same value for every match in this call. Read back by + [evict_lru_auto_registered_locked] to pick the least recently used + caller. *) + let seq = next_call_sequence () in + List.iter + (fun entry -> + Caller_statistics.register_call ~token_amount:cost entry.stats ; + Atomic.set entry.last_call seq + ) + matches ; + if matches <> [] then + task_create (fun __context -> + let now = Clock.Date.now () in + List.iter + (fun entry -> + try + Db.Caller.set_last_access ~__context ~self:entry.caller_ref + ~value:now + with e -> + debug "Failed to update last_access for caller %s: %s" + (Ref.string_of entry.caller_ref) + (Printexc.to_string e) + ) + matches + ) ; + let entry_and_bucket = + List.find_map + (fun entry -> + if entry.rate_limit_ref = Ref.null then + None + else + Option.map + (fun rl -> (entry, rl)) + (Xapi_rate_limit.find_bucket entry.rate_limit_ref) + ) + matches + in + (matches, entry_and_bucket) + +(* Drop the auto-registered caller with the least recent call. Assumes + [caller_table_mutex] is held. Only ever scans the (bounded) in-memory table + and reads recency from an atomic, so no DB reads are needed to choose the + victim; the O(n) scan runs only on the rare "at capacity" auto-create. *) +let evict_lru_auto_registered_locked ~__context = + let victim = + entries_of_table () + |> List.filter (fun entry -> entry.auto_registered) + |> List.fold_left + (fun acc entry -> + match acc with + | Some best + when Atomic.get best.last_call <= Atomic.get entry.last_call -> + acc + | _ -> + Some entry + ) + None + in + match victim with + | None -> + () + | Some entry -> + debug + "Auto-registered caller limit (%d) reached; evicting least recently \ + used caller %s" + !Xapi_globs.max_auto_registered_callers + (Ref.string_of entry.caller_ref) ; + destroy_locked ~__context ~self:entry.caller_ref + +let maybe_autocreate ~task_create ~user_agent ~client_ip ~existing = + let fully_specified_request = user_agent <> "" && client_ip <> "" in + if (not fully_specified_request) || any_fully_specified existing then + () + else + task_create (fun __context -> + with_caller_table_mutex (fun () -> + (* Re-check under the lock: another thread may have auto-created + a matching row while we were racing to acquire the mutex. *) + let target = target_of_request ~user_agent ~client_ip in + let existing = Caller_table.get caller_table ~caller_id:target in + let limit = !Xapi_globs.max_auto_registered_callers in + if any_fully_specified existing || limit = 0 then + (* A limit of 0 disables auto-registration entirely. *) + () + else + try + (* Enforce the cap before adding a new auto-registered caller. + A negative limit means unbounded, so no eviction. *) + if limit > 0 && !auto_registered_count >= limit then + evict_lru_auto_registered_locked ~__context ; + let pattern_key = + pattern_key_of_fields ~user_agent ~client_ip + in + let caller_ref = + create_locked ~__context + ~name_label: + (Printf.sprintf "user_agent: %s, client_ip: %s" user_agent + client_ip + ) + ~name_description: + (Printf.sprintf + "Autogenerated caller for user_agent %s, client_ip %s" + user_agent client_ip + ) + ~user_agent ~client_ip ~pattern_key ~auto_registered:true + in + Db.Caller.set_last_access ~__context ~self:caller_ref + ~value:(Clock.Date.now ()) + with e -> + warn "Auto-create of caller for (%s, %s) failed: %s" user_agent + client_ip (Printexc.to_string e) + ) + ) + +let make_observer ~parent ~entry ~user_agent ~client_ip ~cost = + let span : Tracing.Span.t option ref = ref None in + let attributes = + [ + ("xapi.rate_limit.user_agent", user_agent) + ; ("xapi.rate_limit.client_ip", client_ip) + ; ("xapi.rate_limit.caller", Ref.string_of entry.caller_ref) + ; ("xapi.rate_limit.bucket", Ref.string_of entry.rate_limit_ref) + ; ("xapi.rate_limit.cost", Printf.sprintf "%g" cost) + ] + in + let tracer = Tracing.Tracer.get_tracer ~name:"xapi" in + let on_start () = + match + Tracing.Tracer.start ~tracer ~name:"xapi.rate_limit.delay" + ~parent:(Some parent) ~span_kind:Tracing.SpanKind.Internal ~attributes + () + with + | Ok s -> + span := s + | Error _ -> + () + in + let on_end () = ignore (Tracing.Tracer.finish !span) in + {Rate_limit.on_start; on_end} + +let submit ~submit_fn ?parent ~user_agent ~client_ip ~callback ~task_create + amount = + if not !Xapi_globs.rate_limit_enabled then + callback () + else + let matches, entry_and_bucket = + bookkeeping_and_bucket ~task_create ~user_agent ~client_ip ~cost:amount + in + maybe_autocreate ~task_create ~user_agent ~client_ip ~existing:matches ; + match entry_and_bucket with + | Some (entry, rl) -> + let observer = + Option.map + (fun p -> + make_observer ~parent:p ~entry ~user_agent ~client_ip ~cost:amount + ) + parent + in + let caller_details = + Printf.sprintf "client_ip: %s, user_agent: %s" client_ip user_agent + in + submit_fn rl ?observer ~callback ~caller_details amount + | None -> + callback () + +let submit_sync ?parent ~user_agent ~client_ip ~callback ~task_create amount = + submit ~submit_fn:Rate_limit.submit_sync ?parent ~user_agent ~client_ip + ~callback ~task_create amount + +let submit_async ?parent ~user_agent ~client_ip ~callback ~task_create amount = + submit ~submit_fn:Rate_limit.submit_async ?parent ~user_agent ~client_ip + ~callback ~task_create amount + +(* We publish two derive data sources per caller group to xcp-rrdd: the group's + cumulative tokens consumed and its cumulative call count, summed over the + callers in that group. Reporting is per group rather than per caller, which + both matches how usage is analysed and bounds the number of data sources + (groups are administrator-defined, callers are not). Callers that belong to no + group are not reported. *) + +let reporter_uid = "xapi-rate-limit-groups" + +(* Sizing of the reporter's local shared-memory payload. The V2 protocol writes, + per data source, an 8-byte value plus its JSON metadata (name, description, + units, ...); a group's name-based data source comes to a few hundred bytes, so + 512 bytes each is a safe over-estimate. Two data sources (tokens, calls) are + published per group. A single fixed 4 KB page previously overflowed at ~8 + data sources, failing the writer with Failure "not enough memory". *) +let reporter_page_size = 4096 + +let reporter_bytes_per_ds = 512 + +let reporter_fixed_overhead = 256 + +(* Group names are administrator-defined and not bounded by any config, so size + the reporter generously. The backing file is sparse - only pages actually + written are committed - so an ample bound costs almost nothing, and the clamp + in [make_group_dss] guarantees the payload never exceeds the allocation. *) +let reporter_max_groups = 1024 + +(* Pages needed for two data sources per group plus fixed protocol overhead. *) +let reporter_page_count max_groups = + let bytes = + reporter_fixed_overhead + (2 * max_groups * reporter_bytes_per_ds) + in + max 1 ((bytes + reporter_page_size - 1) / reporter_page_size) + +(* Ceiling on data sources written per cycle, captured when the reporter starts + so it matches the shared memory actually allocated. 0 means no reporter is + running yet. *) +let reporter_max_datasources = ref 0 + +(* Aggregate per-caller statistics into per-group [(group, tokens, calls)] + totals. Group membership is mirrored into each entry, so this needs no + database access - important because it runs on the reporter thread, which has + no context. *) +let group_totals () = + let totals : (string, float * int) Hashtbl.t = Hashtbl.create 64 in + entries_of_table () + |> List.iter (fun entry -> + let tokens = Caller_statistics.get_token_count entry.stats in + let calls = Caller_statistics.get_call_count entry.stats in + List.iter + (fun group -> + let t, c = + Option.value ~default:(0.0, 0) (Hashtbl.find_opt totals group) + in + Hashtbl.replace totals group (t +. tokens, c + calls) + ) + entry.groups + ) ; + Hashtbl.fold (fun group (t, c) acc -> (group, t, c) :: acc) totals [] + +let make_group_dss () = + let groups = group_totals () in + let groups = + let max_groups = !reporter_max_datasources / 2 in + if max_groups > 0 && List.length groups > max_groups then ( + (* Defensive: never emit more data sources than the shared memory was + sized for. If somehow over, keep the busiest groups by token usage. *) + debug + "caller RRD reporter: %d groups exceed reporter capacity (%d); \ + reporting the busiest" + (List.length groups) max_groups ; + groups + |> List.sort (fun (_, t1, _) (_, t2, _) -> compare t2 t1) + |> List.filteri (fun i _ -> i < max_groups) + ) else + groups + in + groups + |> List.concat_map (fun (group, tokens, calls) -> + [ + ( Rrd.Host + , Ds.ds_make + ~name:(Printf.sprintf "group_%s_tokens" group) + ~description: + (Printf.sprintf "Total tokens consumed by caller group %s" group) + ~value:(Rrd.VT_Float tokens) ~ty:Rrd.Derive ~default:true + ~units:"tokens" ~min:0.0 () + ) + ; ( Rrd.Host + , Ds.ds_make + ~name:(Printf.sprintf "group_%s_calls" group) + ~description:(Printf.sprintf "Total calls by caller group %s" group) + ~value:(Rrd.VT_Int64 (Int64.of_int calls)) + ~ty:Rrd.Derive ~default:true ~units:"calls" ~min:0.0 () + ) + ] + ) + +let reporter : Rrdd_plugin.Reporter.t option ref = ref None + +let start_reporter () = + reporter_max_datasources := 2 * reporter_max_groups ; + let page_count = reporter_page_count reporter_max_groups in + try + let r = + Rrdd_plugin.Reporter.start_async + (module D : Debug.DEBUG) + ~uid:reporter_uid ~neg_shift:0.5 + ~target:(Rrdd_plugin.Reporter.Local page_count) + ~protocol:Rrd_interface.V2 ~dss_f:make_group_dss + in + reporter := Some r + with e -> + warn "Failed to start caller RRD reporter: %s" (Printexc.to_string e) + +let register ~__context = + if not !Xapi_globs.rate_limit_enabled then + debug + "Rate limiting disabled (rate_limit=false); skipping caller registration" + else ( + load_token_costs () ; + (* Runs single-threaded at start-of-day, so bypasses caller_table_mutex. *) + auto_registered_count := 0 ; + List.iter + (fun self -> + let record = Db.Caller.get_record ~__context ~self in + let pattern_key = pattern_key_of_record record in + insert_entry_locked ~caller_ref:self + ~stats:(Caller_statistics.create ~caller_uuid:record.caller_uuid) + ~pattern_key ~rate_limit_ref:record.API.caller_rate_limit + ~auto_registered:record.API.caller_auto_registered + ~groups:record.API.caller_groups () ; + if record.API.caller_auto_registered then incr auto_registered_count + ) + (Db.Caller.get_all ~__context) ; + (* Auto-registered callers persist across restarts, so the database may + already hold more than the current cap (e.g. after lowering it, or after + disabling auto-registration with a limit of 0). Trim the excess, dropping + those with the least recent call first. A negative limit means unbounded, + so nothing is trimmed. Recency here comes from the persisted [last_access] + field - the only recency signal available before any calls have been seen + this boot. This reads [last_access] once per auto-registered caller, but + only on the rare boot where the database already exceeds the cap. *) + let limit = !Xapi_globs.max_auto_registered_callers in + ( if limit >= 0 && !auto_registered_count > limit then + let auto_callers = + entries_of_table () + |> List.filter (fun entry -> entry.auto_registered) + |> List.map (fun entry -> + let last_access = + try Db.Caller.get_last_access ~__context ~self:entry.caller_ref + with _ -> Clock.Date.epoch + in + (entry.caller_ref, last_access) + ) + |> List.sort (fun (_, a) (_, b) -> Clock.Date.compare a b) + in + let to_drop = !auto_registered_count - limit in + auto_callers + |> List.filteri (fun i _ -> i < to_drop) + |> List.iter (fun (self, _) -> + debug + "Auto-registered caller count exceeds limit (%d) at startup; \ + evicting least recently used caller %s" + limit (Ref.string_of self) ; + destroy_locked ~__context ~self + ) + ) ; + start_reporter () + ) diff --git a/ocaml/xapi/xapi_caller.mli b/ocaml/xapi/xapi_caller.mli new file mode 100644 index 00000000000..f9984ff961b --- /dev/null +++ b/ocaml/xapi/xapi_caller.mli @@ -0,0 +1,79 @@ +(* + * Copyright (C) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** In-memory caller_table mirroring the Caller DB rows, plus the entry + point used by [Server_helpers.do_dispatch] / [Xapi_http.add_handler] to + apply per-caller rate limiting. *) + +val default_token_cost : float + +val get_token_cost : string -> float + +val submit_sync : + ?parent:Tracing.Span.t + -> user_agent:string + -> client_ip:string + -> callback:(unit -> 'a) + -> task_create:((Context.t -> unit) -> unit) + -> float + -> 'a +(** [parent], when supplied, is the parent span used to record a + [xapi.rate_limit.delay] child span whenever the call is actually + queued/delayed. No span is emitted when tokens are available immediately. *) + +val submit_async : + ?parent:Tracing.Span.t + -> user_agent:string + -> client_ip:string + -> callback:(unit -> unit) + -> task_create:((Context.t -> unit) -> unit) + -> float + -> unit +(** See {!submit_sync} for the meaning of [parent]. *) + +val create : + __context:Context.t + -> name_label:string + -> name_description:string + -> user_agent:string + -> client_ip:string + -> API.ref_Caller + +val destroy : __context:Context.t -> self:API.ref_Caller -> unit + +val add_group : + __context:Context.t -> self:API.ref_Caller -> group:string -> unit + +val remove_group : + __context:Context.t -> self:API.ref_Caller -> group:string -> unit + +val query_token_usage : __context:Context.t -> self:API.ref_Caller -> float + +val query_call_count : __context:Context.t -> self:API.ref_Caller -> int64 + +val query_group_token_usage : __context:Context.t -> group:string -> float + +val query_group_call_count : __context:Context.t -> group:string -> int64 + +val query_all_usage : __context:Context.t -> string list list + +val group_totals : unit -> (string * float * int) list +(** [(group, tokens, calls)] totals, summed over all callers in each group, from + in-memory state (no database access). This is the data published per group by + the RRD reporter. Callers in no group do not appear. *) + +val register : __context:Context.t -> unit +(** Populate caller_table from persisted Caller rows and install + [Xapi_rate_limit]'s caller-refresh callback. Must run after + [Xapi_rate_limit.register] so that bucket lookups succeed. *) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 2cf8fc836eb..0e8608d219a 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -243,12 +243,12 @@ module Daemon = struct let is_enabled () = Atomic.get enabled - let maybe_call_script ~__context script params = + let maybe_call_script ~__context ?timeout script params = match Context.get_test_clusterd_rpc __context with | Some _ -> debug "in unit test, not calling %s %s" script (String.concat " " params) | None -> - ignore (Helpers.call_script script params) + ignore (Helpers.call_script ?timeout script params) let maybe_update_firewall ~__context ~status = match Context.get_test_clusterd_rpc __context with @@ -264,6 +264,17 @@ module Daemon = struct let service = "xapi-clusterd" + (* Add a timeout to `systemctl start` so it cannot block pool-join if it hangs. *) + let start_timeout = Mtime.Span.(60 * s) + + (* [systemctl is-active], gated for unit tests where systemctl is not called. *) + let is_service_active ~__context = + match Context.get_test_clusterd_rpc __context with + | Some _ -> + false + | None -> + Fe_systemctl.is_active ~service + let enable ~__context = debug "Enabling and starting the clustering daemon" ; ( try maybe_call_script ~__context !Xapi_globs.systemctl ["cat"; service] @@ -275,7 +286,13 @@ module Daemon = struct ( try maybe_update_firewall ~__context ~status:Firewall.Enabled ; maybe_call_script ~__context !Xapi_globs.systemctl ["enable"; service] ; - maybe_call_script ~__context !Xapi_globs.systemctl ["start"; service] + (* A redundant start of an already-active unit may hang forever waiting + * for a JobRemoved signal; skip it if running. *) + if is_service_active ~__context then + debug "%s already active, skipping redundant start" service + else + maybe_call_script ~__context ~timeout:start_timeout + !Xapi_globs.systemctl ["start"; service] with _ -> Helpers.internal_error "could not start %s" service ) ; Atomic.set enabled true ; @@ -363,6 +380,52 @@ let assert_cluster_host_quorate ~__context ~self = warn "Cannot query cluster host quorate status" ; handle_error error +(* Pre-flight for pool-ha-enable when the chosen [cluster_stack] is corosync: + every pool host must have an enabled, joined cluster_host on that stack, and + the local coordinator host must currently be quorate. Otherwise the gfs2 + heartbeat SR's PBD cannot plug and pool-ha-enable would later fail with the + misleading SR_NO_PBDS from check_sr_can_host_statefile. Intended to run + before ha_cluster_stack is persisted, so a failed precondition does not leak + it into the pool DB. *) +let assert_pool_ready_for_corosync_ha ~__context ~cluster_stack = + let localhost = Helpers.get_localhost ~__context in + List.iter + (fun host -> + match find_cluster_host ~__context ~host with + | None -> + raise + Api_errors.( + Server_error (no_compatible_cluster_host, [Ref.string_of host]) + ) + | Some self -> + let cluster = Db.Cluster_host.get_cluster ~__context ~self in + let ch_stack = + Db.Cluster.get_cluster_stack ~__context ~self:cluster + in + if ch_stack <> cluster_stack then + raise + Api_errors.( + Server_error (no_compatible_cluster_host, [Ref.string_of host]) + ) ; + assert_cluster_host_enabled ~__context ~self ~expected:true ; + if not (Db.Cluster_host.get_joined ~__context ~self) then + raise + Api_errors.( + Server_error (cluster_host_not_joined, [Ref.string_of self]) + ) + ) + (Db.Host.get_all ~__context) ; + (* Quorum only needs asserting once, for the local coordinator: it checks live + quorum directly via xapi-clusterd diagnostics, sidestepping the + Cluster_host.live DB field which the corosync_notifyd watcher only updates + asynchronously. *) + match find_cluster_host ~__context ~host:localhost with + | Some self -> + assert_cluster_host_quorate ~__context ~self + | None -> + warn "%s: coordinator %s has no cluster_host; skipping quorum check" + __FUNCTION__ (Ref.string_of localhost) + let assert_cluster_host_is_enabled_for_matching_sms ~__context ~host ~sr_sm_type = match get_required_cluster_stacks ~__context ~sr_sm_type with diff --git a/ocaml/xapi/xapi_clustering.mli b/ocaml/xapi/xapi_clustering.mli index 746c538fa79..2d3b26fdbef 100644 --- a/ocaml/xapi/xapi_clustering.mli +++ b/ocaml/xapi/xapi_clustering.mli @@ -52,6 +52,9 @@ val get_network_internal : val assert_cluster_host_enabled : __context:Context.t -> self:[`Cluster_host] Ref.t -> expected:bool -> unit +val assert_pool_ready_for_corosync_ha : + __context:Context.t -> cluster_stack:string -> unit + val assert_operation_host_target_is_localhost : __context:Context.t -> host:[`host] Ref.t -> unit diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index ee19e8369c7..cd656f09fdf 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -196,12 +196,7 @@ let software_version () = ; (_date, Xapi_version.date) ] -let pygrub_path = "/usr/bin/pygrub" - -let eliloader_path = "/usr/bin/eliloader" - -let supported_bootloaders = - [("pygrub", pygrub_path); ("eliloader", eliloader_path)] +let supported_bootloaders = ["pygrub"; "eliloader"] (* Deprecated: *) let is_guest_installer_network = "is_guest_installer_network" @@ -1061,7 +1056,9 @@ let winbind_set_machine_account_kerberos_encryption_type = ref false let winbind_scan_trusted_domains = ref false -let winbind_keep_configuration = ref false +let winbind_keep_configuration = ref true + +let serialize_auth_service = ref true let winbind_ldap_query_subject_timeout = ref Mtime.Span.(20 * s) @@ -1200,6 +1197,14 @@ let event_next_delay, event_next_entry = ~delay_before:Mtime.Span.(200 * ms) ~delay_between:Mtime.Span.(50 * ms) +(** Upper bound on the number of callers that [Xapi_caller] may auto-register. + When the limit is reached and a new caller must be registered, the + auto-registered caller with the least recent call is dropped first. + A value of 0 disables auto-registration entirely; a negative value means + unbounded. Manually created callers do not count towards this limit and are + never auto-evicted. *) +let max_auto_registered_callers = ref 100 + let xapi_globs_spec = [ ( "master_connection_reset_timeout" @@ -1292,6 +1297,7 @@ let xapi_globs_spec = ; ("test-open", Int test_open) (* for consistency with xenopsd *) ; ("local_yum_repo_port", Int local_yum_repo_port) ; ("ha_best_effort_max_retries", Int ha_best_effort_max_retries) + ; ("max-auto-registered-callers", Int max_auto_registered_callers) ] let xapi_globs_spec_with_descriptions = @@ -1436,6 +1442,16 @@ let factory_ntp_servers = ref [] let legacy_factory_ntp_servers = ref [] +(** When false (default), per-caller rate limiting is disabled at runtime: + [Xapi_caller.register] and [Xapi_rate_limit.register] are no-ops, the + RRD reporter is not started, and dispatch bypasses the caller table. *) +let rate_limit_enabled = ref false + +(** File mapping API calls to their rate-limiting token cost, in key=value + format ("Class.method = cost"), read by [Xapi_caller.register] at start of + day. *) +let call_costs_file = ref "/etc/xensource/call-costs.conf" + let other_options = [ gen_list_option "sm-plugins" @@ -1674,6 +1690,13 @@ let other_options = , "Whether to clear winbind configuration when join domain failed or leave \ domain" ) + ; ( "serialize_auth_service" + , Arg.Bool (fun b -> serialize_auth_service := b) + , (fun () -> string_of_bool !serialize_auth_service) + , "Serialize AD external auth operations under a mutex (default: true). \ + Set to false only if configure (enable/disable/set-ldaps) and \ + authenticate calls are never concurrent to improve performance." + ) ; ( "hsts_max_age" , Arg.Set_int hsts_max_age , (fun () -> string_of_int !hsts_max_age) @@ -1963,6 +1986,11 @@ let other_options = (fun s -> s) (fun s -> s) factory_ntp_servers + ; ( "rate_limit" + , Arg.Set rate_limit_enabled + , (fun () -> string_of_bool !rate_limit_enabled) + , "Enable per-caller rate limiting (Caller / Rate_limit datamodel)." + ) ] (* The options can be set with the variable xapiflags in /etc/sysconfig/xapi. @@ -2204,6 +2232,10 @@ module Resources = struct , iscsi_initiator_config_file , "Path to the initiatorname.iscsi file" ) + ; ( "call-costs-file" + , call_costs_file + , "File mapping API calls to their rate-limiting token cost" + ) ] let essential_dirs = diff --git a/ocaml/xapi/xapi_ha.ml b/ocaml/xapi/xapi_ha.ml index 48c212b1a2c..0ed7ebae08d 100644 --- a/ocaml/xapi/xapi_ha.ml +++ b/ocaml/xapi/xapi_ha.ml @@ -1908,6 +1908,8 @@ let enable __context heartbeat_srs configuration = let cluster_stack = Cluster_stack_constraints.choose_cluster_stack ~__context in + if cluster_stack = Constants.Ha_cluster_stack.(to_string Corosync) then + Xapi_clustering.assert_pool_ready_for_corosync_ha ~__context ~cluster_stack ; Db.Pool.set_ha_cluster_stack ~__context ~self:pool ~value:cluster_stack ; Localdb.put Constants.ha_cluster_stack cluster_stack ; (* Steps from 8.7 Enabling HA in Marathon spec: diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index e9e4de16bf0..4ad71dca189 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -352,7 +352,9 @@ let compute_evacuation_plan_no_wlb ~__context ~host ?(ignore_ha = false) () = List.iter (fun (vm, _) -> Hashtbl.replace plans vm - (Error (Api_errors.host_not_enough_free_memory, [Ref.string_of vm])) + (Error + (Api_errors.host_evacuate_vm_not_ha_protected, [Ref.string_of vm]) + ) ) unprotected_vms ; let migratable_vms, _ = @@ -811,8 +813,13 @@ let restart_agent ~__context ~host:_ = let shutdown_agent ~__context = debug "Host.shutdown_agent: Host agent will shutdown in 1s!!!!" ; let host_uuid = Helpers.get_localhost_uuid () in - Xapi_hooks.xapi_pre_shutdown ~__context ~host_uuid - ~reason:Xapi_hooks.reason__clean_shutdown ; + ( try + Xapi_hooks.xapi_pre_shutdown ~__context ~host_uuid + ~reason:Xapi_hooks.reason__clean_shutdown + with exn -> + warn "%s: xapi_pre_shutdown hook failed: %s" __FUNCTION__ + (Printexc.to_string exn) + ) ; Xapi_fuse.light_fuse_and_dont_restart ~fuse_length:1. () let disable ~__context ~host ~auto_enable = @@ -1074,7 +1081,7 @@ let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address ~cpu_configuration:[] (* !!! FIXME hard coding *) ~cpu_info:[] ~chipset_info ~memory_overhead:0L ~sched_policy:"credit" (* !!! FIXME hard coding *) ~numa_affinity_policy - ~supported_bootloaders:(List.map fst Xapi_globs.supported_bootloaders) + ~supported_bootloaders:Xapi_globs.supported_bootloaders ~suspend_image_sr:Ref.null ~crash_dump_sr:Ref.null ~logging:[] ~hostname ~address ~metrics ~license_params ~boot_free_mem:0L ~ha_statefiles:[] ~ha_network_peers:[] ~blobs:[] ~tags:[] ~external_auth_type @@ -1980,6 +1987,21 @@ let disable_external_auth ~__context ~host ~config ~force = disable_external_auth_common ~during_pool_eject:false ~__context ~host ~config ~force () +(* Enable or disable LDAPS for external authentication on a host *) +let external_auth_set_ldaps ~__context ~host ~ldaps ~force = + let open Api_errors in + let auth_error_to_set_ldaps_error f = + try f () + with Server_error (code, params) when code = auth_service_error -> + raise (Server_error (auth_set_ldaps_failed, Ref.string_of host :: params)) + in + + (* Just dispatch to the backend *) + with_lock serialize_host_enable_disable_extauth @@ fun () -> + auth_error_to_set_ldaps_error @@ fun () -> + Extauth.call_with_exception_handler @@ fun () -> + (Ext_auth.d ()).set_ldaps ~__context ~ldaps ~force + module Static_vdis_list = Xapi_database.Static_vdis_list let attach_static_vdis ~__context ~host:_ ~vdi_reason_map = diff --git a/ocaml/xapi/xapi_host.mli b/ocaml/xapi/xapi_host.mli index f153d37422a..8436552f1fc 100644 --- a/ocaml/xapi/xapi_host.mli +++ b/ocaml/xapi/xapi_host.mli @@ -372,6 +372,9 @@ val disable_external_auth : -> force:bool -> unit +val external_auth_set_ldaps : + __context:Context.t -> host:API.ref_host -> ldaps:bool -> force:bool -> unit + (** {2 Static VDIs} *) val attach_static_vdis : diff --git a/ocaml/xapi/xapi_http.ml b/ocaml/xapi/xapi_http.ml index a69b1f6c3b9..50d4767140a 100644 --- a/ocaml/xapi/xapi_http.ml +++ b/ocaml/xapi/xapi_http.ml @@ -352,25 +352,42 @@ let add_handler (name, handler) = failwith (Printf.sprintf "Unregistered HTTP handler: %s" name) in let check_rbac = Rbac.is_rbac_enabled_for_http_action name in - let h req ic context = - let client = - Http_svr.(client_of_req_and_fd req ic |> Option.map string_of_client) + let rate_limit (client_id_opt : (string * string) option) handler () = + if List.mem name Datamodel.custom_rate_limit_http_actions then + handler () + else + match client_id_opt with + | None -> + handler () + | Some (user_agent, client_ip) -> + Xapi_caller.submit_async ~user_agent ~client_ip ~callback:handler + ~task_create:(Server_helpers.exec_with_new_task "Add new caller") + Xapi_caller.default_token_cost + in + let h req ic () = + let client_info = Http_svr.client_of_req_and_fd req ic in + let client = Option.map Http_svr.string_of_client client_info in + let client_id = + match (req.Http.Request.user_agent, client_info) with + | Some user_agent, Some (_, ip) -> + Some (user_agent, Http_svr.canonical_ip_string ip) + | _ -> + None in + let rate_limited_handler = rate_limit client_id (handler req ic) in Debug.with_thread_associated ?client name (fun () -> try if check_rbac then ( try (* session and rbac checks *) - assert_credentials_ok name req - ~fn:(fun () -> handler req ic context) - ic + assert_credentials_ok name req ~fn:rate_limited_handler ic with e -> debug "Leaving RBAC-handler in xapi_http after: %s" (ExnHelper.string_of_exn e) ; raise e ) else (* no rbac checks *) - handler req ic context + rate_limited_handler () with Api_errors.Server_error (name, params) as e -> error "Unhandled Api_errors.Server_error(%s, [ %s ])" name (String.concat "; " params) ; diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index 8b44814aaee..a00ee2866c6 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -502,6 +502,10 @@ let pool_introduce ~__context ~device ~network ~host ~mAC ~mTU ~vLAN ~physical ~vLAN_master_of ~management ~other_config ~disallow_unplug ~ipv6_configuration_mode ~iPv6 ~ipv6_gateway ~primary_address_type ~managed ~properties = + (* Check we introduce PIF on compatible network (no VIF using trunks) *) + if vLAN <> -1L then + Xapi_pif_helpers.assert_network_compatible_with_trunks_on_vif ~__context + ~network ; let pif_ref = Ref.make () in let metrics = make_pif_metrics ~__context in let () = @@ -540,6 +544,10 @@ let introduce_internal ?network ?(physical = true) ~t ~__context ~host ~mAC ~mTU | Some x -> x in + (* Check we introduce PIF on compatible network (no VIF using trunks) *) + if vLAN <> -1L then + Xapi_pif_helpers.assert_network_compatible_with_trunks_on_vif ~__context + ~network:net_ref ; let metrics = match metrics with None -> make_pif_metrics ~__context | Some m -> m in diff --git a/ocaml/xapi/xapi_pif_helpers.ml b/ocaml/xapi/xapi_pif_helpers.ml index 00f1688bb15..27bcd99e7ed 100644 --- a/ocaml/xapi/xapi_pif_helpers.ml +++ b/ocaml/xapi/xapi_pif_helpers.ml @@ -121,6 +121,30 @@ let get_pif_topo ~__context ~pif_rec = let pif_t_list = List.rev pif_t_list in pif_t_list +(** Checks the Network is compatible with trunks attribute on VIF (no PIF with VLAN configured). *) +let assert_network_compatible_with_trunks_on_pif ~__context ~network = + let pif_has_vlan = + Db.Network.get_PIFs ~__context ~self:network + |> List.exists (fun self -> Db.PIF.get_VLAN ~__context ~self <> -1L) + in + if pif_has_vlan then + raise + (Api_errors.Server_error + (Api_errors.network_incompatible_with_trunks, [Ref.string_of network]) + ) + +(** Checks the Network is compatible with trunks attribute on VIF (no VIF with trunks attribute). *) +let assert_network_compatible_with_trunks_on_vif ~__context ~network = + let vif_has_trunks = + Db.Network.get_VIFs ~__context ~self:network + |> List.exists (fun self -> Db.VIF.get_trunks ~__context ~self <> []) + in + if vif_has_trunks then + raise + (Api_errors.Server_error + (Api_errors.network_incompatible_with_trunks, [Ref.string_of network]) + ) + let vlan_is_allowed_on_pif ~__context ~tagged_PIF ~pif_rec:_ ~pif_topo ~tag:_ = match pif_topo with | Physical pif_rec :: _ when pif_rec.API.pIF_bond_slave_of <> Ref.null -> diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index cdd1eec2173..87822518c71 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1688,7 +1688,7 @@ let certificate_sync ~__context = Certificates.sync_all_hosts ~__context (Db.Host.get_all ~__context) ; () -let install_trusted_certificate ~__context ~self:_ ~ca ~cert ~purpose = +let install_trusted_certificate' ~__context ~self:_ ~ca ~cert ~purpose = let open Certificates in let certificate = let open Api_errors in @@ -1712,12 +1712,18 @@ let install_trusted_certificate ~__context ~self:_ ~ca ~cert ~purpose = | false, true -> raise Api_errors.(Server_error (certificate_lacks_purpose, [])) in - let (_ : API.ref_Certificate), uuid = + let (ref : API.ref_Certificate), uuid = Db_util.add_cert ~__context ~type':cert_type ~purpose certificate in let name = Certificates.name_of_uuid uuid in Certificates.host_install kind ~name ~cert ; Cert_distrib.copy_certs_to_all ~__context ; + ref + +let install_trusted_certificate ~__context ~self ~ca ~cert ~purpose = + let (_ : API.ref_Certificate) = + install_trusted_certificate' ~__context ~self ~ca ~cert ~purpose + in () let uninstall_trusted_certificate ~__context ~self:_ ~certificate = @@ -1742,15 +1748,29 @@ let uninstall_trusted_certificate ~__context ~self:_ ~certificate = Cert_distrib.copy_certs_to_all ~__context ; () -let install_trusted_certificate_ignore_dup ~__context ~self ~ca ~cert ~purpose = - try install_trusted_certificate ~__context ~self ~ca ~cert ~purpose +let install_trusted_certificate_ignore_dup' ~__context ~self ~ca ~cert ~purpose + = + try + Ok (Some (install_trusted_certificate' ~__context ~self ~ca ~cert ~purpose)) with | Api_errors.(Server_error (code, [fp])) - when code = Api_errors.trusted_certificate_already_exists - -> - warn "%s: a trusted certificate (fingerprint=%s) exists already." - __FUNCTION__ fp ; - () + when code = Api_errors.trusted_certificate_already_exists -> + warn "%s: a trusted certificate (fingerprint=%s) exists already." + __FUNCTION__ fp ; + Ok None + | e -> + error "%s: failed to install certificate: %s" __FUNCTION__ + (Printexc.to_string e) ; + Error e + +let install_trusted_certificate_ignore_dup ~__context ~self ~ca ~cert ~purpose = + match + install_trusted_certificate_ignore_dup' ~__context ~self ~ca ~cert ~purpose + with + | Ok _ -> + () + | Error e -> + raise e let purpose_of_string_list = List.map Record_util.certificate_purpose_of_string @@ -1788,6 +1808,48 @@ let exchange_trusted_certificates ~__context ~rpc ~session_id ~remote ~local = ) [`ca; `pinned] +let sync_trusted_certificates_from ~__context ~self ~remote_pool ~remote_session + ~remote_certificate ~ca = + let rpc = + Helpers.make_external_host_verified_rpc ~__context remote_pool + remote_certificate + in + let session_id = remote_session in + let cert_type = + if ca then + "ca" + else + "pinned" + in + let expr = + Printf.sprintf {|field "type"="%s" and field "name"=""|} cert_type + in + let export = + Client.Certificate.get_all_records_where ~rpc ~session_id ~expr + |> List.map fst + in + Client.Pool.exchange_trusted_certificates_on_join ~rpc ~session_id + ~self:(get_pool ~rpc ~session_id) + ~ca ~import:[] ~export + |> Listext.List.try_map_collect (fun (cert, purpose) -> + let purpose = purpose_of_string_list purpose in + install_trusted_certificate_ignore_dup' ~__context + ~self:(Helpers.get_pool ~__context) + ~ca ~cert ~purpose + ) + |> function + | Ok refs -> + List.filter_map Fun.id refs + | Error (refs, e) -> + List.filter_map Fun.id refs + |> List.iter (fun ref -> + try uninstall_trusted_certificate ~__context ~self ~certificate:ref + with e -> + error "Can't revert the installed certificate %s: %s" + (Ref.string_of ref) (Printexc.to_string e) + ) ; + raise e + let exchange_crls_on_join ~__context ~self:_ ~import ~export = List.iter (fun (name, crl) -> crl_install ~__context ~name ~cert:crl) import ; Cert_distrib.collect_crls ~__context ~names:export @@ -1834,6 +1896,12 @@ let exchange_crls ~__context ~rpc ~session_id = (fun (name, crl) -> crl_install ~__context ~name ~cert:crl) remote_crls +let ignore_error ~msg ~warn f = + try f () + with e -> + debug "%s: %s" msg (Printexc.to_string e) ; + D.warn "%s" warn + let join_common ~__context ~master_address ~master_username ~master_password ~force = assert_pooling_licensed ~__context ; @@ -2024,23 +2092,43 @@ let join_common ~__context ~master_address ~master_username ~master_password error "Unable to configure SSH service on local host: %s" (ExnHelper.string_of_exn e) ) ; + (* Sync ldaps status before update_non_vm_metadata so that the corrected + value gets pushed to the coordinator as part of that sync, preventing + it from being overwritten when the host restarts as a slave. *) + ignore_error ~msg:"Failed to sync ldaps status with pool coordinator" + ~warn: + "Error whilst syncing ldaps status with pool coordinator. The \ + pool-join operation will continue as only the pool coordinator is \ + used for ldap query. Use pool-external-auth-set-ldaps --force to \ + fix up" (fun () -> + let coordinator_ldaps = + Client.Host.get_external_auth_configuration ~rpc ~session_id + ~self:remote_coordinator + |> fun config -> Helpers.ldaps_enabled_in_config ~config + in + let local_ldaps = + Db.Host.get_external_auth_configuration ~__context ~self:me + |> fun config -> Helpers.ldaps_enabled_in_config ~config + in + if coordinator_ldaps <> local_ldaps then + Xapi_host.external_auth_set_ldaps ~__context ~host:me + ~ldaps:coordinator_ldaps ~force:true + ) ; (* this is where we try and sync up as much state as we can with the master. This is "best effort" rather than critical; if we fail part way through this then we carry on with the join *) - try - update_non_vm_metadata ~__context ~rpc ~session_id ; - ignore - (Importexport.remote_metadata_export_import ~__context ~rpc - ~session_id ~remote_address:master_address ~restore:true `All - ) - with e -> - debug "Error whilst importing db objects into master; aborted: %s" - (Printexc.to_string e) ; - warn + ignore_error ~msg:"Error whilst importing db objects into master; aborted" + ~warn: "Error whilst importing db objects to master. The pool-join \ operation will continue, but some of the slave's VMs may not be \ - available on the master." + available on the master." (fun () -> + update_non_vm_metadata ~__context ~rpc ~session_id ; + ignore + (Importexport.remote_metadata_export_import ~__context ~rpc + ~session_id ~remote_address:master_address ~restore:true `All + ) + ) ) (fun () -> Client.Session.logout ~rpc ~session_id) ; @@ -3337,6 +3425,46 @@ let disable_external_auth ~__context ~pool:_ ~config = ) ) +(* Enable or disable LDAPS for external authentication on all hosts in the pool *) +let external_auth_set_ldaps ~__context ~pool:_ ~ldaps ~force = + let host = Helpers.get_master ~__context in + let current_ldaps = + Db.Host.get_external_auth_configuration ~__context ~self:host + |> fun config -> Helpers.ldaps_enabled_in_config ~config + in + + let hosts = Xapi_pool_helpers.get_master_slaves_list ~__context in + let set_ldap_on host = + try + call_fn_on_host ~__context + (Client.Host.external_auth_set_ldaps ~ldaps ~force) + host ; + Ok host + with e -> + debug "%s failed to set ldaps for host %s: %s" __FUNCTION__ + (Ref.string_of host) + (ExnHelper.string_of_exn e) ; + Error (host, e) + in + with_lock Xapi_globs.serialize_pool_enable_disable_extauth @@ fun () -> + let revert host = + try + call_fn_on_host ~__context + (Client.Host.external_auth_set_ldaps ~ldaps:current_ldaps ~force:true) + host + with e -> + warn "Failed to revert ldaps on host %s: %s" (Ref.string_of host) + (ExnHelper.string_of_exn e) + in + (* Set ldaps to host and host will perform the necessary checks *) + match Listext.List.try_map_collect set_ldap_on hosts with + | Ok _ -> + debug "%s succeed to set pool ldaps to %b" __FUNCTION__ ldaps + | Error (_, (_, e)) when current_ldaps = ldaps -> + raise e + | Error (hs, (_, e)) -> + List.iter revert hs ; raise e + (* CA-24856: detect non-homogeneous external-authentication config in pool *) let detect_nonhomogeneous_external_auth_in_pool ~__context = let slaves = Xapi_pool_helpers.get_slaves_list ~__context in diff --git a/ocaml/xapi/xapi_pool.mli b/ocaml/xapi/xapi_pool.mli index e483d835a71..275253c11eb 100644 --- a/ocaml/xapi/xapi_pool.mli +++ b/ocaml/xapi/xapi_pool.mli @@ -272,6 +272,9 @@ val enable_external_auth : val disable_external_auth : __context:Context.t -> pool:'a -> config:API.string_to_string_map -> unit +val external_auth_set_ldaps : + __context:Context.t -> pool:'a -> ldaps:bool -> force:bool -> unit + val detect_nonhomogeneous_external_auth_in_pool : __context:Context.t -> unit val run_detect_nonhomogeneous_external_auth_in_pool : unit -> unit @@ -475,3 +478,12 @@ val exchange_crls_on_join : -> import:API.string_to_string_map -> export:string list -> API.string_to_string_map + +val sync_trusted_certificates_from : + __context:Context.t + -> self:API.ref_pool + -> remote_pool:string + -> remote_session:API.ref_session + -> remote_certificate:string + -> ca:bool + -> API.ref_Certificate list diff --git a/ocaml/xapi/xapi_rate_limit.ml b/ocaml/xapi/xapi_rate_limit.ml new file mode 100644 index 00000000000..0859b1ccbca --- /dev/null +++ b/ocaml/xapi/xapi_rate_limit.ml @@ -0,0 +1,148 @@ +(* + * Copyright (C) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module D = Debug.Make (struct let name = "xapi_rate_limit" end) + +open D +module Rate_limit = Rate_limit_lib.Rate_limit + +(** Map of Rate_limit ref -> in-memory token-bucket worker. Owned here; + Xapi_caller looks up workers by ref via [find_bucket]. *) +let buckets : (API.ref_Rate_limit, Rate_limit.t) Hashtbl.t = Hashtbl.create 16 + +let mutex = Mutex.create () + +let with_mutex f = + Mutex.lock mutex ; + Fun.protect ~finally:(fun () -> Mutex.unlock mutex) f + +(** Callback invoked after a caller's rate_limit ref changes in the database, + so that the in-memory caller_table entry can be rebuilt to point at the + correct bucket. Set by [Xapi_caller.register]. Default is a no-op so + callbacks ordering during startup is not load-bearing. *) +let on_caller_rate_limit_changed : + (__context:Context.t -> API.ref_Caller -> unit) ref = + ref (fun ~__context:_ _ -> ()) + +let set_caller_refresh_callback f = on_caller_rate_limit_changed := f + +let notify_caller_changed ~__context caller_ref = + !on_caller_rate_limit_changed ~__context caller_ref + +let find_bucket rate_limit_ref = + with_mutex (fun () -> Hashtbl.find_opt buckets rate_limit_ref) + +let validate_params ~burst_size ~fill_rate = + if fill_rate <= 0. then + raise + Api_errors.( + Server_error (invalid_value, ["fill_rate"; string_of_float fill_rate]) + ) ; + if burst_size <= 0. then + raise + Api_errors.( + Server_error (invalid_value, ["burst_size"; string_of_float burst_size]) + ) + +let build_bucket ~burst_size ~fill_rate = + try Rate_limit.create ~burst_size ~fill_rate + with Invalid_argument msg -> + raise Api_errors.(Server_error (invalid_value, [msg])) + +let install_bucket ~self ~burst_size ~fill_rate = + let bucket = build_bucket ~burst_size ~fill_rate in + with_mutex (fun () -> + Option.iter Rate_limit.delete (Hashtbl.find_opt buckets self) ; + Hashtbl.replace buckets self bucket + ) + +let remove_bucket ~self = + with_mutex (fun () -> + Option.iter Rate_limit.delete (Hashtbl.find_opt buckets self) ; + Hashtbl.remove buckets self + ) + +let create ~__context ~name_label ~name_description ~burst_size ~fill_rate = + validate_params ~burst_size ~fill_rate ; + let uuid = Uuidx.make () in + let ref = Ref.make () in + Db.Rate_limit.create ~__context ~ref ~uuid:(Uuidx.to_string uuid) ~name_label + ~name_description ~burst_size ~fill_rate ; + install_bucket ~self:ref ~burst_size ~fill_rate ; + ref + +let destroy ~__context ~self = + let attached_callers = Db.Rate_limit.get_callers ~__context ~self in + List.iter + (fun caller -> + Db.Caller.set_rate_limit ~__context ~self:caller ~value:Ref.null ; + notify_caller_changed ~__context caller + ) + attached_callers ; + remove_bucket ~self ; + Db.Rate_limit.destroy ~__context ~self + +let add_caller ~__context ~self ~caller = + (* One rate limit per caller. Set the new value directly: the datamodel's + reverse-relation machinery removes the caller from any previous + Rate_limit's [callers] set automatically. The previous implementation + cleared to Ref.null first and then set the target, which briefly + left the caller unlimited and triggered two full refreshes (each + an extra DB read for the callback). *) + let previous = Db.Caller.get_rate_limit ~__context ~self:caller in + if previous <> self then ( + Db.Caller.set_rate_limit ~__context ~self:caller ~value:self ; + notify_caller_changed ~__context caller + ) + +let remove_caller ~__context ~self ~caller = + let current = Db.Caller.get_rate_limit ~__context ~self:caller in + if current = self then ( + Db.Caller.set_rate_limit ~__context ~self:caller ~value:Ref.null ; + notify_caller_changed ~__context caller + ) + +(* No [notify_caller_changed] on parameter changes: the caller_table entry + still points at the same rate_limit_ref, and [install_bucket] has + already swapped the in-memory bucket - the next [find_bucket] on the + dispatch path picks up the new parameters. Notifying attached callers + here would just be an extra DB read per caller with no state change. *) +let set_burst_size ~__context ~self ~value = + let fill_rate = Db.Rate_limit.get_fill_rate ~__context ~self in + validate_params ~burst_size:value ~fill_rate ; + Db.Rate_limit.set_burst_size ~__context ~self ~value ; + install_bucket ~self ~burst_size:value ~fill_rate + +let set_fill_rate ~__context ~self ~value = + let burst_size = Db.Rate_limit.get_burst_size ~__context ~self in + validate_params ~burst_size ~fill_rate:value ; + Db.Rate_limit.set_fill_rate ~__context ~self ~value ; + install_bucket ~self ~burst_size ~fill_rate:value + +let register ~__context = + if not !Xapi_globs.rate_limit_enabled then + debug + "Rate limiting disabled (rate_limit=false); skipping bucket registration" + else + List.iter + (fun self -> + let record = Db.Rate_limit.get_record ~__context ~self in + let burst_size = record.API.rate_limit_burst_size in + let fill_rate = record.API.rate_limit_fill_rate in + if fill_rate > 0. && burst_size > 0. then + install_bucket ~self ~burst_size ~fill_rate + else + warn "Skipping rate_limit %s: invalid persisted parameters" + record.API.rate_limit_uuid + ) + (Db.Rate_limit.get_all ~__context) diff --git a/ocaml/xapi/xapi_rate_limit.mli b/ocaml/xapi/xapi_rate_limit.mli new file mode 100644 index 00000000000..fa24db8be79 --- /dev/null +++ b/ocaml/xapi/xapi_rate_limit.mli @@ -0,0 +1,64 @@ +(* + * Copyright (C) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** In-memory store of rate-limit token-bucket workers, keyed by the + Rate_limit datamodel ref. Owns the worker lifecycle and exposes + {!find_bucket} for Xapi_caller's request-dispatch path. *) + +val find_bucket : API.ref_Rate_limit -> Rate_limit_lib.Rate_limit.t option +(** Look up the in-memory bucket worker for a Rate_limit row. *) + +val set_caller_refresh_callback : + (__context:Context.t -> API.ref_Caller -> unit) -> unit +(** Install the callback used to refresh in-memory state for a caller + whenever its rate_limit DB field changes. Called once at startup by + Xapi_caller. *) + +(** {2 Datamodel-message implementations.} + + These are called by the generated dispatch layer via the + Custom_actions / message_forwarding wiring. *) + +val create : + __context:Context.t + -> name_label:string + -> name_description:string + -> burst_size:float + -> fill_rate:float + -> API.ref_Rate_limit + +val destroy : __context:Context.t -> self:API.ref_Rate_limit -> unit + +val add_caller : + __context:Context.t + -> self:API.ref_Rate_limit + -> caller:API.ref_Caller + -> unit + +val remove_caller : + __context:Context.t + -> self:API.ref_Rate_limit + -> caller:API.ref_Caller + -> unit + +val set_burst_size : + __context:Context.t -> self:API.ref_Rate_limit -> value:float -> unit + +val set_fill_rate : + __context:Context.t -> self:API.ref_Rate_limit -> value:float -> unit + +val register : __context:Context.t -> unit +(** Load all persisted Rate_limit rows and build their in-memory workers. + Must run before Xapi_caller.register so that callers can attach to + existing buckets at startup. *) diff --git a/ocaml/xapi/xapi_stunnel_server.ml b/ocaml/xapi/xapi_stunnel_server.ml index 93474474f60..afc110e1da2 100644 --- a/ocaml/xapi/xapi_stunnel_server.ml +++ b/ocaml/xapi/xapi_stunnel_server.ml @@ -52,10 +52,10 @@ end = struct let open Printf in let cipher_options = [ - sprintf "ciphers = %s" Constants.good_ciphersuites - ; "curve = secp384r1" - ; "options = CIPHER_SERVER_PREFERENCE" - ; "sslVersion = TLSv1.2" + sprintf "ciphers = %s" Tls_policy.Openssl.default_ciphers + ; sprintf "curve = %s" Tls_policy.Openssl.default_curve + ; sprintf "options = %s" Tls_policy.Openssl.default_server_preference + ; sprintf "sslVersion = %s" Tls_policy.Openssl.default_version ] in [ diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index 004a65b059c..e4b8e345f0b 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -1066,6 +1066,12 @@ let resize ~__context ~vdi ~size = Db.VDI.set_virtual_size ~__context ~self:vdi ~value:new_size ) +(* Online resize follows exactly the same storage path as the offline resize; + the distinction lives in xapi's allowed-operations checks, which permit + resize_online on a VDI attached to a running VM (subject to the SM backend + advertising the VDI_RESIZE_ONLINE capability). *) +let resize_online = resize + let generate_config ~__context ~host:_ ~vdi = Sm.assert_pbd_is_plugged ~__context ~sr:(Db.VDI.get_SR ~__context ~self:vdi) ; Xapi_vdi_helpers.assert_managed ~__context ~vdi ; diff --git a/ocaml/xapi/xapi_vdi.mli b/ocaml/xapi/xapi_vdi.mli index 68d15e56d0f..4c057ad7362 100644 --- a/ocaml/xapi/xapi_vdi.mli +++ b/ocaml/xapi/xapi_vdi.mli @@ -164,6 +164,9 @@ val _data_destroy : val resize : __context:Context.t -> vdi:[`VDI] API.Ref.t -> size:int64 -> unit +val resize_online : + __context:Context.t -> vdi:[`VDI] API.Ref.t -> size:int64 -> unit + val generate_config : __context:Context.t -> host:'a -> vdi:[`VDI] API.Ref.t -> string diff --git a/ocaml/xapi/xapi_vif.ml b/ocaml/xapi/xapi_vif.ml index 17dccdfa05b..de4f73cc31a 100644 --- a/ocaml/xapi/xapi_vif.ml +++ b/ocaml/xapi/xapi_vif.ml @@ -33,7 +33,7 @@ let unplug_force ~__context ~self = Xapi_xenops.vif_unplug ~__context ~self true let create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config ~currently_attached ~qos_algorithm_type ~qos_algorithm_params ~locking_mode - ~ipv4_allowed ~ipv6_allowed : API.ref_VIF = + ~ipv4_allowed ~ipv6_allowed ~trunks : API.ref_VIF = (* TODO: Raise bad power state error (once all API clients make sure to onlu call the needed params in the create method) when: - power_state = `Halted and currently_attached = true *) @@ -49,7 +49,7 @@ let create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config ~mAC ~mTU ~other_config ~qos_algorithm_type ~qos_algorithm_params ~locking_mode ~ipv4_allowed ~ipv6_allowed ~ipv4_configuration_mode:`None ~ipv4_addresses:[] ~ipv4_gateway:"" ~ipv6_configuration_mode:`None - ~ipv6_addresses:[] ~ipv6_gateway:"" + ~ipv6_addresses:[] ~ipv6_gateway:"" ~trunks let destroy ~__context ~self = destroy ~__context ~self @@ -95,6 +95,9 @@ let move ~__context ~self ~network = ) ) ) ; + if Db.VIF.get_trunks ~__context ~self <> [] then + Xapi_pif_helpers.assert_network_compatible_with_trunks_on_pif ~__context + ~network ; move_internal ~__context ~network ~active self let change_locking_config ~__context ~self ~licence_check f = @@ -217,3 +220,36 @@ let configure_ipv6 ~__context ~self ~mode ~address ~gateway = Db.VIF.set_ipv6_gateway ~__context ~self ~value:gateway ; if device_active ~__context ~self then Xapi_xenops.vif_set_ipv6_configuration ~__context ~self + +(** Checks that Network associated to VIF is not backed on PIF with VLAN. *) +let assert_vif_compatible_with_trunks ~__context ~self = + let network = Db.VIF.get_network ~__context ~self in + Xapi_pif_helpers.assert_network_compatible_with_trunks_on_pif ~__context + ~network + +let add_trunks ~__context ~self ~value = + Xapi_vlan.assert_valid_VLAN_tag value ; + assert_vif_compatible_with_trunks ~__context ~self ; + let current = Db.VIF.get_trunks ~__context ~self in + if not (List.mem value current) then ( + Db.VIF.set_trunks ~__context ~self ~value:(value :: current) ; + if device_active ~__context ~self then + Xapi_xenops.vif_set_trunks ~__context ~self + ) + +let remove_trunks ~__context ~self ~value = + let current = Db.VIF.get_trunks ~__context ~self in + if List.mem value current then ( + let value = List.filter (( <> ) value) current in + Db.VIF.set_trunks ~__context ~self ~value ; + if device_active ~__context ~self then + Xapi_xenops.vif_set_trunks ~__context ~self + ) + +let set_trunks ~__context ~self ~value = + if value <> [] then assert_vif_compatible_with_trunks ~__context ~self ; + let value = Listext.setify value in + List.iter Xapi_vlan.assert_valid_VLAN_tag value ; + Db.VIF.set_trunks ~__context ~self ~value ; + if device_active ~__context ~self then + Xapi_xenops.vif_set_trunks ~__context ~self diff --git a/ocaml/xapi/xapi_vif.mli b/ocaml/xapi/xapi_vif.mli index 2d98a7dc342..b78cd36c790 100644 --- a/ocaml/xapi/xapi_vif.mli +++ b/ocaml/xapi/xapi_vif.mli @@ -54,6 +54,7 @@ val create : -> locking_mode:API.vif_locking_mode -> ipv4_allowed:string list -> ipv6_allowed:string list + -> trunks:int64 list -> API.ref_VIF (** Create a new VIF instance *) @@ -129,3 +130,14 @@ val configure_ipv6 : -> gateway:string -> unit (** Change the IP configuration of a VIF *) + +val add_trunks : __context:Context.t -> self:[`VIF] Ref.t -> value:int64 -> unit +(** Associate a 802.1Q VLAN with this VIF. *) + +val remove_trunks : + __context:Context.t -> self:[`VIF] Ref.t -> value:int64 -> unit +(** Remove a 802.1Q VLAN from this VIF. *) + +val set_trunks : + __context:Context.t -> self:[`VIF] Ref.t -> value:int64 list -> unit +(** Set the list of 802.1Q VLANs allowed to use this VIF. *) diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index fc1eb8a3127..4307b66afa4 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -237,8 +237,8 @@ let m = Mutex.create () (* prevents duplicate VIFs being created by accident *) let create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config ~qos_algorithm_type ~qos_algorithm_params ~currently_attached ~locking_mode ~ipv4_allowed ~ipv6_allowed ~ipv4_configuration_mode ~ipv4_addresses - ~ipv4_gateway ~ipv6_configuration_mode ~ipv6_addresses ~ipv6_gateway : - API.ref_VIF = + ~ipv4_gateway ~ipv6_configuration_mode ~ipv6_addresses ~ipv6_gateway ~trunks + : API.ref_VIF = let () = debug "VIF.create running" in if Xapi_network_sriov_helpers.is_sriov_network ~__context ~self:network then Pool_features.assert_enabled ~__context ~f:Features.Network_sriov ; @@ -270,6 +270,10 @@ let create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config in if not (Helpers.is_valid_MAC mAC) then raise (Api_errors.Server_error (Api_errors.mac_invalid, [mAC])) ; + (* Check we can use trunks on the network. *) + if trunks <> [] then + Xapi_pif_helpers.assert_network_compatible_with_trunks_on_pif ~__context + ~network ; (* Make people aware that non-shared networks being added to VMs makes them not agile *) let pool = Helpers.get_pool ~__context in ( if @@ -341,7 +345,7 @@ let create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config ~metrics ~locking_mode ~ipv4_allowed ~ipv6_allowed ~ipv4_configuration_mode ~ipv4_addresses ~ipv4_gateway ~ipv6_configuration_mode ~ipv6_addresses ~ipv6_gateway - ~reserved_pci:Ref.null + ~reserved_pci:Ref.null ~trunks in () ) ; @@ -397,7 +401,7 @@ let copy ~__context ~vm ~preserve_mac_address vif = ~ipv4_gateway:all.API.vIF_ipv4_gateway ~ipv6_configuration_mode:all.API.vIF_ipv6_configuration_mode ~ipv6_addresses:all.API.vIF_ipv6_addresses - ~ipv6_gateway:all.API.vIF_ipv6_gateway + ~ipv6_gateway:all.API.vIF_ipv6_gateway ~trunks:all.API.vIF_trunks in let expr = Xapi_database.Db_filter_types.(Eq (Field "VIF", Literal (Ref.string_of vif))) diff --git a/ocaml/xapi/xapi_vif_helpers.mli b/ocaml/xapi/xapi_vif_helpers.mli index 6451ba02ddc..7b062a8df7d 100644 --- a/ocaml/xapi/xapi_vif_helpers.mli +++ b/ocaml/xapi/xapi_vif_helpers.mli @@ -55,6 +55,7 @@ val create : -> ipv6_configuration_mode:[< `None | `Static] -> ipv6_addresses:string list -> ipv6_gateway:string + -> trunks:int64 list -> API.ref_VIF (** Create a VIF object in the database. *) diff --git a/ocaml/xapi/xapi_vlan.ml b/ocaml/xapi/xapi_vlan.ml index 2e2b13191cf..ab3f849c477 100644 --- a/ocaml/xapi/xapi_vlan.ml +++ b/ocaml/xapi/xapi_vlan.ml @@ -15,6 +15,14 @@ module D = Debug.Make (struct let name = "xapi_vlan" end) open D +let assert_valid_VLAN_tag tag = + if tag < 0L || tag > 4094L then + raise + (Api_errors.Server_error + (Api_errors.vlan_tag_invalid, [Int64.to_string tag]) + ) ; + () + (* Dummy MAC used by the VLAN *) let vlan_mac = "fe:ff:ff:ff:ff:ff" @@ -48,6 +56,8 @@ let pool_introduce ~__context ~tagged_PIF ~untagged_PIF ~tag ~other_config = vlan let create_internal ~__context ~host ~tagged_PIF ~tag ~network ~device = + Xapi_pif_helpers.assert_network_compatible_with_trunks_on_vif ~__context + ~network ; let vlan = Ref.make () and vlan_uuid = Uuidx.to_string (Uuidx.make ()) in let untagged_PIF = Ref.make () in (* Copy the MTU and metrics from the base PIF *) @@ -83,12 +93,7 @@ let create ~__context ~tagged_PIF ~tag ~network = ~pif_topo ~tag ; Xapi_network_helpers.assert_vlan_network_compatible_with_pif ~__context ~network ~tagged_PIF ~pif_topo ; - (* Check the VLAN tag is sensible; 4095 is reserved for implementation use (802.1Q) *) - if tag < 0L || tag > 4094L then - raise - (Api_errors.Server_error - (Api_errors.vlan_tag_invalid, [Int64.to_string tag]) - ) ; + assert_valid_VLAN_tag tag ; let device = pif_rec.API.pIF_device in let vlans = let open Xapi_database.Db_filter_types in diff --git a/ocaml/xapi/xapi_vlan.mli b/ocaml/xapi/xapi_vlan.mli index 10fbf1523d6..d4dac761891 100644 --- a/ocaml/xapi/xapi_vlan.mli +++ b/ocaml/xapi/xapi_vlan.mli @@ -60,3 +60,7 @@ val destroy : __context:Context.t -> self:[`VLAN] Ref.t -> unit (** Destroy a VLAN. Removes the VLAN object as well as the VLAN master PIF. *) val vlan_mac : string + +val assert_valid_VLAN_tag : int64 -> unit +(** Checks the parameter is sensible value for VLAN tag (0 - 4094 inclusive); + * 4095 is reserved for implementation use (802.1Q) *) diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 09cfc811345..f474ca306cb 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -690,6 +690,34 @@ let create ~__context ~name_label ~name_description ~power_state ~user_version ~pending_guidances:[] ~recommended_guidances:[] ~pending_guidances_recommended:[] ~pending_guidances_full:[] ~secureboot_certificates_state:`ok ; + (* Inspect the NVRAM supplied at creation time and record whether its Secure + Boot certificates are due to expire. If the pool has opted in to automatic + Secure Boot certificate updates and an update is available, schedule it on + the VM's next boot; otherwise simply record the current state so it is + visible to the user. + check_secureboot_certificates_state returns `ok cheaply when the NVRAM + contains no EFI variables (e.g. BIOS VMs), so no external check is run in + that case. There may be no pool in unit-test mock databases, in which case + there is no opt-in setting to honour and the check is skipped. *) + ( match Db.Pool.get_all ~__context with + | [] -> + () + | pool :: _ -> + let auto_update = + Db.Pool.get_auto_update_vm_secureboot_certificates ~__context ~self:pool + in + let value : API.vm_secureboot_certificates_state = + match + Xapi_vm_helpers.check_secureboot_certificates_state ~__context + ~self:vm_ref + with + | `update_available when auto_update -> + `update_on_boot + | (`ok | `update_available) as state -> + (state :> API.vm_secureboot_certificates_state) + in + Db.VM.set_secureboot_certificates_state ~__context ~self:vm_ref ~value + ) ; Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm_ref ; update_memory_overhead ~__context ~vm:vm_ref ; update_vm_virtual_hardware_platform_version ~__context ~vm:vm_ref ; diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index 4ecab7e580c..24580c31e2b 100644 --- a/ocaml/xapi/xapi_vm_snapshot.ml +++ b/ocaml/xapi/xapi_vm_snapshot.ml @@ -288,14 +288,17 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm = VDISet.map get_snapshot_of snap_disks_reverted in + let vm_disks_without_snapshot = + let ( --- ) = VDISet.diff in + vm_disks_all --- snap_disks_snapshot_of + in + let vm_disks_to_be_destroyed = let ( --- ) = VDISet.diff in let ( +++ ) = VDISet.union in - (* Disks without snapshot are left unattached after the revert is complete. *) - let vm_disks_without_snapshot = vm_disks_all --- snap_disks_snapshot_of in - vm_disks_all + (* Disks without snapshot are left unattached after the revert is complete. *) --- vm_disks_without_snapshot --- vm_disks_already_reverted +++ vm_suspend_VDI @@ -310,7 +313,9 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm = let vm_vbds_to_be_destroyed = let ( +++ ) = VBDSet.union in - filter_vbds_from_vdis vm_VBDs_all vm_disks_to_be_destroyed +++ vm_VBDs_CD + filter_vbds_from_vdis vm_VBDs_all vm_disks_to_be_destroyed + +++ filter_vbds_from_vdis vm_VBDs_all vm_disks_without_snapshot + +++ vm_VBDs_CD in let snap_VBDs_reverted = diff --git a/ocaml/xapi/xapi_vncsnapshot.ml b/ocaml/xapi/xapi_vncsnapshot.ml index f783039ee3c..5bcf48fa5b6 100644 --- a/ocaml/xapi/xapi_vncsnapshot.ml +++ b/ocaml/xapi/xapi_vncsnapshot.ml @@ -21,6 +21,8 @@ open D let vncsnapshot = "/usr/bin/vncsnapshot" +let timeout = Mtime.Span.(30 * s) + let vncsnapshot_handler (req : Request.t) s _ = debug "vncshapshot handler running" ; Xapi_http.with_context "Taking snapshot of VM console" req s (fun __context -> @@ -29,27 +31,50 @@ let vncsnapshot_handler (req : Request.t) s _ = Console.rbac_check_for_control_domain __context req console Rbac_static.permission_http_get_vncsnapshot_host_console .Db_actions.role_name_label ; - let tmp = Filename.temp_file "snapshot" "jpg" in + let tmp = Filename.temp_file "snapshot" ".jpg" in let filename = Filename.basename tmp in Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> - let vnc_port = - Int64.to_int (Db.Console.get_port ~__context ~self:console) - in - let pid = - safe_close_and_exec None None None [] vncsnapshot - [ - "-quiet" - ; "-allowblank" - ; "-encodings" - ; "\"raw\"" - ; Printf.sprintf "%s:%d" "127.0.0.1" (vnc_port - 5900) - ; tmp - ] - in - let hsts_time = !Xapi_globs.hsts_max_age in - waitpid_fail_if_bad_exit pid ; - Http_svr.response_file ~hsts_time s tmp ~download_name:filename + match Console.address_of_console __context console with + | None -> + error "Failed to find the VNC console address" ; + Http_svr.headers s (Http.http_404_missing ()) + | Some address -> + let target = + match address with + | Console.Port port -> + [Printf.sprintf "127.0.0.1::%d" port] + | Console.Path path -> + ["-unix"; path] + in + let args = + ["-allowblank"; "-encodings"; "raw"] @ target @ [tmp] + in + ( try + let out, err = + execute_command_get_output ~timeout vncsnapshot args + in + debug "vncsnapshot succeeded (stdout=%S stderr=%S)" out err + with + | Subprocess_timeout as e -> + error "vncsnapshot timed out after %s" + (Fmt.to_to_string Mtime.Span.pp timeout) ; + raise e + | Spawn_internal_error (err, out, status) as e -> + let status = + match status with + | Unix.WEXITED n -> + Printf.sprintf "exited with code %d" n + | Unix.WSIGNALED n -> + Printf.sprintf "was killed by signal %d" n + | Unix.WSTOPPED n -> + Printf.sprintf "was stopped by signal %d" n + in + error "vncsnapshot %s (stdout=%S stderr=%S)" status out err ; + raise e + ) ; + let hsts_time = !Xapi_globs.hsts_max_age in + Http_svr.response_file ~hsts_time s tmp ~download_name:filename ) (fun () -> try Unix.unlink tmp with _ -> ()) with e -> diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 9d2ee7437d0..d15cbe033d4 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -889,6 +889,7 @@ module MD = struct else Some vlan in + let trunks = Db.VIF.get_trunks ~__context ~self:vif_ref in { Vif.id= (vm.API.vM_uuid, vif.API.vIF_device) ; position= int_of_string vif.API.vIF_device @@ -904,6 +905,7 @@ module MD = struct ; ipv6_configuration ; pvs_proxy ; vlan + ; trunks } let pcis_of_vm ~__context (vmref, vm) = @@ -1465,8 +1467,8 @@ let create_metadata ~__context ~self = ) in let vifs' = List.map (fun vif -> MD.of_vif ~__context ~vm ~vif) vifs in - let pcis = MD.pcis_of_vm ~__context (self, vm) in let vgpus = MD.vgpus_of_vm ~__context (self, vm) in + let pcis = MD.pcis_of_vm ~__context (self, vm) in let vusbs = MD.vusbs_of_vm ~__context (self, vm) in let domains = (* For suspended VMs, the last_booted_record contains the "live" xenopsd state. *) @@ -4475,6 +4477,21 @@ let vif_set_ipv6_configuration ~__context ~self = Events_from_xenopsd.wait queue_name dbg (fst vif.Vif.id) () ) +let vif_set_trunks ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let vm = Db.VIF.get_VM ~__context ~self in + let queue_name = queue_of_vm ~__context ~self:vm in + transform_xenops_exn ~__context ~vm queue_name (fun () -> + assert_resident_on ~__context ~self:vm ; + let vif = md_of_vif ~__context ~self in + info "xenops: VIF.vif_set_trunks %s.%s" (fst vif.Vif.id) (snd vif.Vif.id) ; + let dbg = Context.string_of_task_and_tracing __context in + let module Client = (val make_client queue_name : XENOPS) in + Client.VIF.set_trunks dbg vif.Vif.id vif.Vif.trunks + |> sync_with_task __context queue_name ; + Events_from_xenopsd.wait queue_name dbg (fst vif.Vif.id) () + ) + let task_cancel ~__context ~self = let@ __context = Context.with_tracing ~__context __FUNCTION__ in try diff --git a/ocaml/xe-cli/bash-completion b/ocaml/xe-cli/bash-completion index 1e2e6c72f7f..9fb77ba8ca7 100644 --- a/ocaml/xe-cli/bash-completion +++ b/ocaml/xe-cli/bash-completion @@ -32,6 +32,26 @@ COMPLETION_SUGGESTIONS=0 SHOW_DESCRIPTION=0 REQD_OPTIONAL_PARAMS=0 +# Display helper for caller UUID completion. Prints the caller's +# name-label when set, otherwise falls back to "@" +# so auto-created records (which have no name-label) still show a +# meaningful description. Empty fields render as '*' to match the +# wildcard semantics of the underlying pattern. +__xe_caller_display() +{ + local uuid="$1" + local nl + nl=$(xe caller-list params=name-label uuid="$uuid" --minimal 2>/dev/null) + if [ -n "$nl" ]; then + echo "$nl" + else + local ua ip + ua=$(xe caller-list params=user-agent uuid="$uuid" --minimal 2>/dev/null) + ip=$(xe caller-list params=client-ip uuid="$uuid" --minimal 2>/dev/null) + echo "${ua:-*}@${ip:-*}" + fi +} + _xe() { # CA-100561 Tab completion bug when grep_options is set different then default --color=auto @@ -209,7 +229,8 @@ _xe() sdn-controller-*|\ network-sriov-*|\ vm-group-*|\ - cluster-host-*) + cluster-host-*|\ + rate-limit-*) # Chop off at the second '-' and append 'list' cmd="$(echo ${OLDSTYLE_WORDS[1]} | cut -d- -f1-2)-list";; *) @@ -223,7 +244,12 @@ _xe() IFS=$'\n,' SHOW_DESCRIPTION=1 - local name_label_cmd="$xe $cmd params=name-label,number,vm-name-label,device 2>/dev/null --minimal uuid=" + local name_label_cmd + if [ "$cmd" = "caller-list" ]; then + name_label_cmd="__xe_caller_display " + else + name_label_cmd="$xe $cmd params=name-label,number,vm-name-label,device 2>/dev/null --minimal uuid=" + fi __xe_debug "name_label_cmd is '$name_label_cmd'" set_completions_for_names "$cmd" 'uuid' "$value" "$name_label_cmd" return 1 @@ -380,6 +406,18 @@ _xe() return 0 ;; + caller-uuids) # rate-limit-create + __xe_debug "triggering autocompletion for caller-uuids" + IFS=$'\n,' + val=$(final_comma_separated_param "$value") + + SHOW_DESCRIPTION=1 + local name_label_cmd="__xe_caller_display " + __xe_debug "name_label_cmd is '$name_label_cmd'" + set_completions_for_names 'caller-list' 'uuid' "$val" "$name_label_cmd" + return 0 + ;; + allocation-algorithm) # GPU_group.allocation_algorithm __xe_debug "triggering autocompletion for allocation-algorithm" IFS=$'\n,' @@ -585,7 +623,7 @@ _xe() # Show corresponding name labels for each UUID SHOW_DESCRIPTION=1 - local name_label_cmd="$xe ${class}-list params=name-label 2>/dev/null --minimal uuid=" + local name_label_cmd="$xe ${class}-list params=name-label,device 2>/dev/null --minimal uuid=" __xe_debug "triggering autocompletion for UUIDs, list command is '${class}-list'" __xe_debug "name_label_cmd is '$name_label_cmd'" diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 065b13a04d4..839755caacc 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -377,6 +377,7 @@ let with_open_tcp server f = | addrinfo :: _ -> addrinfo.Unix.ai_addr in + debug "Connecting via TCP to [%s] port [%d]\n%!" server port ; let open Safe_resources in Unixfd.with_open_connection ~loc:__LOC__ addr @@ fun ufd -> Unixfd.with_channels ufd f @@ -386,15 +387,20 @@ let with_open_channels f = try Ok (f chs) with e -> Backtrace.is_important e ; Error e in let result = - if is_localhost !xapiserver then + if is_localhost !xapiserver then ( try + let unix_socket_path = Filename.concat "/var/lib/xcp" "xapi" in + debug "Connecting to Unix socket [%s]%!" unix_socket_path ; let open Safe_resources in - Unixfd.with_open_connection - (Unix.ADDR_UNIX (Filename.concat "/var/lib/xcp" "xapi")) + Unixfd.with_open_connection (Unix.ADDR_UNIX unix_socket_path) ~loc:__LOC__ - @@ fun chs -> Unixfd.with_channels chs wrap - with _ -> with_open_tcp !xapiserver wrap - else + @@ fun chs -> + debug "\n%!" ; + Unixfd.with_channels chs wrap + with _ -> + debug " failed\n%!" ; + with_open_tcp !xapiserver wrap + ) else with_open_tcp !xapiserver wrap in match result with Ok r -> r | Error e -> raise e diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index ca67548dc85..252a4e80cdb 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -367,6 +367,7 @@ let parse_vif vm_id (x, idx) = ; ipv6_configuration= Unspecified6 ; pvs_proxy= None ; vlan= None + ; trunks= [] } let print_vm id = diff --git a/ocaml/xenopsd/lib/bootloader.ml b/ocaml/xenopsd/lib/bootloader.ml index 2c07a7d1945..1c2742037b8 100644 --- a/ocaml/xenopsd/lib/bootloader.ml +++ b/ocaml/xenopsd/lib/bootloader.ml @@ -78,11 +78,12 @@ let command bootloader q pv_bootloader_args image vm_uuid domid = let image = [image] in match bootloader_of_string bootloader with | Some Pygrub -> + let uid = (Unix.getpwnam "qemu_base").pw_uid + domid in let args = [ ["--output-format=simple"] ; q - ; [Printf.sprintf "--domid=%d" domid] + ; [Printf.sprintf "--runas=%d" uid] ; (* --vm is unnecessary for pygrub and not supported upstream *) pv_bootloader_args ; image diff --git a/ocaml/xenopsd/lib/migrate_connect.ml b/ocaml/xenopsd/lib/migrate_connect.ml new file mode 100644 index 00000000000..7be9ace70d1 --- /dev/null +++ b/ocaml/xenopsd/lib/migrate_connect.ml @@ -0,0 +1,243 @@ +(* + * Copyright (c) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(* TLS transport for the VM-migration data connections in [Xenops_server]. + + When [migration-tls = "ktls"] is set in xenopsd.conf and the migration URI + uses https, this module spawns the external [ktls-helper] binary to + perform the TLS handshake and install a kTLS-enabled socket in the kernel, + then receives the resulting socket fd via SCM_RIGHTS and passes it to the + caller. The fd behaves like an ordinary TCP socket for [read]/[write]: the + kernel encrypts outgoing data and decrypts incoming data transparently. + + On any failure to PRODUCE the kTLS fd (helper missing, handshake error, + kTLS install rejected by the kernel, SCM_RIGHTS message lost, ...) this + module logs a single [warn] and transparently falls back to the existing + [Open_uri.with_open_uri] (stunnel) path, so the migration still succeeds + over TLS. Failures raised AFTER the fd has been handed to the caller are + migration-layer failures and propagate unchanged. *) + +module D = Debug.Make (struct let name = "migrate_connect" end) + +(* Transport selected by the xenopsd.conf [migration-tls] option. Empty or + unknown values mean the default stunnel path (the historical behaviour). *) +module Migration_tls = struct + type t = Stunnel | Ktls + + let to_string = function Stunnel -> "stunnel" | Ktls -> "ktls" + + (* Parse a conf value, defaulting unknown/empty to [Stunnel] with a warning. + Config parsing must never crash xenopsd, so this does not raise (mirrors + the [Xenops_server.compressor] convention). *) + let of_string s = + match String.lowercase_ascii (String.trim s) with + | "" | "stunnel" -> + Stunnel + | "ktls" -> + Ktls + | other -> + D.warn "unknown migration-tls value %S; using stunnel" other ; + Stunnel +end + +let migration_tls = ref Migration_tls.Stunnel + +let ktls_enabled () = !migration_tls = Migration_tls.Ktls + +(* Path to the helper binary. Registered as an Xcp_service resource + ("xenopsd-tls-helper") so it is access-checked at startup and overridable in + xenopsd.conf; this ref holds the resolved path. *) +let helper_path = ref "/usr/libexec/xapi/ktls-helper" + +(* Maximum time to wait for the helper to finish handshaking and hand back the + fd before abandoning the kTLS path and falling back to stunnel. *) +let helper_timeout = ref 30.0 + +(* Default port for an https URI with no explicit port. NB: [Constants.https_port] + would couple xenopsd's library to xapi-consts; that coupling was reverted for + a build issue, so the value is kept local here. *) +let default_https_port = 443 + +(* Close [fd] ignoring errors, via the canonical stdext helper. *) +let close_ignore fd = + Xapi_stdext_pervasives.Pervasiveext.ignore_exn (fun () -> Unix.close fd) + +let protect ~finally protected = + Xapi_stdext_pervasives.Pervasiveext.finally protected finally + +(* [let@ () = protect ~finally:cleanup in body] runs [body] then always runs + [cleanup], reading top to bottom instead of nesting [body] inside a thunk. *) +let ( let@ ) f x = f x + +let recv_one_fd sock = + (* The 16-byte buffer holds enough space for the throwaway 1-byte SCM_RIGHTS + control payload the helper sends alongside the fd. *) + let buf = Bytes.make 16 '\000' in + let _len, _, fd = Fd_send_recv.recv_fd sock buf 0 (Bytes.length buf) [] in + fd + +(* Build the helper argv from the resolved verification policy and the options. + [verify_cert] is the same [Stunnel.verification_config option] the stunnel + fallback would use, so the kTLS path honours the pool's certificate- + verification on/off switch (single source of truth). *) +let helper_args ~host ~port ~fd_uuid ~verify_cert = + (* SNI selects which certificate the destination serves (the pool-internal + cert), independently of whether we verify it, so it is always sent — the + migration profile uses "pool", matching the stunnel client. *) + let sni_name = + Option.bind verify_cert (fun cfg -> cfg.Stunnel.sni) + |> Option.value ~default:"pool" + in + let verify_args = + match verify_cert with + | None -> + (* No CA to verify against: certificate verification is disabled + pool-wide (/var/xapi/verify-certificates absent or emergency-disabled) + or this is a cross-pool migration. This is the same [verify_cert] the + stunnel fallback receives, so the kTLS path mirrors stunnel exactly + and is never more permissive. *) + ["--no-verify"] + | Some cfg -> + ["--cert-bundle-file"; cfg.Stunnel.cert_bundle_path] + in + (* Pass the cipher list and ECDHE curve the helper must negotiate, sourced + from the same [Stunnel.Openssl] values the stunnel client uses, so the two + paths stay in lock-step and the helper carries no cipher policy of its own. *) + let cipher_args = + [ + "--ciphers" + ; Stunnel.Openssl.default_ciphers + ; "--curves" + ; Stunnel.Openssl.default_curve + ] + in + ["--host"; host; "--port"; string_of_int port; "--sni"; sni_name] + @ verify_args + @ cipher_args + @ ["--send-fd"; fd_uuid] + +(* Spawn the helper and return the kTLS-enabled fd it sends back via SCM_RIGHTS. + Raises on any failure; the caller decides whether to fall back. *) +let connect_via_ktls_helper ~host ~port ~verify_cert = + if not (Sys.file_exists !helper_path) then + failwith (Printf.sprintf "kTLS helper not found at %s" !helper_path) ; + let sock_xenopsd, sock_helper = + Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 + in + let fd_uuid = Uuidx.(to_string (make ())) in + let configs = [(fd_uuid, sock_helper)] in + let args = helper_args ~host ~port ~fd_uuid ~verify_cert in + D.debug "spawning %s for %s:%d" !helper_path host port ; + let pid = + (* Route the helper's stdout+stderr to syslog under "ktls-helper" so its + "kTLS active" line and any error line are visible. *) + try + Forkhelpers.safe_close_and_exec None None None configs + ~syslog_stdout:(Forkhelpers.Syslog_WithKey "ktls-helper") + ~redirect_stderr_to_stdout:true !helper_path args + with e -> close_ignore sock_helper ; close_ignore sock_xenopsd ; raise e + in + (* The helper now holds its own copy of sock_helper; we don't need ours. *) + close_ignore sock_helper ; + (* [sock_xenopsd] is closed on every path by the [protect] cleanup below; the + helper is always reaped via [waitpid] (killed first if it times out) so it + cannot leak. *) + let@ () = protect ~finally:(fun () -> close_ignore sock_xenopsd) in + let received_fd = + try + if + not + (Xapi_stdext_threads.Threadext.wait_timed_read sock_xenopsd + !helper_timeout + ) + then ( + (* Kill the helper so we don't leak it. *) + ( try Unix.kill (Forkhelpers.getpid pid) Sys.sigkill with _ -> () + ) ; + failwith + (Printf.sprintf "helper did not respond within %.0fs" !helper_timeout) + ) ; + recv_one_fd sock_xenopsd + with e -> + (try ignore (Forkhelpers.waitpid pid) with _ -> ()) ; + raise e + in + (* Reap the helper and check its exit status. Close the fd we would return on + ANY failure to confirm a clean exit (a raising waitpid, or a non-zero or + other status); on a clean exit it is handed to the caller, so it must NOT + be closed here. *) + ( try + match snd (Forkhelpers.waitpid pid) with + | Unix.WEXITED 0 -> + () + | status -> + let reason = + match status with + | Unix.WEXITED n -> + Printf.sprintf "exited with status %d" n + | Unix.WSIGNALED n -> + Printf.sprintf "killed by signal %d" n + | Unix.WSTOPPED n -> + Printf.sprintf "stopped by signal %d" n + in + failwith (Printf.sprintf "ktls-helper %s" reason) + with e -> close_ignore received_fd ; raise e + ) ; + D.debug "received kTLS fd from helper for %s:%d" host port ; + received_fd + +(** Drop-in replacement for [Open_uri.with_open_uri] on the migration paths. + + - When [migration-tls = "ktls"] and the URI is https, spawn the helper, + receive the kTLS-enabled fd via SCM_RIGHTS, and pass it to [f]. On any + failure to produce the fd, log a [warn] and fall back to + [Open_uri.with_open_uri]. + - Otherwise behave exactly as [Open_uri.with_open_uri]. *) +let with_open_uri ?verify_cert uri f = + let fallback () = Open_uri.with_open_uri ?verify_cert uri f in + let is_https = Uri.scheme uri = Some "https" in + if not (is_https && ktls_enabled ()) then + fallback () + else + match Uri.host uri with + | None -> + fallback () + | Some host -> ( + let port = Option.value ~default:default_https_port (Uri.port uri) in + (* [Open_uri]'s [?verify_cert] is itself a [verification_config option], + so this binding is an option-of-option; flatten it for the helper + (the [fallback] above re-passes the original via [?verify_cert]). *) + let verify_cert = Option.join verify_cert in + (* Only fall back to stunnel when the kTLS path fails to PRODUCE the fd + (helper spawn / handshake / kTLS install / SCM_RIGHTS). Once [f fd] + is invoked the kTLS fd has been committed; any exception raised by + [f] is a migration-layer failure and MUST propagate unchanged, since + silently retrying [f] over a fresh stunnel socket would re-enter the + in-progress migration on the destination and corrupt its state. *) + let fd_or_none = + try Some (connect_via_ktls_helper ~host ~port ~verify_cert) + with e -> + D.warn + "migration-tls=ktls connect failed for %s:%d (%s); falling back \ + to stunnel for this connection" + host port (Printexc.to_string e) ; + None + in + match fd_or_none with + | None -> + fallback () + | Some fd -> + let@ () = protect ~finally:(fun () -> close_ignore fd) in + f fd + ) diff --git a/ocaml/xenopsd/lib/migrate_connect.mli b/ocaml/xenopsd/lib/migrate_connect.mli new file mode 100644 index 00000000000..671af2f84d3 --- /dev/null +++ b/ocaml/xenopsd/lib/migrate_connect.mli @@ -0,0 +1,45 @@ +(* + * Copyright (c) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** TLS transport for the VM-migration data connections. See the module + implementation for the full description of the kTLS helper flow and the + transparent stunnel fallback. *) + +module Migration_tls : sig + type t = Stunnel | Ktls + + val to_string : t -> string + + val of_string : string -> t + (** Parse a [xenopsd.conf] [migration-tls] value; empty or unknown values + default to [Stunnel] and never raise. *) +end + +val migration_tls : Migration_tls.t ref +(** The transport selected by the [migration-tls] option in xenopsd.conf. *) + +val helper_path : string ref +(** Path to the migration TLS helper binary, registered as an Xcp_service + resource and overridable in xenopsd.conf. *) + +val with_open_uri : + ?verify_cert:Stunnel.verification_config option + -> Uri.t + -> (Unix.file_descr -> 'a) + -> 'a +(** Drop-in replacement for [Open_uri.with_open_uri] on the migration paths. + With [migration-tls = "ktls"] and an https URI, spawn the helper, receive + the kTLS-enabled fd via SCM_RIGHTS, and pass it to [f]; on any failure to + produce the fd, log a warning and fall back to [Open_uri.with_open_uri]. + Otherwise behaves exactly as [Open_uri.with_open_uri]. *) diff --git a/ocaml/xenopsd/lib/resources.ml b/ocaml/xenopsd/lib/resources.ml index 729242abe6f..3bab66702db 100644 --- a/ocaml/xenopsd/lib/resources.ml +++ b/ocaml/xenopsd/lib/resources.ml @@ -28,7 +28,7 @@ let rmmod = ref "/usr/sbin/rmmod" let hvmloader = ref "hvmloader" -let pygrub = ref "pygrub-wrapper" +let pygrub = ref "pygrub" let eliloader = ref "eliloader" diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index 8de1296c931..be9b127033d 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -120,6 +120,7 @@ type atomic = | VIF_set_ipv4_configuration of Vif.id * Vif.ipv4_configuration | VIF_set_ipv6_configuration of Vif.id * Vif.ipv6_configuration | VIF_set_active of Vif.id * bool + | VIF_set_trunks of Vif.id * int64 list (* During migration the domid of a uuid is not stable. To hide this from hooks that depend on domids, this allows the caller to provide an additonal uuid that can maintain the initial domid *) @@ -201,6 +202,8 @@ let rec name_of_atomic = function "VIF_set_ipv6_configuration" | VIF_set_active _ -> "VIF_set_active" + | VIF_set_trunks _ -> + "VIF_set_trunks" | VM_hook_script_stable _ -> "VM_hook_script_stable" | VM_hook_script _ -> @@ -1644,6 +1647,16 @@ let rec perform_atomic ~progress_callback ?result (op : atomic) debug "VIF.set_active %s %b" (VIF_DB.string_of_id id) b ; B.VIF.set_active t (VIF_DB.vm_of id) (VIF_DB.read_exn id) b ; VIF_DB.signal id + | VIF_set_trunks (id, trunks) -> + debug "VIF.set_trunks %s %s" (VIF_DB.string_of_id id) + (String.concat "," (List.map Int64.to_string trunks)) ; + finally + (fun () -> + let vif = VIF_DB.read_exn id in + B.VIF.set_trunks t (VIF_DB.vm_of id) vif trunks ; + VIF_DB.write id {vif with Vif.trunks} + ) + (fun () -> VIF_DB.signal id) | VM_hook_script_stable (id, script, reason, backend_vm_id) -> let extra_args = B.VM.get_hook_args backend_vm_id in Xenops_hooks.vm ~script ~reason ~id ~extra_args @@ -2228,7 +2241,8 @@ and trigger_cleanup_after_failure_atom op t = | VIF_set_locking_mode (id, _) | VIF_set_pvs_proxy (id, _) | VIF_set_ipv4_configuration (id, _) - | VIF_set_ipv6_configuration (id, _) -> + | VIF_set_ipv6_configuration (id, _) + | VIF_set_trunks (id, _) -> immediate_operation dbg (fst id) (VIF_check_state id) | PCI_plug (id, _) | PCI_unplug id -> immediate_operation dbg (fst id) (PCI_check_state id) @@ -2437,7 +2451,7 @@ and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = info "VM %s has memory_limit = %Ld" id state.Vm.memory_limit ; let url = make_url "/migrate/vm/" new_dest_id in let https = Uri.scheme url = Some "https" in - Open_uri.with_open_uri ~verify_cert url (fun vm_fd -> + Migrate_connect.with_open_uri ~verify_cert url (fun vm_fd -> let module Handshake = Xenops_migrate.Handshake in let do_request fd extra_cookies url = if not https then Sockopt.set_sock_keepalives fd ; @@ -2518,7 +2532,7 @@ and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = in let save ?vgpu_fd () = let url = make_url "/migrate/mem/" new_dest_id in - Open_uri.with_open_uri ~verify_cert url (fun mem_fd -> + Migrate_connect.with_open_uri ~verify_cert url (fun mem_fd -> (* vm_fd: signaling channel, mem_fd: memory stream *) do_request mem_fd [] url ; Handshake.recv_success mem_fd ; @@ -2557,7 +2571,7 @@ and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = make_url "/migrate/vgpu/" (VGPU_DB.string_of_id (new_dest_id, dev_id)) in - Open_uri.with_open_uri ~verify_cert url (fun vgpu_fd -> + Migrate_connect.with_open_uri ~verify_cert url (fun vgpu_fd -> if not https then Sockopt.set_sock_keepalives vgpu_fd ; do_request vgpu_fd [(cookie_vgpu_migration, "")] url ; Handshake.recv_success vgpu_fd ; @@ -3215,6 +3229,9 @@ module VIF = struct queue_operation dbg (DB.vm_of id) (Atomic (VIF_set_ipv6_configuration (id, ipv6_configuration))) + let set_trunks _ dbg id trunks = + queue_operation dbg (DB.vm_of id) (Atomic (VIF_set_trunks (id, trunks))) + let remove _ dbg id = Debug.with_thread_associated dbg (fun () -> DB.remove' id) () @@ -4086,6 +4103,7 @@ let _ = Server.VIF.set_ipv4_configuration (VIF.set_ipv4_configuration ()) ; Server.VIF.set_ipv6_configuration (VIF.set_ipv6_configuration ()) ; Server.VIF.set_pvs_proxy (VIF.set_pvs_proxy ()) ; + Server.VIF.set_trunks (VIF.set_trunks ()) ; Server.VGPU.add (VGPU.add ()) ; Server.VGPU.remove (VGPU.remove ()) ; Server.VGPU.stat (VGPU.stat ()) ; diff --git a/ocaml/xenopsd/lib/xenops_server_plugin.ml b/ocaml/xenopsd/lib/xenops_server_plugin.ml index 8bb8b21596e..2b078986b27 100644 --- a/ocaml/xenopsd/lib/xenops_server_plugin.ml +++ b/ocaml/xenopsd/lib/xenops_server_plugin.ml @@ -273,6 +273,9 @@ module type S = sig val get_device_action_request : Vm.id -> Vif.t -> device_action_request option + + val set_trunks : + Xenops_task.task_handle -> Vm.id -> Vif.t -> Vif.trunks -> unit end module VGPU : sig diff --git a/ocaml/xenopsd/lib/xenops_server_simulator.ml b/ocaml/xenopsd/lib/xenops_server_simulator.ml index 5256f1a91d1..5795f96b279 100644 --- a/ocaml/xenopsd/lib/xenops_server_simulator.ml +++ b/ocaml/xenopsd/lib/xenops_server_simulator.ml @@ -502,6 +502,26 @@ let set_pvs_proxy vm vif proxy () = in DB.write vm {d with Domain.vifs} +let set_trunks vm vif trunks () = + let d = DB.read_exn vm in + let this_one x = x.Vif.id = vif.Vif.id in + let vifs = + List.map + (fun vif -> + { + vif with + Vif.trunks= + ( if this_one vif then + trunks + else + vif.Vif.trunks + ) + } + ) + d.Domain.vifs + in + DB.write vm {d with Domain.vifs} + let remove_pci vm pci () = let d = DB.read_exn vm in let this_one x = x.Pci.id = pci.Pci.id in @@ -738,6 +758,8 @@ module VIF = struct let get_state vm vif = with_lock m (vif_state vm vif) let get_device_action_request _vm _vif = None + + let set_trunks _ vm vif trunks = with_lock m (set_trunks vm vif trunks) end module UPDATES = struct diff --git a/ocaml/xenopsd/lib/xenops_server_skeleton.ml b/ocaml/xenopsd/lib/xenops_server_skeleton.ml index d812910fd27..20c66c95a21 100644 --- a/ocaml/xenopsd/lib/xenops_server_skeleton.ml +++ b/ocaml/xenopsd/lib/xenops_server_skeleton.ml @@ -190,6 +190,8 @@ module VIF = struct let get_state _ _ = unplugged_vif let get_device_action_request _ _ = None + + let set_trunks _ _ = unimplemented __FUNCTION__ end module VGPU = struct diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index 4f3a0643014..c850b4ca038 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -340,6 +340,20 @@ let options = , (fun () -> !Xenops_server.migration_compressor) , "Compression method; one of 'stream' (default), 'xenguest'" ) + ; ( "migration-tls" + , Arg.String + (fun s -> + Migrate_connect.migration_tls := + Migrate_connect.Migration_tls.of_string s + ) + , (fun () -> + Migrate_connect.Migration_tls.to_string !Migrate_connect.migration_tls + ) + , "TLS transport for VM migration: 'stunnel' (default) uses the stunnel \ + client subprocess; 'ktls' uses the ktls-helper to install kTLS on the \ + migration socket. On any failure the 'ktls' path logs a warning and \ + falls back to stunnel." + ) ] let path () = Filename.concat !sockets_path "xenopsd" diff --git a/ocaml/xenopsd/scripts/make-custom-xenopsd.conf b/ocaml/xenopsd/scripts/make-custom-xenopsd.conf index 59f52269157..0a75155beb1 100755 --- a/ocaml/xenopsd/scripts/make-custom-xenopsd.conf +++ b/ocaml/xenopsd/scripts/make-custom-xenopsd.conf @@ -45,7 +45,6 @@ setup-vif-rules=${XENOPSD_LIBEXECDIR}/setup-vif-rules sockets-group=$group qemu-wrapper=${QEMU_WRAPPER_DIR}/qemu-wrapper swtpm-wrapper=${QEMU_WRAPPER_DIR}/qemu-wrapper -pygrub-wrapper=${QEMU_WRAPPER_DIR}/pygrub-wrapper disable-logging-for=http # Workaround xenopsd bug #45 diff --git a/ocaml/xenopsd/scripts/pygrub-wrapper b/ocaml/xenopsd/scripts/pygrub-wrapper deleted file mode 100644 index e55121745bf..00000000000 --- a/ocaml/xenopsd/scripts/pygrub-wrapper +++ /dev/null @@ -1,33 +0,0 @@ -#! /usr/bin/python3 -# -# Copyright (C) 2023 Cloud Software Group -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published -# by the Free Software Foundation; version 2.1 only. with the special -# exception on linking described in file LICENSE. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. - - -import pwd, subprocess, sys - -cmd = ["/usr/libexec/xen/bin/pygrub"] - -# Get the usage string. We can't use check_output() because the exit status isn't 0 -pygrub_usage = subprocess.Popen(cmd, stdout=subprocess.PIPE, stderr=subprocess.PIPE, universal_newlines=True).communicate()[1] - -for arg in sys.argv[1:]: - # Catch the synthetic --domid argument and turn it into --runas - argname_domid = "--domid=" - if arg.startswith(argname_domid): - domid = int(arg[len(argname_domid):]) - uid = pwd.getpwnam('qemu_base').pw_uid + domid - cmd += ["--runas=" + str(uid)] - else: - cmd += [arg] - -sys.exit(subprocess.call(cmd)) diff --git a/ocaml/xenopsd/scripts/vif-real b/ocaml/xenopsd/scripts/vif-real index 25662c9bf02..eefb78e68de 100755 --- a/ocaml/xenopsd/scripts/vif-real +++ b/ocaml/xenopsd/scripts/vif-real @@ -107,6 +107,29 @@ handle_mtu() fi } +handle_trunks() +{ + local trunks + + if trunks=$(xenstore-read "${PRIVATE}/trunks" 2>/dev/null); then + case $NETWORK_MODE in + bridge) + logger -t scripts-vif "${dev}: trunks is not supported via bridge mode." + ;; + openvswitch) + logger -t scripts-vif "Setting ${dev} trunks ${trunks}" + if [ -z "${trunks}" ]; then + ${vsctl} clear Port "${dev}" trunks || logger -t scripts-vif "Failed to ovs-vsctl clear Port ${dev} trunks. Error code $?" + else + ${vsctl} set Port "${dev}" "trunks=${trunks}" || logger -t scripts-vif "Failed to ovs-vsctl set Port ${dev} trunks=${trunks}. Error code $?" + fi + ;; + esac + else + handle_error "Failed to read ${PRIVATE}/trunks" + fi +} + add_to_bridge() { local address=$(xenstore-read "${PRIVATE}/bridge-MAC") @@ -234,6 +257,7 @@ online) handle_mtu add_to_bridge + handle_trunks handle_promiscuous # only for the benefit of xenrt test case, see CA-61528 @@ -250,6 +274,7 @@ add) if [ "${TYPE}" = "tap" ] ; then handle_mtu add_to_bridge + handle_trunks fi ;; @@ -270,5 +295,6 @@ remove) move) if [ "${TYPE}" = "vif" ] ;then add_to_bridge + handle_trunks fi esac diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index a2971937d79..bb82b3acaa1 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -822,14 +822,15 @@ end module Vif = struct let add ~xs ~devid ~mac ?mtu ?(rate = None) ?(backend_domid = 0) - ?(other_config = []) ~netty ~carrier ?(protocol = Protocol_Native) + ?(other_config = []) ~netty ~carrier ~trunks ?(protocol = Protocol_Native) ?(extra_private_keys = []) ?(extra_xenserver_keys = []) (task : Xenops_task.task_handle) domid = debug - "Device.Vif.add domid=%d devid=%d mac=%s carrier=%b rate=%s \ + "Device.Vif.add domid=%d devid=%d mac=%s carrier=%b rate=%s trunks=%s \ other_config=[%s] extra_private_keys=[%s] extra_xenserver_keys=[%s]" domid devid mac carrier (match rate with None -> "none" | Some (a, b) -> sprintf "(%Ld,%Ld)" a b) + (String.concat "," (List.map Int64.to_string trunks)) (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) other_config)) (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) extra_private_keys) @@ -917,6 +918,7 @@ module Vif = struct let extra_private_keys = extra_private_keys @ ("mac", mac) + :: ("trunks", String.concat "," (List.map Int64.to_string trunks)) :: ( match mtu with | Some mtu when mtu > 0 -> diff --git a/ocaml/xenopsd/xc/device.mli b/ocaml/xenopsd/xc/device.mli index 0bf45bf4e10..8bfad2d862f 100644 --- a/ocaml/xenopsd/xc/device.mli +++ b/ocaml/xenopsd/xc/device.mli @@ -167,6 +167,7 @@ module Vif : sig -> ?other_config:(string * string) list -> netty:Netman.netty -> carrier:bool + -> trunks:int64 list -> ?protocol:protocol -> ?extra_private_keys:(string * string) list -> ?extra_xenserver_keys:(string * string) list diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index b4972cacc38..92ee3638751 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -74,6 +74,7 @@ type domain_create_flag = Xenctrl.domain_create_flag = | CDF_IOMMU | CDF_NESTED_VIRT | CDF_VPMU + | CDF_TRAP_UNMAPPED_ACCESSES [@@deriving rpcty] type domain_create_iommu_opts = Xenctrl.domain_create_iommu_opts = @@ -107,6 +108,7 @@ type domctl_create_config = Xenctrl.domctl_create_config = { ; max_maptrack_frames: int ; max_grant_version: int ; altp2m_opts: int32 + ; altp2m_count: int32 ; vmtrace_buf_kb: int32 ; cpupool_id: int32 ; arch: arch_domainconfig @@ -378,7 +380,24 @@ let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept in let vpmu = get_platform_key ~key:"vpmu" ~default:false (fun _ -> Ok ()) in - info "VM = %s; Creating %s%s%s%s%s" (Uuidx.to_string uuid) + let is_arm = + match (domain_config : arch_domainconfig) with + | ARM _ -> + true + | X86 _ -> + false + in + let require_arm wants : (_, _) result = + if wants && not is_arm then + Error "Arm required for" + else + Ok () + in + let trap_unmapped_accesses = + get_platform_key ~key:"trap-unmapped-accesses" ~default:is_arm require_arm + in + + info "VM = %s; Creating %s%s%s%s%s%s" (Uuidx.to_string uuid) ( if hvm then "HVM" else @@ -403,6 +422,11 @@ let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept " VPMU" else "" + ) + ( if trap_unmapped_accesses then + " TRAP_UNMAPPED_ACCESSES" + else + "" ) ; let config = @@ -416,6 +440,7 @@ let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept ; (iommu, CDF_IOMMU) ; (nested_virt, CDF_NESTED_VIRT) ; (vpmu, CDF_VPMU) + ; (trap_unmapped_accesses, CDF_TRAP_UNMAPPED_ACCESSES) ] |> List.filter_map (fun (cond, flag) -> if cond then @@ -517,6 +542,7 @@ let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept 1 ) ; altp2m_opts= 0l + ; altp2m_count= 0l ; vmtrace_buf_kb= 0l ; cpupool_id= 0l ; arch= domain_config diff --git a/ocaml/xenopsd/xc/xc_resources.ml b/ocaml/xenopsd/xc/xc_resources.ml index 2199fb04ab6..154d409e805 100644 --- a/ocaml/xenopsd/xc/xc_resources.ml +++ b/ocaml/xenopsd/xc/xc_resources.ml @@ -49,6 +49,8 @@ let alternatives = ref "/usr/lib/xapi/alternatives" let usb_reset_script = ref "/opt/xensource/libexec/usb_reset.py" +let ovs_vsctl = ref "/usr/bin/ovs-vsctl" + open Unix let essentials = @@ -71,6 +73,7 @@ let essentials = , setup_pvs_proxy_rules , "path to the setup-pvs-proxy-rules script" ) + ; (X_OK, "ovs-vsctl", ovs_vsctl, "path to the ovs-vsctl binary") ] @ Resources.network_configuration @@ -91,6 +94,11 @@ let nonessentials = , igmp_query_injector_script , "path to the igmp query injector script" ) + ; ( X_OK + , "xenopsd-tls-helper" + , Migrate_connect.helper_path + , "path to the ktls-helper binary used when migration-tls=ktls" + ) ] @ Resources.hvm_guests @ Resources.pv_guests diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index 5835edf79ed..2f17eb6e739 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -5026,6 +5026,7 @@ module VIF = struct (vif.carrier && vif.locking_mode <> Xenops_interface.Vif.Disabled ) + ~trunks:vif.trunks ~extra_private_keys: ((id :: vif.extra_private_keys) @ locking_mode @@ -5467,6 +5468,62 @@ module VIF = struct with Xenopsd_error Device_not_connected -> None ) ) + + let set_trunks _task vm vif trunks = + debug "set_trunks: enter" ; + with_xc_and_xs (fun xc xs -> + match vif.backend with + | Network.Sriov _ -> + raise (Xenopsd_error (Unimplemented "network SR-IOV")) + | Network.Local _ | Network.Remote _ -> + (* If the device is gone then this is ok *) + let device = device_by_id xc xs vm Vif (id_of vif) in + let path = Device_common.get_private_data_path_of_device device in + let trunks_path = path ^ "/trunks" in + let trunks_str = + String.concat "," (List.map Int64.to_string trunks) + in + (* Update xenstore key *) + xs.Xs.write trunks_path trunks_str ; + (* Apply the configuration *) + let setup port_name = + debug "set_trunks: setup: %s trunks=[%s]" port_name trunks_str ; + try + if trunks = [] then + ignore + (run !Xc_resources.ovs_vsctl + ["clear"; "Port"; port_name; "trunks"] + ) + else + ignore + (run !Xc_resources.ovs_vsctl + [ + "set" + ; "Port" + ; port_name + ; Printf.sprintf "trunks=%s" trunks_str + ] + ) + with exc -> + if String.starts_with ~prefix:"tap" port_name then + (* Might not exists if the VM has PV drivers loaded. *) + () + else + raise exc + in + let devid = string_of_int device.frontend.devid in + let di = Xenctrl.domain_getinfo xc device.frontend.domid in + let port_list = + Printf.sprintf "vif%d.%s" device.frontend.domid devid + :: + ( if VM.get_domain_type ~xs di = Vm.Domain_HVM then + [Printf.sprintf "tap%d.%s" device.frontend.domid devid] + else + [] + ) + in + List.iter setup port_list + ) end module UPDATES = struct diff --git a/ocaml/xenopsd/xenopsd.conf b/ocaml/xenopsd/xenopsd.conf index e12a19073a7..aed5d481fc5 100644 --- a/ocaml/xenopsd/xenopsd.conf +++ b/ocaml/xenopsd/xenopsd.conf @@ -86,6 +86,7 @@ disable-logging-for=http tracing tracing_export # umount=/bin/umount # ionice=/usr/bin/ionice # chgrp=/bin/chgrp +# ovs-vsctl=/usr/bin/ovs-vsctl # Default backend for VBDs (used in XenStore) # default-vbd-backend-kind=vbd @@ -126,3 +127,18 @@ disable-logging-for=http tracing tracing_export # Compression method used when migration compression is enabled - either stream or xenguest. # migration-compressor = "stream" +# TLS transport for VM live migration. +# "stunnel" — default; spawn one stunnel client subprocess per migration +# "ktls" — spawn the ktls-helper instead. The helper performs the +# TLS handshake, installs the symmetric keys into the kernel via +# kTLS, and hands the kTLS-enabled socket fd back to xenopsd over +# SCM_RIGHTS. Subsequent reads/writes are decrypted/encrypted by +# the kernel — no stunnel pipe on the data path. +# If the 'ktls' helper fails for any reason xenopsd logs a warning and +# transparently falls back to the stunnel path for that one connection, +# so the migration still succeeds. +# migration-tls = "stunnel" + +# Path to the ktls-helper binary (used only when migration-tls=ktls). +# xenopsd-tls-helper = "/usr/libexec/xapi/ktls-helper" + diff --git a/opam/xapi-debug.opam b/opam/xapi-debug.opam index bbfb1827c25..a20cae4ebb9 100644 --- a/opam/xapi-debug.opam +++ b/opam/xapi-debug.opam @@ -55,6 +55,7 @@ depends: [ "x509" "xapi-log" "xapi-types" + "xapi-rate-limit" "xapi-stdext-pervasives" "xapi-stdext-unix" "xapi-stdext-zerocheck" diff --git a/opam/xapi-rate-limit.opam b/opam/xapi-rate-limit.opam new file mode 100644 index 00000000000..29795d7fa31 --- /dev/null +++ b/opam/xapi-rate-limit.opam @@ -0,0 +1,37 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "A simple token bucket-based rate limter for XAPI" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "3.20"} + "ocaml" {>= "4.12"} + "clock" {= version} + "mtime" + "xapi-log" {= version} + "xapi-stdext-threads" {= version} + "alcotest" {with-test} + "fmt" {with-test} + "qcheck-core" {with-test} + "qcheck-alcotest" {with-test} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-storage-cli.opam b/opam/xapi-storage-cli.opam index ab152653112..1f1c9a242e7 100644 --- a/opam/xapi-storage-cli.opam +++ b/opam/xapi-storage-cli.opam @@ -16,6 +16,7 @@ depends: [ "ppx_deriving_rpc" "xapi-client" {= version} "xapi-idl" {= version} + "xapi-rate-limit" {= version} "xapi-types" {= version} "xapi-stdext-zerocheck" {= version} "xapi-work-queues" {= version} diff --git a/opam/xapi.opam b/opam/xapi.opam index 1db83dc844e..2bfea8405d7 100644 --- a/opam/xapi.opam +++ b/opam/xapi.opam @@ -78,6 +78,7 @@ depends: [ "xapi-idl" {= version} "xapi-inventory" {= version} "xapi-log" {= version} + "xapi-rate-limit" {= version} "xapi-stdext-pervasives" {= version} "xapi-stdext-std" {= version} "xapi-stdext-threads" {= version} diff --git a/pyproject.toml b/pyproject.toml index 512eac89030..f949d1123ec 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -10,7 +10,7 @@ maintainers = [ {name = "Rob Hoes"}, {name = "Pau Ruiz Safont"}, ] -readme = "README.markdown" +readme = "README.md" # https://pypi.org/classifiers/ classifiers = [ "Development Status :: 5 - Production/Stable", diff --git a/quality-gate.sh b/quality-gate.sh index 228cf58e0e7..6b1e6466d2d 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=453 + N=455 X="ocaml/tests" X+="|ocaml/quicktest" X+="|ocaml/message-switch/core_test" @@ -44,7 +44,7 @@ mli-files () { } structural-equality () { - N=9 + N=10 EQ=$(git grep -r --count ' == ' -- '**/*.ml' ':!ocaml/sdk-gen/**/*.ml' | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$EQ" -eq "$N" ]; then echo "OK counted $EQ usages of ' == '" diff --git a/scripts/Makefile b/scripts/Makefile index 403279ad379..fd95cd191b2 100644 --- a/scripts/Makefile +++ b/scripts/Makefile @@ -109,6 +109,7 @@ install: $(IPROG) pam.d-xapi $(DESTDIR)/etc/pam.d/xapi $(IPROG) upload-wrapper logs-download $(DESTDIR)$(LIBEXECDIR) $(IDATA) usb-policy.conf $(DESTDIR)$(ETCXENDIR) + $(IDATA) call-costs.conf $(DESTDIR)$(ETCXENDIR) mkdir -p $(DESTDIR)$(OPTDIR)/packages/iso #omg XXX $(IPROG) xapi-rolling-upgrade-miami $(DESTDIR)$(LIBEXECDIR)/xapi-rolling-upgrade $(IPROG) set-hostname $(DESTDIR)$(LIBEXECDIR) diff --git a/scripts/attach-static-vdis b/scripts/attach-static-vdis index 2745fa82ada..cab5688a05b 100755 --- a/scripts/attach-static-vdis +++ b/scripts/attach-static-vdis @@ -2,6 +2,8 @@ # # attach-static-vdis Attaches any statically-configured VDIs to dom0 +shopt -s nullglob + STATE_DIR=/etc/xensource/static-vdis [ -d ${STATE_DIR} ] || exit 0 @@ -52,7 +54,7 @@ start() { clear_stale_state attach_all RC=$? - echo + echo return $RC } diff --git a/scripts/call-costs.conf b/scripts/call-costs.conf new file mode 100644 index 00000000000..4e4d7cd84b8 --- /dev/null +++ b/scripts/call-costs.conf @@ -0,0 +1,97 @@ +# Per-call token costs used by xapi's per-caller rate limiting. +# +# Each line maps an API call to the number of tokens it consumes against a +# caller's rate-limit bucket, in "Class.method = cost" form. One token roughly +# corresponds to a cheap DB read; expensive operations cost multiples. Lines +# starting with '#' are comments. Calls without an entry here use a cost of 1. +# +# This file is read once, when xapi starts. Edit the values or add new calls and +# restart xapi to apply the changes; no recompilation is required. + +VDI.pool_migrate = 2500 +VM.migrate_send = 2000 +VM.suspend = 400 +VM.resume_on = 400 +SR.probe = 400 +VM.copy = 300 +pool.enable_ha = 300 +VM.checkpoint = 200 +host.ha_join_liveset = 200 +Cluster.pool_create = 200 +VDI.copy = 200 +VM.pool_migrate = 200 +VM.resume = 200 +SR.destroy = 200 +Cluster_host.create = 150 +event.from = 150 +pool.management_reconfigure = 100 +pool.join = 100 +pool.disable_ha = 100 +host.prepare_for_poweroff = 100 +VM.set_memory_dynamic_range = 100 +host.evacuate = 75 +VM.clean_reboot = 70 +VM.restart_device_models = 70 +pool_update.apply = 70 +Bond.create = 60 +VM.clean_shutdown = 60 +VM.revert = 50 +host.install_server_certificate = 50 +pool.eject = 40 +Cluster.create = 40 +pool.sync_updates = 40 +host.apply_updates = 40 +SR.probe_ext = 40 +host.ha_wait_for_shutdown_via_statefile = 40 +pool_update.precheck = 30 +event.next = 30 +VDI.snapshot = 30 +pool_update.introduce = 30 +pool.enable_external_auth = 20 +VM.start_on = 20 +VM.hard_reboot = 20 +SR.create = 20 +VM.hard_shutdown = 20 +pool.designate_new_master = 20 +VM.start = 20 +VDI.clone = 20 +host.ha_release_resources = 15 +VM.snapshot = 15 +pool.is_slave = 15 +pool.recover_slaves = 15 +host.preconfigure_ha = 15 +pool_update.detach = 15 +pool_update.attach = 15 +host.update_master = 15 +PBD.plug = 15 +Repository.apply = 12 +pool.emergency_reset_master = 12 +VBD.plug = 12 +host.commit_new_master = 12 +SR.scan = 10 +VBD.unplug = 10 +pool_update.pool_clean = 10 +VM.clone = 10 +VM.provision = 10 +PIF.reconfigure_ip = 10 +pool.create_VLAN_from_PIF = 8 +pool.apply_edition = 8 +pool.disable_external_auth = 7 +VM.pool_migrate_complete = 7 +host.call_plugin = 7 +VLAN.create = 6 +VDI.create = 6 +host.update_firewalld_service_status = 6 +VDI.destroy = 5 +VIF.plug = 5 +host.set_iscsi_iqn = 5 +SR.update = 5 +VDI.resize = 5 +host.management_reconfigure = 4 +VIF.unplug = 3 +host.set_https_only = 3 +PIF.plug = 3 +host.disable_external_auth = 3 +VDI.set_name_label = 3 +VDI.set_name_description = 3 +PIF.scan = 3 diff --git a/scripts/xapi.conf b/scripts/xapi.conf index e8df3cf739b..a8d7b7003c3 100644 --- a/scripts/xapi.conf +++ b/scripts/xapi.conf @@ -47,6 +47,15 @@ inventory = /etc/xensource-inventory # Optional configuration file for udchp # udhcpd-conf = @ETCXENDIR@/udhcpd.conf +# File mapping API calls to their rate-limiting token cost +# call-costs-file = @ETCXENDIR@/call-costs.conf + +# Maximum number of callers auto-registered for rate limiting. When the limit +# is reached, the auto-registered caller with the least recent call is dropped. +# A value of 0 disables auto-registration; a negative value means unbounded. +# Manually created callers are not counted. +# max-auto-registered-callers = 100 + # Enable/disable the watchdog # nowatchdog = false diff --git a/unixpwd/c/unixpwd_stubs.c b/unixpwd/c/unixpwd_stubs.c index 7b7046940d7..6809d759135 100644 --- a/unixpwd/c/unixpwd_stubs.c +++ b/unixpwd/c/unixpwd_stubs.c @@ -13,6 +13,7 @@ */ #include +#include #include #include @@ -24,23 +25,29 @@ #include "unixpwd.h" - -CAMLprim value -caml_unixpwd_getpwd(value caml_user) +static value caml_unixpwd_get_(value caml_user, const char *fname, char*(*f)(const char*)) { CAMLparam1(caml_user); - const char *user; - char *passwd; + char *user; + char *passwd; + int saved_errno; CAMLlocal1(pw); - user = String_val(caml_user); + user = caml_stat_strdup(String_val(caml_user)); caml_release_runtime_system(); - passwd = unixpwd_getpwd(user); + errno = 0; + passwd = f(user); + saved_errno = errno; caml_acquire_runtime_system(); - if (passwd == NULL && errno != 0) - caml_failwith(strerror(errno)); - if (passwd == NULL) - caml_failwith("unspecified error in caml_unixpwd_getpwd()"); + caml_stat_free(user); user = NULL; + errno = saved_errno; + + if (passwd == NULL) { + char msg[128]; + + snprintf(msg, sizeof(msg), "unspecified error in %s()", fname); + caml_failwith(saved_errno ? strerror(saved_errno) : msg); + } pw = caml_copy_string(passwd); free(passwd); @@ -48,87 +55,57 @@ caml_unixpwd_getpwd(value caml_user) } CAMLprim value -caml_unixpwd_getspw(value caml_user) +caml_unixpwd_getpwd(value caml_user) { - CAMLparam1(caml_user); - const char *user; - char *passwd; - CAMLlocal1(pw); - - user = String_val(caml_user); - caml_release_runtime_system(); - passwd = unixpwd_getspw(user); - caml_acquire_runtime_system(); - if (passwd == NULL && errno != 0) - caml_failwith(strerror(errno)); - if (passwd == NULL) - caml_failwith("unspecified error in caml_unixpwd_getspw()"); - - pw = caml_copy_string(passwd); - free(passwd); - CAMLreturn(pw); + return caml_unixpwd_get_(caml_user, "unixpwd_getpwd", unixpwd_getpwd); } - +CAMLprim value +caml_unixpwd_getspw(value caml_user) +{ + return caml_unixpwd_get_(caml_user, "unixpwd_getspw", unixpwd_getspw); +} CAMLprim value caml_unixpwd_get(value caml_user) { - CAMLparam1(caml_user); - const char *user; - char *passwd; - CAMLlocal1(pw); - - user = String_val(caml_user); - caml_release_runtime_system(); - passwd = unixpwd_get(user); - caml_acquire_runtime_system(); - if (passwd == NULL && errno != 0) - caml_failwith(strerror(errno)); - if (passwd == NULL) - caml_failwith("unspecified error in caml_unixpwd_get()"); - - pw = caml_copy_string(passwd); - free(passwd); - CAMLreturn(pw); + return caml_unixpwd_get_(caml_user, "unixpwd_get", unixpwd_get); } -CAMLprim value -caml_unixpwd_setpwd(value caml_user, value caml_password) +static value caml_unixpwd_set_(value caml_user, value caml_password, const char *fname, int(*f)(const char*, char*)) { CAMLparam2(caml_user, caml_password); - const char *user; - char *password; - int rc; + char *user; + char *password; + int rc; - user = String_val(caml_user); + user = caml_stat_strdup(String_val(caml_user)); password = caml_stat_strdup(String_val(caml_password)); - caml_release_runtime_system(); - rc = unixpwd_setpwd(user, password); + rc = f(user, password); caml_acquire_runtime_system(); - + caml_stat_free(user); caml_stat_free(password); - if (rc != 0) - caml_failwith(strerror(rc)); + + if (rc != 0) { + char msg[128]; + + snprintf(msg, sizeof(msg), "%s: %s", fname, strerror(rc)); + caml_failwith(msg); + } CAMLreturn(Val_unit); } CAMLprim value -caml_unixpwd_setspw(value caml_user, value caml_password) +caml_unixpwd_setpwd(value caml_user, value caml_password) { - CAMLparam2(caml_user, caml_password); - const char *user; - char *password; - int rc; + return caml_unixpwd_set_(caml_user, caml_password, "unixpwd_setpwd", + unixpwd_setpwd); +} - user = String_val(caml_user); - password = caml_stat_strdup(String_val(caml_password)); - caml_release_runtime_system(); - rc = unixpwd_setspw(user, password); - caml_acquire_runtime_system(); - caml_stat_free(password); - if (rc != 0) - caml_failwith(strerror(rc)); - CAMLreturn(Val_unit); +CAMLprim value +caml_unixpwd_setspw(value caml_user, value caml_password) +{ + return caml_unixpwd_set_(caml_user, caml_password, "unixpwd_setspw", + unixpwd_setspw); }