diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index 721e2c6322..0b89883615 100644 --- a/.git-blame-ignore-revs +++ b/.git-blame-ignore-revs @@ -32,6 +32,7 @@ d6ab15362548b8fe270bd14d5153b8d94e1b15c0 b12cf444edea15da6274975e1b2ca6a7fce2a090 364c27f5d18ab9dd31825e67a93efabecad06823 d8b4de9076531dd13bdffa20cc10c72290a52356 +bdf06bca7534fbc0c4fc3cee3408a51a22615226 # ocp-indent d018d26d6acd4707a23288b327b49e44f732725e diff --git a/.github/workflows/1.249-lcm.yml b/.github/workflows/1.249-lcm.yml index 8057b255a9..8ba69e28ec 100644 --- a/.github/workflows/1.249-lcm.yml +++ b/.github/workflows/1.249-lcm.yml @@ -10,7 +10,7 @@ on: jobs: python-test: name: Python tests - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 permissions: contents: read strategy: @@ -28,7 +28,7 @@ jobs: ocaml-test: name: Ocaml tests - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 steps: - name: Checkout code diff --git a/.github/workflows/codechecker.yml b/.github/workflows/codechecker.yml index da8ea12c00..bb3a9fa430 100644 --- a/.github/workflows/codechecker.yml +++ b/.github/workflows/codechecker.yml @@ -31,6 +31,7 @@ jobs: uses: ./.github/workflows/setup-xapi-environment with: xapi_version: ${{ env.XAPI_VERSION }} + ocaml_version: "4.14.2" - name: Install dune-compiledb to generate compile_commands.json run: | @@ -38,7 +39,7 @@ jobs: opam pin add -y dune-compiledb https://github.com/edwintorok/dune-compiledb/releases/download/0.6.0/dune-compiledb-0.6.0.tbz - name: Trim dune cache - run: opam exec -- dune cache trim --size=2GiB + run: opam exec -- dune cache trim --size=2GiB - name: Generate compile_commands.json run: opam exec -- make compile_commands.json @@ -73,7 +74,10 @@ jobs: name: codechecker_sarif path: codechecker.sarif - - name: Upload SARIF report - uses: github/codeql-action/upload-sarif@v3 - with: - sarif_file: codechecker.sarif + # TODO: reenable after fixing + # https://github.blog/changelog/2025-07-21-code-scanning-will-stop-combining-multiple-sarif-runs-uploaded-in-the-same-sarif-file/ + # + #- name: Upload SARIF report + # uses: github/codeql-action/upload-sarif@v3 + # with: + # sarif_file: codechecker.sarif diff --git a/.github/workflows/generate-and-build-sdks.yml b/.github/workflows/generate-and-build-sdks.yml index ca1a67a4c7..1c9ec9dd7f 100644 --- a/.github/workflows/generate-and-build-sdks.yml +++ b/.github/workflows/generate-and-build-sdks.yml @@ -24,22 +24,12 @@ jobs: uses: ./.github/workflows/setup-xapi-environment with: xapi_version: ${{ inputs.xapi_version }} + ocaml_version: "4.14.2" - name: Generate SDKs shell: bash run: opam exec -- make sdk - # sdk-ci runs some Go unit tests. - # This setting ensures that SDK date time - # tests are run on a machine that - # isn't using UTC - - name: Set Timezone to Tokyo for datetime tests - run: | - sudo timedatectl set-timezone Asia/Tokyo - - - name: Run CI for SDKs - uses: ./.github/workflows/sdk-ci - - name: Store C SDK source uses: actions/upload-artifact@v4 with: @@ -60,7 +50,13 @@ jobs: name: SDK_Source_PowerShell path: _build/install/default/share/powershell/* - - name: Store Go SDK Artifacts + - name: Store Java SDK source + uses: actions/upload-artifact@v4 + with: + name: SDK_Source_Java + path: _build/install/default/share/java/* + + - name: Store Go SDK source uses: actions/upload-artifact@v4 with: name: SDK_Artifacts_Go @@ -69,11 +65,16 @@ jobs: !_build/install/default/share/go/dune !_build/install/default/share/go/**/*_test.go - - name: Store Java SDK source - uses: actions/upload-artifact@v4 - with: - name: SDK_Source_Java - path: _build/install/default/share/java/* + # sdk-ci runs some Go unit tests. + # This setting ensures that SDK date time + # tests are run on a machine that + # isn't using UTC + - name: Set Timezone to Tokyo for datetime tests + run: | + sudo timedatectl set-timezone Asia/Tokyo + + - name: Run CI for SDKs + uses: ./.github/workflows/sdk-ci - name: Trim dune cache run: opam exec -- dune cache trim --size=2GiB @@ -188,7 +189,7 @@ jobs: - name: Build C# SDK shell: pwsh run: | - dotnet build source/src ` + dotnet build source/src/XenServer.csproj ` --disable-build-servers ` --configuration Release ` -p:Version=${{ env.XAPI_VERSION_NUMBER }}-prerelease-unsigned ` @@ -200,86 +201,12 @@ jobs: name: SDK_Binaries_CSharp path: source/src/bin/Release/XenServer.NET.${{ env.XAPI_VERSION_NUMBER }}-prerelease-unsigned.nupkg - build-powershell-5x-sdk: - name: Build PowerShell 5.x SDK (.NET Framework 4.5) - needs: build-csharp-sdk - # PowerShell SDK for PowerShell 5.x needs to run on windows-2019 because - # windows-2022 doesn't contain .NET Framework 4.x dev tools - runs-on: windows-2019 - permissions: - contents: read - - steps: - - name: Strip 'v' prefix from xapi version - shell: pwsh - run: echo "XAPI_VERSION_NUMBER=$("${{ inputs.xapi_version }}".TrimStart('v'))" | Out-File -FilePath $env:GITHUB_ENV -Encoding utf8 -Append - - - name: Retrieve PowerShell SDK source - uses: actions/download-artifact@v4 - with: - name: SDK_Source_PowerShell - path: source/ - - - name: Retrieve C# SDK binaries - uses: actions/download-artifact@v4 - with: - name: SDK_Binaries_CSharp - path: csharp/ - - # Following needed for restoring packages - # when calling dotnet add package - - name: Set up dotnet CLI (.NET 6.0 and 8.0) - uses: actions/setup-dotnet@v4 - with: - dotnet-version: | - 6 - 8 - - - name: Setup project and dotnet CLI - shell: pwsh - run: | - dotnet nuget add source --name local ${{ github.workspace }}\csharp - dotnet add source/src package XenServer.NET --version ${{ env.XAPI_VERSION_NUMBER }}-prerelease-unsigned - - - name: Build PowerShell SDK (.NET Framework 4.5) - shell: pwsh - run: | - dotnet build source/src/XenServerPowerShell.csproj ` - --disable-build-servers ` - --configuration Release ` - -p:Version=${{ env.XAPI_VERSION_NUMBER }}-prerelease-unsigned ` - -p:TargetFramework=net45 ` - --verbosity=normal` - - - name: Update SDK and PS versions in "XenServerPSModule.psd1" - shell: pwsh - run: | - (Get-Content "source\XenServerPSModule.psd1") -replace "@SDK_VERSION@","${{ env.XAPI_VERSION_NUMBER }}" | Set-Content -Path "source\XenServerPSModule.psd1" - (Get-Content "source\XenServerPSModule.psd1") -replace "@PS_VERSION@","5.0" | Set-Content -Path "source\XenServerPSModule.psd1" - - - name: Move binaries to destination folder - shell: pwsh - run: | - New-Item -Path "." -Name "output" -ItemType "directory" - Copy-Item -Verbose "source\README_51.md" -Destination "output" -Force - Copy-Item -Verbose "source\LICENSE" -Destination "output" -Force - Copy-Item -Path "source\src\bin\Release\net45\*" -Include "*.dll" "output\" - Get-ChildItem -Path "source" |` - Where-Object { $_.Extension -eq ".ps1" -or $_.Extension -eq ".ps1xml" -or $_.Extension -eq ".psd1" -or $_.Extension -eq ".txt" } |` - ForEach-Object -Process { Copy-Item -Verbose $_.FullName -Destination "output" } - - - name: Store PowerShell SDK (.NET Framework 4.5) - uses: actions/upload-artifact@v4 - with: - name: SDK_Binaries_XenServerPowerShell_NET45 - path: output/**/* - build-powershell-7x-sdk: name: Build PowerShell 7.x SDK strategy: fail-fast: false matrix: - dotnet: ["6", "8"] + dotnet: ["8"] needs: build-csharp-sdk runs-on: windows-2022 permissions: diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 92f5101d18..a22f85dc72 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -21,7 +21,22 @@ concurrency: # On new push, cancel old workflows from the same PR, branch or tag jobs: ocaml-tests: name: Run OCaml tests - runs-on: ubuntu-22.04 + strategy: + fail-fast: false + matrix: + runs-on: ["ubuntu-22.04"] + ocaml-version: ["4.14.2"] + experimental: [false] + include: + - runs-on: "ubuntu-22.04-arm" + ocaml-version: "4.14.2" + experimental: true + - runs-on: "ubuntu-22.04" + ocaml-version: "5.3.0" + experimental: true + + continue-on-error: ${{ matrix.experimental }} + runs-on: ${{ matrix.runs-on }} permissions: contents: read env: @@ -29,6 +44,7 @@ jobs: # when changing this value, to keep builds # consistent XAPI_VERSION: "v0.0.0" + steps: - name: Checkout code uses: actions/checkout@v4 @@ -37,6 +53,7 @@ jobs: uses: ./.github/workflows/setup-xapi-environment with: xapi_version: ${{ env.XAPI_VERSION }} + ocaml_version: ${{ matrix.ocaml-version }} - name: Build run: opam exec -- make diff --git a/.github/workflows/other.yml b/.github/workflows/other.yml index 7ec6914045..0a94353560 100644 --- a/.github/workflows/other.yml +++ b/.github/workflows/other.yml @@ -51,7 +51,7 @@ jobs: - uses: pre-commit/action@v3.0.1 name: Run pre-commit checks (no spaces at end of lines, etc) with: - extra_args: --all-files --verbose --hook-stage commit + extra_args: --all-files --verbose --hook-stage pre-commit env: SKIP: no-commit-to-branch diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index d766f4f1e4..5dc1442510 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -83,16 +83,10 @@ jobs: name: SDK_Binaries_CSharp path: dist/ - - name: Retrieve PowerShell 5.x SDK distribution artifacts - uses: actions/download-artifact@v4 - with: - name: SDK_Binaries_XenServerPowerShell_NET45 - path: sdk_powershell_5x/ - - name: Retrieve PowerShell 7.x SDK distribution artifacts uses: actions/download-artifact@v4 with: - name: SDK_Binaries_XenServerPowerShell_NET6 + name: SDK_Binaries_XenServerPowerShell_NET8 path: sdk_powershell_7x/ - name: Package C SDK artifacts for deployment @@ -104,10 +98,6 @@ jobs: rm -rf libxenserver/usr/local/lib/ tar -zcvf libxenserver-prerelease.src.tar.gz -C ./libxenserver/usr/local . - - name: Zip PowerShell 5.x SDK artifacts for deployment - shell: bash - run: zip PowerShell-SDK-5.x-prerelease-unsigned.zip ./sdk_powershell_5x -r - - name: Zip PowerShell 7.x SDK artifacts for deployment shell: bash run: zip PowerShell-SDK-7.x-prerelease-unsigned.zip ./sdk_powershell_7x -r @@ -120,7 +110,6 @@ jobs: shell: bash run: | gh release create ${{ github.ref_name }} --repo ${{ github.repository }} --generate-notes dist/* \ - PowerShell-SDK-5.x-prerelease-unsigned.zip \ PowerShell-SDK-7.x-prerelease-unsigned.zip \ Go-SDK-prerelease-unsigned.zip \ libxenserver-prerelease.tar.gz libxenserver-prerelease.src.tar.gz diff --git a/.github/workflows/setup-xapi-environment/action.yml b/.github/workflows/setup-xapi-environment/action.yml index c3126a6d15..aba9e88121 100644 --- a/.github/workflows/setup-xapi-environment/action.yml +++ b/.github/workflows/setup-xapi-environment/action.yml @@ -5,6 +5,9 @@ inputs: xapi_version: description: "XenAPI version, pass to configure as --xapi_version=" required: true + ocaml_version: + description: "OCaml compiler version" + required: true runs: using: "composite" steps: @@ -52,7 +55,7 @@ runs: - name: Use ocaml uses: ocaml/setup-ocaml@v3 with: - ocaml-compiler: ${{ steps.dotenv.outputs.ocaml_version_full }} + ocaml-compiler: ${{ inputs.ocaml_version }} opam-repositories: | xs-opam: ${{ steps.dotenv.outputs.repository }} dune-cache: true diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index e8fb2f37e0..008a4e13fb 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -13,7 +13,7 @@ ## For manually executing the pre-push hook: # pre-commit run -av --hook-stage pre-push # -default_stages: [commit, push] +default_stages: [pre-commit, pre-push] default_language_version: python: python3.11 repos: @@ -68,7 +68,7 @@ repos: entry: env PYTHONDEVMODE=yes sh -c 'coverage run && coverage xml && coverage html && coverage report && diff-cover --ignore-whitespace --compare-branch=origin/master - --show-uncovered --html-report .git/coverage-diff.html + --show-uncovered --format html:.git/coverage-diff.html --fail-under 50 .git/coverage3.11.xml' require_serial: true pass_filenames: false @@ -108,7 +108,7 @@ repos: hooks: - id: pylint files: python3/ - stages: [push] + stages: [pre-push] name: check that changes to python3 tree pass pylint entry: diff-quality --violations=pylint --ignore-whitespace --compare-branch=origin/master @@ -134,7 +134,7 @@ repos: entry: python3 pytype_reporter.py pass_filenames: false types: [python] - stages: [push] + stages: [pre-push] verbose: true # This hook runs locally only when Python files change: language: python diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000000..34b62707ea --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,162 @@ +# Issues + +We welcome reports of technical issues with the components of the xen-api +toolstack. Please make sure that the description of the issue is as detailed as +possible to help anyone investigating it: + +1) Mention how it was detected, if and how it could be reproduced + +1) What's the desired behaviour? In what cases would it be useful? + +1) Include error messages, related logs if appropriate + +# Pull Requests + +To contribute changes to xen-api, please fork the repository on +GitHub, and then submit a pull request. + +It is required to add a `Signed-off-by:` as a +[Developers Certificate of Origin](http://developercertificate.org). +It certifies the patch's origin and is licensed under an +appropriate open-source licence to include it in Xapi: +https://git-scm.com/docs/git-commit#Documentation/git-commit.txt---signoff + +The following points are intended to describe what makes a contribution "good" - +easier to review, integrate, and maintain. Please follow them in your work. + +## Commit subjects and PR titles + +Commit subjects should preferrably start with the name of the component the +commit is most related to, and describe what the commit achieves. If your +commit only touches the `ocaml/xenopsd` directory, it should look like this, +for example: + +``` +xenopsd: Fix a deadlock during VM suspend +``` + +Similar principle applies to Pull Request titles. If there is only a single +commit in the PR, Github will automatically copy its subject and description to +the PR's title and body. If there are several commits in the PR, describe what +the PR achieves and the components it most directly impacts. + +If the commit subject includes some tracking identifier (such as `CP-1234`, for +example) referring to internal systems, please make sure to include all of the +essential information in the public descriptions - describe the symptoms of the +issue, how it was detected, investigated, how it could be reproduced, what are +the trade-offs and so on as appropriate. + +## Split into commits + +Following from the rules described above, if what the commit achieves is +difficult to fit into its subject, it is probably better to split it into +several commits, if possible. Note that every commit should build (`make` +should work and the CI should pass) independently, without requiring future +commits. This means some modifications can't really be split into several +commits (datamodel changes, in particular, require modifications to several +components at the same time), but makes it easier to revert part of the Pull +Request if some issues are detected in integration testing at a later point. + +## Good Commit Messages + +Commit messages (and the body of a Pull Request) should be as helpful and +descriptive as possible. If applicable, please include a description of current +behaviour, your changes, and the new behaviour. Justify the reasoning behind +your changes - are they sufficient on their own, or preparing for more changes? +Link any appropriate documentation, issues, or commits (avoiding internal and +publicly inaccessible sources) + +## CI + +Please make sure your Pull Request passes the Github CI. It will verify that +your code has been properly formatted (can be done locally with `make format`), +builds (`make` and `make check`), and passes the unit tests (`make test`). +The CI will run in the branches of your fork, so you can verify it passes +there before opening a Pull Request. + +## Testing + +Describe what kind of testing your contribution underwent. If the testing was +manual, please describe the commands or external clients that were used. If the +tests were automated, include at least a cursory description/name of the tests, +when they were regressed, if possible. + +Please note that any contribution to the code of the project will likely +require at least some testing to be done. Depending on how central the +component touched in your PR is to the system, the more things could only be +detected in real-world usecases through integration testing. + +If a commit has been determined to break integration testing at a later stage, +please note that the first and safest measure will almost always be reverting +the faulty commit. Making sure critical tests are passing remains a priority +over waiting for some commit to be reworked or refactored (which can be worked +on after a revert has been done). Though we are striving to make more tests +public (with failure then being visible to all), as long as some critical tests +remain private, this will also apply to such tests (with maintainers flagging +the breakage preferrably describing at least the gist of the test). + +If you are still waiting on some testing to be done, please mark the PR as a +"draft" and make the reasoning clear. + +If wider testing is needed (e.g. the change itself is believed to be correct +but may expose latent bugs in other components), lightweight feature flags can +also be used. E.g. an entry in `xapi_globs.ml` and `xapi.conf`, where the +feature/change is defaulted to `off`, to be turned on at a future time +(when e.g. more related PRs land, or it has passed some wider testing). + +If your contribution doesn't intend to have any functional changes, please make +that clear as well. + +## Feature work + +If your contribution adds some new feature or reworks some major aspect of the +system (as opposed to one-off fixes), it can be benefitial to first describe +the plan of your work in a design proposal. Architectural issues are better +spotted early on, and taking a big-picture view can often lead to new insights. + +An example of a design proposal is here: + +https://github.com/xapi-project/xen-api/pull/6387 + +If submitting a design first is not possible, include documentation alongside +with your PR describing the work, like it was done in the last three commits +here: + +https://github.com/xapi-project/xen-api/pull/6457 + +Note that the design will often serve as documentation as well - so take care +updating it after the implementation is done to better reflect reality. + +## Review process and merge + +It can often be useful to address review suggestions with a "fixup" commit +(created manually or with the help of `git commit --fixup=HASH`). This way it +is clear what the original code was and what your fix touches. Once the +fixup commit has been reviewed and the PR approved, please squash the fixup +commits with `git rebase --autosquash` before merging. Otherwise the commits in +the Pull Request should stay as independent commits - we do not require +squashing all the commits into a single one on merge. + +If the commit fixes a bug in an earlier, already merged PR then it might be +useful to mention that in the commit, if known. + +This can be done by adding this to your GIT configuration: + +``` +[pretty] + fixes = Fixes: %h (\"%s\") +``` + +And then running: + +``` +# git log -1 --pretty=fixes +Fixes: 1c581c074 ("xenopsd: Fix a deadlock during VM suspend") +``` + +This will print the commit title and hash in a nice format, which can then be +added to the footer of the commit message (alongside the sign-off). + +This is useful information to have if any of these commits get backported to +another release in the future, so that we also backport the bugfixes, not just +the buggy commits. diff --git a/Makefile b/Makefile index dde13fc24a..a1d5a628f3 100644 --- a/Makefile +++ b/Makefile @@ -147,7 +147,8 @@ install-extra: 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' -DUNE_IU_PACKAGES1=-j $(JOBS) --destdir=$(DESTDIR) --prefix=$(PREFIX) --libdir=$(LIBDIR) --mandir=$(MANDIR) +DUNE_IU_COMMON=-j $(JOBS) --destdir=$(DESTDIR) --libdir=$(LIBDIR) --mandir=$(MANDIR) +DUNE_IU_PACKAGES1=$(DUNE_IU_COMMON) --prefix=$(PREFIX) DUNE_IU_PACKAGES1+=--libexecdir=$(XENOPSD_LIBEXECDIR) --datadir=$(SDKDIR) DUNE_IU_PACKAGES1+=xapi-client xapi-schema xapi-consts xapi-cli-protocol xapi-datamodel xapi-types DUNE_IU_PACKAGES1+=xen-api-client xen-api-client-lwt rrdd-plugin rrd-transport @@ -163,17 +164,17 @@ install-dune1: # dune can install libraries and several other files into the right locations dune install $(DUNE_IU_PACKAGES1) -DUNE_IU_PACKAGES2=-j $(JOBS) --destdir=$(DESTDIR) --prefix=$(OPTDIR) --libdir=$(LIBDIR) --mandir=$(MANDIR) --libexecdir=$(OPTDIR)/libexec --datadir=$(DOCDIR) xapi xe +DUNE_IU_PACKAGES2=$(DUNE_IU_COMMON) --prefix=$(OPTDIR) --libexecdir=$(OPTDIR)/libexec --datadir=$(DOCDIR) xapi xe install-dune2: dune install $(DUNE_IU_PACKAGES2) -DUNE_IU_PACKAGES3=-j $(JOBS) --destdir=$(DESTDIR) --prefix=$(OPTDIR) --libdir=$(LIBDIR) --mandir=$(MANDIR) --libexecdir=$(OPTDIR)/libexec --bindir=$(OPTDIR)/debug --datadir=$(OPTDIR)/debug xapi-debug +DUNE_IU_PACKAGES3=$(DUNE_IU_COMMON) --prefix=$(OPTDIR) --libexecdir=$(OPTDIR)/libexec --bindir=$(OPTDIR)/debug --datadir=$(OPTDIR)/debug xapi-debug install-dune3: dune install $(DUNE_IU_PACKAGES3) -DUNE_IU_PACKAGES4=-j $(JOBS) --destdir=$(DESTDIR) --prefix=$(PREFIX) --libdir=$(LIBDIR) --libexecdir=/usr/libexec --mandir=$(MANDIR) vhd-tool forkexec +DUNE_IU_PACKAGES4=$(DUNE_IU_COMMON) --prefix=$(PREFIX) --libexecdir=/usr/libexec vhd-tool forkexec qcow-stream-tool install-dune4: dune install $(DUNE_IU_PACKAGES4) @@ -186,7 +187,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; 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.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; uninstall: diff --git a/README.markdown b/README.markdown index b41ab950d8..9f795d8550 100644 --- a/README.markdown +++ b/README.markdown @@ -108,6 +108,9 @@ It certifies the patch's origin and is licensed under an appropriate open-source licence to include it in Xapi: https://git-scm.com/docs/git-commit#Documentation/git-commit.txt---signoff +For more detailed guidelines on what makes a good contribution, see +[CONTRIBUTING](./CONTRIBUTING.md). + Discussions ----------- diff --git a/doc/content/design/numa.md b/doc/content/design/numa.md new file mode 100644 index 0000000000..fa1917b3c5 --- /dev/null +++ b/doc/content/design/numa.md @@ -0,0 +1,142 @@ +--- +title: NUMA +layout: default +design_doc: true +revision: 1 +status: proposed +--- + +# NUMA + +NUMA stands for Non-Uniform Memory Access and describes that RAM access +for CPUs in a large system is not equally fast for all of them. CPUs +are grouped into so-called nodes and each node has fast access to RAM +that is considered local to its node and slower access to other RAM. +Conceptually, a node is a container that bundles some CPUs and RAM and +there is an associated cost when accessing RAM in a different node. In +the context of CPU virtualisation assigning vCPUs to NUMA nodes is an +optimisation strategy to reduce memory latency. This document describes +a design to make NUMA-related assignments for Xen domains (hence, VMs) +visible to the user. Below we refer to these assignments and +optimisations collectively as NUMA for simplicity. + +NUMA is more generally discussed as +[NUMA Feature](../toolstack/features/NUMA/index.md). + + +## NUMA Properties + +Xen 4.20 implements NUMA optimisation. We want to expose the following +NUMA-related properties of VMs to API clients, and in particualar +XenCenter. Each one is represented by a new field in XAPI's `VM_metrics` +data model: + +* RO `VM_metrics.numa_optimised`: boolean: if the VM is + optimised for NUMA +* RO `VM_metrics.numa_nodes`: integer: number of NUMA nodes of the host + the VM is using +* MRO `VM_metrics.numa_node_memory`: int -> int map; mapping a NUMA node + (int) to an amount of memory (bytes) in that node. + +Required NUMA support is only available in Xen 4.20. Some parts of the +code will have to be managed by patches. + +## XAPI High-Level Implementation + +As far as Xapi clients are concerned, we implement new fields in the +`VM_metrics` class of the data model and surface the values in the CLI +via `records.ml`; we could decide to make `numa_optimised` visible by +default in `xe vm-list`. + +Introducing new fields requires defaults; these would be: + +* `numa_optimised`: false +* `numa_nodes`: 0 +* `numa_node_memory`: [] + +The data model ensures that the values are visible to API clients. + +## XAPI Low-Level Implementation + +NUMA properties are observed by Xenopsd and Xapi learns about them as +part of the `Client.VM.stat` call implemented by Xenopsd. Xapi makes +these calls frequently and we will update the Xapi VM fields related to +NUMA simply as part of processing the result of such a call in Xapi. + +For this to work, we extend the return type of `VM.stat` in + +* `xenops_types.ml`, type `Vm.state` + +with three fields: + +* `numa_optimised: bool` +* `numa_nodes: int` +* `numa_node_memory: (int, int64) list` + +matching the semantics from above. + +## Xenopsd Implementation + +Xenopsd implements the `VM.stat` return value in + +* `Xenops_server_sen.get_state` + +where the three fields would be set. Xenopsds relies on bindings to Xen to +observe NUMA-related properties of a domain. + +Given that NUMA related functionality is only available for Xen 4.20, we +probably will have to maintain a patch in xapi.spec for compatibility +with earlier Xen versions. + +The (existing) C bindings and changes come in two forms: new functions +and an extension of a type used by and existing function. + +```ocaml + external domain_get_numa_info_node_pages_size : handle -> int -> int + = "stub_xc_domain_get_numa_info_node_pages_size" +``` + +Thia function reports the number of NUMA nodes used by a Xen domain +(supplied as an argument) + +```ocaml + type domain_numainfo_node_pages = { + tot_pages_per_node : int64 array; + } + external domain_get_numa_info_node_pages : + handle -> int -> int -> domain_numainfo_node_pages + = "stub_xc_domain_get_numa_info_node_pages" +``` + +This function receives as arguments a domain ID and the number of nodes +this domain is using (acquired using `domain_get_numa_info_node_pages`) + +The number of NUMA nodes of the host (not domain) is reported by +`Xenctrl.physinfo` which returns a value of type `physinfo`. + +```diff + index b4579862ff..491bd3fc73 100644 + --- a/tools/ocaml/libs/xc/xenctrl.ml + +++ b/tools/ocaml/libs/xc/xenctrl.ml + @@ -155,6 +155,7 @@ type physinfo = + capabilities : physinfo_cap_flag list; + max_nr_cpus : int; + arch_capabilities : arch_physinfo_cap_flags; + + nr_nodes : int; + } +``` + +We are not reporting `nr_nodes` directly but use it to determine the +value of `numa_optimised` for a domain/VM: + + numa_optimised = + (VM.numa_nodes = 1) + or (VM.numa_nodes < physinfo.Xenctrl.nr_nodes) + +### Details + +The three new fields that become part of type `VM.state` are updated as +part of `get_state()` using the primitives above. + + + diff --git a/doc/content/design/sm-supported-image-formats.md b/doc/content/design/sm-supported-image-formats.md index fd1118e885..3d860c2833 100644 --- a/doc/content/design/sm-supported-image-formats.md +++ b/doc/content/design/sm-supported-image-formats.md @@ -2,7 +2,7 @@ title: Add supported image formats in sm-list layout: default design_doc: true -revision: 2 +revision: 3 status: proposed --- @@ -22,32 +22,16 @@ available formats. # Design Proposal To expose the available image formats to clients (e.g., XenCenter, XenOrchestra, etc.), -we propose adding a new field called `supported-image-formats` to the Storage Manager (SM) -module. This field will be included in the output of the `SM.get_all_records` call. +we propose adding a new field called `supported_image_formats` to the Storage Manager +(SM) module. This field will be included in the output of the `SM.get_all_records` call. -The `supported-image-formats` field will be populated by retrieving information -from the SMAPI drivers. Specifically, each driver will update its `DRIVER_INFO` -dictionary with a new key, `supported_image_formats`, which will contain a list -of strings representing the supported image formats -(for example: `["vhd", "raw", "qcow2"]`). - -The list designates the driver's preferred VDI format as its first entry. That -means that when migrating a VDI, the destination storage repository will -attempt to create a VDI in this preferred format. If the default format cannot -be used (e.g., due to size limitations), an error will be generated. - -If a driver does not provide this information (as is currently the case with existing -drivers), the default value will be an empty array. This signifies that it is the -driver that decides which format it will use. This ensures that the modification -remains compatible with both current and future drivers. - -With this new information, listing all parameters of the SM object will return: +- With this new information, listing all parameters of the SM object will return: ```bash # xe sm-list params=all ``` -will output something like: +Output of the command will look like (notice that CLI uses hyphens): ``` uuid ( RO) : c6ae9a43-fff6-e482-42a9-8c3f8c533e36 @@ -65,12 +49,118 @@ required-cluster-stack ( RO) : supported-image-formats ( RO) : vhd, raw, qcow2 ``` -This change impacts the SM data model, and as such, the XAPI database version will -be incremented. +## Implementation details + +The `supported_image_formats` field will be populated by retrieving information +from the SMAPI drivers. Specifically, each driver will update its `DRIVER_INFO` +dictionary with a new key, `supported_image_formats`, which will contain a list +of strings representing the supported image formats +(for example: `["vhd", "raw", "qcow2"]`). Although the formats are listed as a +list of strings, they are treated as a set-specifying the same format multiple +times has no effect. + +### Driver behavior without `supported_image_formats` + +If a driver does not provide this information (as is currently the case with +existing drivers), the default value will be an empty list. This signifies +that the driver determines which format to use when creating VDI. During a migration, +the destination driver will choose the format of the VDI if none is explicitly +specified. This ensures backward compatibility with both current and future drivers. + +### Specifying image formats for VDIs creation + +If the supported image format is exposed to the client, then, when creating new VDI, +user can specify the desired format via the `sm_config` parameter `image-format=qcow2` (or +any format that is supported). If no format is specified, the driver will use its +preferred default format. If the specified format is not supported, an error will be +generated indicating that the SR does not support it. Here is how it can be achieved +using the XE CLI: + +```bash +# xe vdi-create \ + sr-uuid=cbe2851e-9f9b-f310-9bca-254c1cf3edd8 \ + name-label="A new VDI" \ + virtual-size=10240 \ + sm-config:image-format=vhd +``` + +### Specifying image formats for VDIs migration + +When migrating a VDI, an API client may need to specify the desired image format if +the destination SR supports multiple storage formats. + +#### VDI pool migrate + +To support this, a new parameter, `dest_img_format`, is introduced to +`VDI.pool_migrate`. This field accepts a string specifying the desired format (e.g., *qcow2*), +ensuring that the VDI is migrated in the correct format. The new signature of +`VDI.pool_migrate` will be +`VDI ref pool_migrate (session ref, VDI ref, SR ref, string, (string -> string) map)`. + +If the specified format is not supported or cannot be used (e.g., due to size limitations), +an error will be generated. Validation will be performed as early as possible to prevent +disruptions during migration. These checks can be performed by examining the XAPI database +to determine whether the SR provided as the destination has a corresponding SM object with +the expected format. If this is not the case, a `format not found` error will be returned. +If no format is specified by the client, the destination driver will determine the appropriate +format. + +```bash +# xe vdi-pool-migrate \ + uuid= \ + sr-uuid= \ + dest-img-format=qcow2 +``` + +#### VM migration to remote host + +A VDI migration can also occur during a VM migration. In this case, we need to +be able to specify the expected destination format as well. Unlike `VDI.pool_migrate`, +which applies to a single VDI, VM migration may involve multiple VDIs. +The current signature of `VM.migrate_send` is `(session ref, VM ref, (string -> string) map, +bool, (VDI ref -> SR ref) map, (VIF ref -> network ref) map, (string -> string) map, +(VGPU ref -> GPU_group ref) map)`. Thus there is already a parameter that maps each source +VDI to its destination SR. We propose to add a new parameter that allows specifying the +desired destination format for a given source VDI: `(VDI ref -> string)`. It is +similar to the VDI-to-SR mapping. We will update the XE cli to support this new format. +It would be `image_format:=`: + +```bash +# xe vm-migrate \ + host-uuid= \ + remote-master= \ + remote-password= \ + remote-username= \ + vdi:= \ + vdi:= \ + image-format:=vhd \ + image-format:=qcow2 \ + uuid= +``` +The destination image format would be a string such as *vhd*, *qcow2*, or another +supported format. It is optional to specify a format. If omitted, the driver +managing the destination SR will determine the appropriate format. +As with VDI pool migration, if this parameter is not supported by the SM driver, +a `format not found` error will be returned. The validation must happen before +sending a creation message to the SM driver, ideally at the same time as checking +whether all VDIs can be migrated. + +To be able to check the format, we will need to modify `VM.assert_can_migrate` and +add the mapping from VDI references to their image formats, as is done in `VM.migrate_send`. # Impact -- **Data Model:** A new field (`supported-image-formats`) is added to the SM records. +It should have no impact on existing storage repositories that do not provide any information +about the supported image format. + +This change impacts the SM data model, and as such, the XAPI database version will +be incremented. It also impacts the API. + +- **Data Model:** + - A new field (`supported_image_formats`) is added to the SM records. + - A new parameter is added to `VM.migrate_send`: `(VDI ref -> string) map` + - A new parameter is added to `VM.assert_can_migrate`: `(VDI ref -> string) map` + - A new parameter is added to `VDI.pool_migrate`: `string` - **Client Awareness:** Clients like the `xe` CLI will now be able to query and display the supported image formats for a given SR. - **Database Versioning:** The XAPI database version will be updated to reflect this change. diff --git a/doc/content/design/snapshot-revert.md b/doc/content/design/snapshot-revert.md index 4618e1ee9c..e014403953 100644 --- a/doc/content/design/snapshot-revert.md +++ b/doc/content/design/snapshot-revert.md @@ -1,62 +1,100 @@ --- -title: Improving snapshot revert behaviour +title: Better VM revert layout: default design_doc: true -revision: 1 +revision: 2 status: confirmed --- -Currently there is a XenAPI `VM.revert` which reverts a "VM" to the state it -was in when a VM-level snapshot was taken. There is no `VDI.revert` so -`VM.revert` uses `VDI.clone` to change the state of the disks. +## Overview -The use of `VDI.clone` has the side-effect of changing VDI refs and uuids. -This causes the following problems: +XenAPI allows users to rollback the state of a VM to a previous state, which is +stored in a snapshot, using the call `VM.revert`. Because there is no +`VDI.revert` call, `VM.revert` uses `VDI.clone` on the snapshot to duplicate +the contents of that disk and then use the new clone as the storage for the VM. -- It is difficult for clients - such as [Apache CloudStack](http://cloudstack.apache.org) to keep track - of the disks it is actively managing -- VDI snapshot metadata (`VDI.snapshot_of` et al) has to be carefully - fixed up since all the old refs are now dangling +Because `VDI.clone` creates new VDI refs and uuids, some problematic +behaviours arise: -We will fix these problems by: +- 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. + Because the database doesn't support transactions this operation is not atomic + and can produce inconsistent database states. -1. adding a `VDI.revert` to the SMAPIv2 and calling this from `VM.revert` -2. defining a new SMAPIv1 operation `vdi_revert` and a corresponding capability - `VDI_REVERT` -3. the Xapi implementation of `VDI.revert` will first try the `vdi_revert`, - and fall back to `VDI.clone` if that fails -4. implement `vdi_revert` for common storage types, including File and LVM-based - SRs. +Additionally, some filesystems support snapshots natively, doing the clone +procedure is much costlier than allowing the filesystem to do the revert. -XenAPI changes --------------- +We will fix these problems by: -We will add the function `VDI.revert` with arguments: +- introducing the new feature `VDI_REVERT` in SM interface (`xapi_smint`). This + allows backends to advertise that they support the new functionality +- defining a new storage operation `VDI.revert` in storage_interface, which is + gated by the feature `VDI_REVERT` +- proxying the storage operation to SMAPIv3 and SMAPv1 backends accordingly +- adding `VDI.revert` to xapi_vdi which will call the storage operation if the + backend advertises it, and fallback to the previous method that uses + `VDI.clone` if it doesn't advertise it, or issues are detected at runtime + that prevent it +- changing the Xapi implementation of `VM.revert` to use `VDI.revert` +- implement `vdi_revert` for common storage types, including File and LVM-based + SRs +- adding unit and quick tests to xapi to test that `VM.revert` does not regress + +## Current VM.revert behaviour + +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) +2. destroys the VM's VDI (disks only), referenced by the snapshot's VDIs using + `snapshot_of`; as well as the suspend VDI. +3. clones the snapshot's VDIs (disks and CDs), if one clone fails none remain. +4. searches the database for all `snapshot_of` references to the deleted VDIs + and replaces them with the referenced of the newly cloned snapshots. +5. clones the snapshot's resume VDI +6. creates copies of all the cloned VBDs and associates them with the cloned VDIs +7. assigns the new resume VDI to the VM + +## XenAPI design + +### API + +The function `VDI.revert` will be added, with arguments: - in: `snapshot: Ref(VDI)`: the snapshot to which we want to revert - in: `driver_params: Map(String,String)`: optional extra parameters -- out: `Ref(VDI)` the new VDI +- out: `Ref(VDI)` reference to the new VDI with the reverted contents + +The function will extract the reference of VDI whose contents need to be +replaced. This is the snapshot's `snapshot_of` field, then it will call the +storage function function `VDI.revert` to have its contents replaced with the +snapshot's. The VDI object will not be modified, and the reference returned is +the VDI's original reference. +If anything impedes the successful finish of an in-place revert, like the SM +backend does not advertising the feature `VDI_REVERT`, not implement the +feature, or the `snapshot_of` reference is invalid; an exception will be +raised. -The function will look up the VDI which this is a `snapshot_of`, and change -the VDI to have the same contents as the snapshot. The snapshot will not be -modified. If the implementation is able to revert in-place, then the reference -returned will be the VDI this is a `snapshot_of`; otherwise it is a reference -to a fresh VDI (created by the `VDI.clone` fallback path) +### Xapi Storage -References: +The function `VDI.revert` is added, with the following arguments: -- @johnelse's [pull request](https://github.com/xapi-project/xen-api/pull/1963) - which implements this +- in: `dbg`: the task identifier, useful for tracing +- in: `sr`: SR where the new VDI must be created +- in: `snapshot_info`: metadata of the snapshot, the contents of which must be + made available in the VDI indicated by the `snapshot_of` field -SMAPIv1 changes ---------------- +#### SMAPIv1 -We will define the function `vdi_revert` with arguments: +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 should be duplicated -- in: `target_uuid`: the UUID of the target whose contents should be replaced +- 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 The function will replace the contents of the `target_uuid` VDI with the contents of the `vdi_uuid` VDI without changing the identify of the target @@ -64,22 +102,27 @@ contents of the `vdi_uuid` VDI without changing the identify of the target The `vdi_uuid` is preserved by this operation. The operation is obvoiusly idempotent. -Xapi changes ------------- +#### SMAPIv3 -Xapi will +In an analogous way to SMAPIv1, the function `Volume.revert` is defined with the +following arguments: -- use `VDI.revert` in the `VM.revert` code-path -- expose a new `xe vdi-revert` CLI command -- implement the `VDI.revert` by calling the SMAPIv1 function and falling back - to `VDI.clone` if a `Not_implemented` exception is thrown +- in: `dbg`: the task identifier, useful for tracing +- in: `sr`: the UUID of the SR containing both the VDI and the snapshot +- in: `snapshot`: the UUID of the snapshot whose contents must be duplicated +- in: `vdi`: the UUID of the VDI whose contents must be replaced -References: +### Xapi -- @johnelse's [pull request](https://github.com/xapi-project/xen-api/pull/1963) +- add the capability `VDI_REVERT` so backends can advertise it +- use `VDI.revert` in the `VM.revert` after the VDIs have been destroyed, and + before the snapshot's VDIs have been cloned. If any of the reverts fail + because a `Not_implemented` exception is thrown, or the `snapshot_of` + contains an invalid reference, add the affected VDIs to the list to be cloned + and recovered, using the existing method +- expose a new `xe vdi-revert` CLI command -SM changes ----------- +## SM changes We will modify @@ -92,8 +135,7 @@ We will modify snapshot/clone machinery - LVHDoISCSISR.py and LVHDoHBASR.py to advertise the `VDI_REVERT` capability -Prototype code -============== +# Prototype code from the previous proposal Prototype code exists here: diff --git a/doc/content/python/_index.md b/doc/content/python/_index.md index 773f02ce38..523c201871 100644 --- a/doc/content/python/_index.md +++ b/doc/content/python/_index.md @@ -52,7 +52,7 @@ in the [pre-commit] configuration file [.pre-commit-config.yaml]. entry: sh -c 'coverage run && coverage xml && coverage html && coverage report && diff-cover --ignore-whitespace --compare-branch=origin/master - --show-uncovered --html-report .git/coverage-diff.html + --show-uncovered --format html:.git/coverage-diff.html --fail-under 50 .git/coverage3.11.xml' require_serial: true pass_filenames: false diff --git a/doc/content/toolstack/features/SSH/index.md b/doc/content/toolstack/features/SSH/index.md new file mode 100644 index 0000000000..a0a7c93770 --- /dev/null +++ b/doc/content/toolstack/features/SSH/index.md @@ -0,0 +1,249 @@ +# SSH Management + +SSH Management enables programmatic control of SSH access to XenServer hosts. This feature +allows administrators to enable/disable SSH services, configure timeout settings, and implement +automatic SSH management based on XAPI health status. + +## Architecture Overview + +The SSH Management feature is built around three core components: + +1. **SSH Service Control**: Direct enable/disable operations for SSH on individual hosts or entire pools +2. **Timeout Management**: Configurable timeouts for both SSH sessions and service duration limits +3. **Auto Mode**: Intelligent SSH management that automatically adjusts based on XAPI health status + +![SSH Status Transition](ssh-status-trans.png) + +## SSH Service Control + +### API Design + +#### Host APIs + +- `host.enable_ssh`: Enables SSH access on the specified host +- `host.disable_ssh`: Disables SSH access on the specified host +- `host.set_ssh_enabled_timeout`: Configures SSH service timeout duration (0-172800 seconds, maximum 2 days) +- `host.set_console_idle_timeout`: Sets idle timeout for SSH/VNC console sessions +- `host.set_ssh_auto_mode`: Controls SSH auto mode behavior (when true, SSH is normally disabled but enabled during XAPI downtime) + +#### Pool APIs + +- `pool.enable_ssh`: Enables SSH access across all hosts in the pool +- `pool.disable_ssh`: Disables SSH access across all hosts in the pool +- `pool.set_ssh_enabled_timeout`: Sets SSH service timeout for all pool hosts +- `pool.set_console_idle_timeout`: Configures console idle timeout for all pool hosts +- `pool.set_ssh_auto_mode`: Applies SSH auto mode configuration to all pool hosts + +### Implementation Details + +The enable/disable operations work by directly managing systemd services. The code starts and enables the sshd systemd service to enable SSH access, or stops and disables it to disable SSH access: + +```ocaml +Xapi_systemctl.start "sshd" +Xapi_systemctl.enable "sshd" + +Xapi_systemctl.stop "sshd" +Xapi_systemctl.disable "sshd" +``` + +#### SSH Timeout Management + +The timeout management uses the scheduler system to automatically disable SSH after a specified period. The function removes any existing disable job from the queue and creates a new one-shot job that will execute the SSH disable operation when the timeout expires. if the XAPI restart during this period, xapi will schedule a new job to disable SSH with remaining time: + +```ocaml +let schedule_disable_ssh_job ~__context ~self ~timeout ~auto_mode = + Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue + !Xapi_globs.job_for_disable_ssh ; + Xapi_stdext_threads_scheduler.Scheduler.add_to_queue + !Xapi_globs.job_for_disable_ssh + Xapi_stdext_threads_scheduler.Scheduler.OneShot (Int64.to_float timeout) + (fun () -> + disable_ssh_internal ~__context ~self + ) +``` + +#### Console Idle Timeout + +The console idle timeout is configured by writing to a profile script that sets the TMOUT environment variable. The function generates appropriate content based on the timeout value and atomically writes it to the profile script file: + +```ocaml +let set_console_idle_timeout ~__context ~self ~value = + let content = match value with + | 0L -> "# Console timeout is disabled\n" + | timeout -> Printf.sprintf "# Console timeout configuration\nexport TMOUT=%Ld\n" timeout + in + Unixext.atomic_write_to_file !Xapi_globs.console_timeout_profile_path 0o0644 + (fun fd -> Unix.write fd (Bytes.of_string content) 0 (String.length content)) +``` + +#### SSH Auto Mode + +The SSH auto mode is configured by managing the monitoring service. The function updates the database with the auto mode setting and then enables or disables the SSH monitoring daemon accordingly. When auto mode is enabled, it starts the monitoring service and enable SSH service (Always enable SSH service for avoid both XAPI and Monitor service are down, user is still able to start SSH service by reboot host); when disabled, it stops and disables the monitoring service: + +```ocaml +let set_ssh_auto_mode ~__context ~self ~value = + Db.Host.set_ssh_auto_mode ~__context ~self ~value ; + if value then ( + Xapi_systemctl.enable ~wait_until_success:false !Xapi_globs.ssh_service ; + Xapi_systemctl.enable ~wait_until_success:false !Xapi_globs.ssh_monitor_service ; + Xapi_systemctl.start ~wait_until_success:false !Xapi_globs.ssh_monitor_service + ) else ( + Xapi_systemctl.stop ~wait_until_success:false !Xapi_globs.ssh_monitor_service ; + Xapi_systemctl.disable ~wait_until_success:false !Xapi_globs.ssh_monitor_service + ) +``` + +### CLI Commands + +```bash +# Enable/disable SSH on hosts +xe host-enable-ssh host= +xe host-disable-ssh host-uuid= + +# Configure timeouts on individual hosts +xe host-param-set uuid= ssh-enabled-timeout=3600 +xe host-param-set uuid= console-idle-timeout=300 +xe host-param-set uuid= ssh-auto-mode=true + +# Query host SSH parameters +xe host-param-get uuid= param-name=ssh-enabled +xe host-param-get uuid= param-name=ssh-expiry +xe host-param-get uuid= param-name=ssh-enabled-timeout +xe host-param-get uuid= param-name=console-idle-timeout +xe host-param-get uuid= param-name=ssh-auto-mode + +# Enable/disable SSH across pool +xe pool-enable-ssh +xe pool-disable-ssh + +# Configure timeouts across pool +xe pool-param-set uuid= ssh-enabled-timeout=3600 +xe pool-param-set uuid= console-idle-timeout=300 +xe pool-param-set uuid= ssh-auto-mode=true + +# Query pool SSH parameters +xe pool-param-get uuid= param-name=ssh-enabled +xe pool-param-get uuid= param-name=ssh-expiry +xe pool-param-get uuid= param-name=ssh-enabled-timeout +xe pool-param-get uuid= param-name=console-idle-timeout +xe pool-param-get uuid= param-name=ssh-auto-mode +``` + +## Auto Mode + +### Overview + +The auto mode feature intelligently manages SSH access based on XAPI health status: +- SSH is automatically enabled when XAPI becomes unhealthy +- SSH is automatically disabled when XAPI is healthy and running normally + +When the user enables the SSH service with `enable_ssh` API, SSH auto mode will be turned off. +| SSH service | auto mode | +|-------------|-----------| +| enabled | off | + +If SSH auto mode is enabled and XAPI becomes unresponsive, the system will automatically enable the SSH service to allow access. +| auto mode | xapi healthy | SSH service | +|-----------|--------------|-------------| +| on | yes | disable | +| on | no | enable | +| off | NA | NA | + +When SSH is temporarily enabled using the ssh-enabled-timeout setting and enable-ssh command, the system preserves the original SSH auto-mode state in cache. During the timeout period, SSH auto-mode is suspended (set to off) to allow SSH access. Once the timeout expires, the system restores the cached auto-mode state - if auto-mode was originally enabled, it will be reactivated and automatically stop the SSH service again +| auto mode before set enable timeout | SSH service before set enable timeout | auto mode during the limited time period | auto mode after enable timeout | +|-----------------------------------|--------------------------------------|----------------------------------------|-------------------------------| +| on | off | off | on | + +### Service Architecture + +#### Monitoring Daemon + +The monitoring daemon (`/opt/xensource/libexec/xapi-state-monitor`) operates continuously: + +1. Monitors current SSH service status +2. When auto mode is enabled: + - If XAPI is healthy and SSH is active → Stop SSH + - If XAPI is unhealthy and SSH is inactive → Start SSH +3. Implements retry logic with up to 3 attempts for failed operations +4. Pauses for 60 seconds between health check cycles + +### Health Check Integration + +The system leverages the existing `xapi-health-check` script for health monitoring: +- Returns 0 when XAPI is healthy +- Returns 1 when XAPI is unhealthy +- Triggers unhealthy status after 20 consecutive failures + +### Configuration + +#### Default Behavior + +- **XenServer 8**: `ssh_auto_mode=false` (SSH is enabled by default) +- **XenServer 9**: `ssh_auto_mode=true` (SSH is disabled by default) + +#### Configuration Files + +In XS8, the ssh_auto_mode default value will be overridden by the configuration file as below, while in XS9, there is no configuration file, so auto-mode will remain enabled by default. + +```bash +# XS8: /etc/xapi.conf.d/ssh-auto-mode.conf +ssh_auto_mode=false +``` + +## Pool Operations + +### Pool Join + +When a host joins a pool, the following sequence occurs: +1. The host inherits SSH configuration from the pool coordinator +2. SSH settings are applied before metadata updates +3. The xapi-ssh-monitor service is started if auto mode is enabled + +### Pool Eject + +When a host is ejected from a pool: +1. The host resets to its default configuration (e.g., in XS8 SSH enabled, no timeout) +2. Default SSH configuration is applied before the host becomes a coordinator + +## XAPI Restart Handling + +During XAPI startup, the system performs several key operations to handle different restart scenarios: + +#### SSH Status Synchronization +The database is updated to reflect the actual SSH service state, ensuring consistency between the database and the running system. + +#### Short XAPI Downtime Recovery +When `ssh_enabled_timeout > 0` and `ssh_expiry > current_time`, indicating that XAPI restarted during a temporary SSH disable period: +- The system reschedules the disable SSH job with the remaining time +- This ensures that the original timeout period is maintained even after XAPI restart + +#### Extended XAPI Downtime Handling +When a ssh_enabled_timeout is configured, `ssh_expiry < current_time` and the SSH service is currently active, indicating that XAPI was down for an extended period that exceeded the timeout duration: +- SSH is automatically disabled +- SSH auto mode is enabled to ensure continuous SSH availability + +This scenario typically occurs when XAPI is not active when the SSH timeout expires, requiring the system to disable SSH and enable auto mode for remains continuously available. + +## Error Handling + +### Retry Logic + +The system implements robust retry mechanisms: +- SSH disable operations are retried up to 3 times +- 5-second intervals are maintained between retry attempts + +## Integration Points + +### xsconsole Integration + +The xsconsole interface has been updated to use XAPI APIs rather than direct systemd commands for consistent with XAPI db status: +- Enable/Disable operations: Calls `host.enable_ssh`/`host.disable_ssh` +- Auto mode configuration: Calls `host.set_ssh_auto_mode` + +### Answerfile Support + +The following configuration in answerfile can be used, when configure ssh-mode to on, auto-mode will be disabled and SSH will be enabled, when configure ssh-mode to off, auto-mode will be disabled and SSH will be disabled as well, when configure to auto, the auto-mode will be enabled and SSH will be disabled by auto-mode once the XAPI is on: + +```xml +on|off|auto +``` \ No newline at end of file diff --git a/doc/content/toolstack/features/SSH/ssh-status-trans.png b/doc/content/toolstack/features/SSH/ssh-status-trans.png new file mode 100644 index 0000000000..40cf16255a Binary files /dev/null and b/doc/content/toolstack/features/SSH/ssh-status-trans.png differ diff --git a/doc/content/toolstack/features/Tracing/index.md b/doc/content/toolstack/features/Tracing/index.md new file mode 100644 index 0000000000..c54441bbb6 --- /dev/null +++ b/doc/content/toolstack/features/Tracing/index.md @@ -0,0 +1,137 @@ ++++ +title = "Tracing" ++++ + +Tracing is a powerful tool for observing system behavior across multiple components, making it especially +useful for debugging and performance analysis in complex environments. + +By integrating OpenTelemetry (a standard that unifies OpenTracing and OpenCensus) and the Zipkin v2 protocol, +XAPI enables efficient tracking and visualization of operations across internal and external systems. +This facilitates detailed analysis and improves collaboration between teams. + +Tracing is commonly used in high-level applications such as web services. As a result, less widely-used or +non-web-oriented languages may lack dedicated libraries for distributed tracing (An OCaml implementation +has been developed specifically for XenAPI). + +# How tracing works in XAPI + +## Spans and Trace Context + +- A *span* is the core unit of a trace, representing a single operation with a defined start and end time. + Spans can contain sub-spans that represent child tasks. This helps identify bottlenecks or areas that + can be parallelized. + - A span can contain several contextual elements such as *tags* (key-value pairs), + *events* (time-based data), and *errors*. +- The *TraceContext* HTTP standard defines how trace IDs and span contexts are propagated across systems, + enabling full traceability of operations. + +This data enables the creation of relationships between tasks and supports visualizations such as +architecture diagrams or execution flows. These help in identifying root causes of issues and bottlenecks, +and also assist newcomers in onboarding to the project. + +## Configuration + +- To enable tracing, you need to create an *Observer* object in XAPI. This can be done using the *xe* CLI: + ```sh + xe observer-create \ + name-label= \ + enabled=true \ + components=xapi,xenopsd \ + ``` +- By default, if you don't specify `enabled=true`, the observer will be disabled. +- To add an HTTP endpoint, make sure the server is up and running, then run: + ```sh + xe observer-param-set uuid= endpoints=bugtool,http://:9411/api/v2/spans + ``` + If you specify an invalid or unreachable HTTP endpoint, the configuration will fail. +- **components**: Specify which internal components (e.g., *xapi*, *xenopsd*) should be traced. + Additional components are expected to be supported in future releases. An experimental *smapi* component + is also available and requires additional configuration (explained below). + +- **endpoints**: The observer can collect traces locally in */var/log/dt* or forward them to external + visualization tools such as [Jaeger](https://www.jaegertracing.io/). Currently, only HTTP/S endpoints + are supported, and they require additional configuration steps (see next section). + +- To disable tracing you just need to set *enabled* to false: + ```sh + xe observer-param-set uuid= enabled=false + ``` + +### Enabling smapi component + +- *smapi* component is currently considered experimental and is filtered by default. To enable it, you must + explicitly configure the following in **xapi.conf**: + ```ini + observer-experimental-components="" + ``` + This tells XAPI that no components are considered experimental, thereby allowing *smapi* to be traced. + A modification to **xapi.conf** requires a restart of the XAPI toolstack. + +### Enabling HTTP/S endpoints + +- By default HTTP and HTTPS endpoints are disabled. To enable them, add the following lines to **xapi.conf**: + ```ini + observer-endpoint-http-enabled=true + observer-endpoint-https-enabled=true + ``` + As with enabling *smapi* component, modifying **xapi.conf** requires a restart of the XAPI toolstack. + *Note*: HTTPS endpoint support is available but not tested and may not work. + +### Sending local trace to endpoint + +By default, traces are generated locally in the `/var/log/dt` directory. You can copy or forward +these traces to another location or endpoint using the `xs-trace` tool. For example, if you have +a *Jaeger* server running locally, you can run: + +```sh +xs-trace /var/log/dt/ http://127.0.0.1:9411/api/v2/spans +``` + +You will then be able to visualize the traces in Jaeger. + +### Tagging Trace Sessions for Easier Search + +#### Specific attributes +To make trace logs easier to locate and analyze, it can be helpful to add custom attributes around the +execution of specific commands. For example: + +```sh +# xe observer-param-set uuid= attributes:custom.random=1234 +# xe vm-start ... +# xe observer-param-clear uuid= param-name=attributes param-key=custom.random +``` + +This technique adds a temporary attribute, *custom.random=1234*, which will appear in the generated trace +spans, making it easier to search for specific activity in trace visualisation tools. It may also be possible +to achieve similar tagging using baggage parameters directly in individual *xe* commands, but this approach +is currently undocumented. + +#### Baggage + +*Baggage*, contextual information that resides alongside the context, is supported. This means you can run +the following command: + +```sh +BAGGAGE="mybaggage=apples" xe vm-list +``` + +You will be able to search for tags `mybaggage=apples`. + +#### Traceparent + +Another way to assist in trace searching is to use the `TRACEPARENT` HTTP header. It is an HTTP header field that +identifies the incoming request. It has a [specific format](https://www.w3.org/TR/trace-context/#traceparent-header) +and it is supported by **XAPI**. Once generated you can run command as: + +```sh +TRACEPARENT="00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01" xe vm-list +``` + +And you will be able to look for trace *4bf92f3577b34da6a3ce929d0e0e4736*. + +### Links + +- [Opentelemetry](https://opentelemetry.io/) +- [Trace Context](https://www.w3.org/TR/trace-context/) +- [Baggage](https://opentelemetry.io/docs/concepts/signals/baggage/) +- [Ocaml opentelemetry module](https://ocaml.org/p/opentelemetry/latest) diff --git a/doc/content/toolstack/features/events/index.md b/doc/content/toolstack/features/events/index.md index 3d76d4db92..98bdf17e6a 100644 --- a/doc/content/toolstack/features/events/index.md +++ b/doc/content/toolstack/features/events/index.md @@ -72,9 +72,9 @@ while True: events = session.xenapi.event.next() # block until a xapi event on a xapi DB object is available for event in events: print "received event op=%s class=%s ref=%s" % (event['operation'], event['class'], event['ref']) - if event['class'] == 'vm' and event['operatoin'] == 'mod': + if event['class'] == 'vm' and event['operation'] == 'mod': vm = event['snapshot'] - print "xapi-event on vm: vm_uuid=%s, power_state=%s, current_operation=%s" % (vm['uuid'],vm['name_label'],vm['power_state'],vm['current_operations'].values()) + print "xapi-event on vm: vm_uuid=%s, vm_name_label=%s, power_state=%s, current_operation=%s" % (vm['uuid'],vm['name_label'],vm['power_state'],vm['current_operations'].values()) except XenAPI.Failure, e: if len(e.details) > 0 and e.details[0] == 'EVENTS_LOST': session.xenapi.event.unregister(["VM","pool"]) diff --git a/doc/content/xapi/alarms/index.md b/doc/content/xapi/alarms/index.md new file mode 100644 index 0000000000..da4c9e542c --- /dev/null +++ b/doc/content/xapi/alarms/index.md @@ -0,0 +1,218 @@ ++++ +title = "How to set up alarms" +linkTitle = "Alarms" ++++ + +# Introduction + +In XAPI, alarms are triggered by a Python daemon located at `/opt/xensource/bin/perfmon`. +The daemon is managed as a systemd service and can be configured by setting parameters in `/etc/sysconfig/perfmon`. + +It listens on an internal Unix socket to receive commands. Otherwise, it runs in a loop, periodically requesting metrics from XAPI. It can then be configured to generate events based on these metrics. It can monitor various types of XAPI objects, including `VMs`, `SRs`, and `Hosts`. The configuration for each object is defined by writing an XML string into the object's `other-config` key. + +The metrics used by `perfmon` are collected by the `xcp-rrdd` daemon. The `xcp-rrdd` daemon is a component of XAPI responsible for collecting metrics and storing them as Round-Robin Databases (RRDs). + +A XAPI plugin also exists, providing the functions `refresh` and `debug_mem`, which send commands through the Unix socket. The `refresh` function is used when an `other-config` key is added or updated; it triggers the daemon to reread the monitored objects so that new alerts are taken into account. The `debug_mem` function logs the objects currently being monitored into `/var/log/user.log` as a dictionary. + +# Monitoring and alarms + +## Overview + +- To get the metrics, `perfmon` requests XAPI by calling: `http://localhost/rrd_updates?session_id=&start=1759912021&host=true&sr_uuid=all&cf=AVERAGE&interval=60` +- Different consolidation functions can be used like **AVERAGE**, **MIN**, **MAX** or **LAST**. See the details in the next sections for specific objects and how to set it. +- Once retrieve, `perfmon` will check all its triggers and generate alarms if needed. + +## Specific XAPI objects +### VMs + +- To set an alarm on a VM, you need to write an XML string into the `other-config` key of the object. For example, to trigger an alarm when the CPU usage is higher than 50%, run: +```sh +xe vm-param-set uuid= other-config:perfmon=' ' +``` + +- Then, you can either wait until the new configuration is read by the `perfmon` daemon or force a refresh by running: +```sh +xe host-call-plugin host-uuid= plugin=perfmon fn=refresh +``` + +- Now, if you generate some load inside the VM and the CPU usage goes above 50%, the `perfmon` daemon will create a message (a XAPI object) with the name **ALARM**. This message will include a _priority_, a _timestamp_, an _obj-uuid_ and a _body_. To list all messages that are alarms, run: +```sh +xe message-list name=ALARM +``` + +- You will see, for example: +```sh +uuid ( RO) : dadd7cbc-cb4e-5a56-eb0b-0bb31c102c94 + name ( RO): ALARM + priority ( RO): 3 + class ( RO): VM + obj-uuid ( RO): ea9efde2-d0f2-34bb-74cb-78c303f65d89 + timestamp ( RO): 20251007T11:30:26Z + body ( RO): value: 0.986414 +config: + + + + + + + +``` +- where the _body_ contains all the relevant information: the value that triggered the alarm and the configuration of your alarm. + +- When configuring you alarm, your XML string can: + - have multiple `` nodes + - use the following values for child nodes: + * **name**: what to call the variable (no default) + * **alarm_priority**: the priority of the messages generated (default '3') + * **alarm_trigger_level**: level of value that triggers an alarm (no default) + * **alarm_trigger_sense**:'high' if alarm_trigger_level is a max, otherwise 'low'. (default 'high') + * **alarm_trigger_period**: num seconds of 'bad' values before an alarm is sent (default '60') + * **alarm_auto_inhibit_period**: num seconds this alarm disabled after an alarm is sent (default '3600') + * **consolidation_fn**: how to combine variables from rrd_updates into one value (default is 'average' for 'cpu_usage', 'get_percent_fs_usage' for 'fs_usage', 'get_percent_log_fs_usage' for 'log_fs_usage','get_percent_mem_usage' for 'mem_usage', & 'sum' for everything else) + * **rrd_regex** matches the names of variables from (xe vm-data-sources-list uuid=$vmuuid) used to compute value (only has defaults for "cpu_usage", "network_usage", and "disk_usage") + +- Notice that `alarm_priority` will be the priority of the generated `message`, 0 being low priority. + +### SRs + +- To set an alarm on an SR object, as with VMs, you need to write an XML string into the `other-config` key of the SR. For example, you can run: +```sh +xe sr-param-set uuid= other-config:perfmon='' +``` +- When configuring you alarm, the XML string supports the same child elements as for VMs + +### Hosts + +- As with VMs ans SRs, alarms can be configured by writing an XML string into an `other-config` key. For example, you can run: +```sh +xe host-param-set uuid= other-config:perfmon=\ + '' +``` + +- The XML string can include multiple nodes allowed +- The full list of supported child nodes is: + * **name**: what to call the variable (no default) + * **alarm_priority**: the priority of the messages generated (default '3') + * **alarm_trigger_level**: level of value that triggers an alarm (no default) + * **alarm_trigger_sense**: 'high' if alarm_trigger_level is a max, otherwise 'low'. (default 'high') + * **alarm_trigger_period**: num seconds of 'bad' values before an alarm is sent (default '60') + * **alarm_auto_inhibit_period**:num seconds this alarm disabled after an alarm is sent (default '3600') + * **consolidation_fn**: how to combine variables from rrd_updates into one value (default is 'average' for 'cpu_usage' & 'sum' for everything else) + * **rrd_regex** matches the names of variables from (xe host-data-source-list uuid=) used to compute value (only has defaults for "cpu_usage", "network_usage", "memory_free_kib" and "sr_io_throughput_total_xxxxxxxx") where that last one ends with the first eight characters of the SR UUID) + +- As a special case for SR throughput, it is also possible to configure a Host by writing XML into the `other-config` key of an SR connected to it. For example: +```sh +xe sr-param-set uuid=$sruuid other-config:perfmon=\ + '' +``` +- This only works for that specific variable name, and `rrd_regex` must not be specified. +- Configuration done directly on the host (variable-name, sr_io_throughput_total_xxxxxxxx) takes priority. + +## Which metrics are available? + +- Accepted name for metrics are: + - **cpu_usage**: matches RRD metrics with the pattern `cpu[0-9]+` + - **network_usage**: matches RRD metrics with the pattern `vif_[0-9]+_[rt]x` + - **disk_usage**: match RRD metrics with the pattern `vbd_(xvd|hd)[a-z]+_(read|write)` + - **fs_usage**, **log_fs_usage**, **mem_usage** and **memory_internal_free** do not match anything by default. +- By using `rrd_regex`, you can add your own expressions. To get a list of available metrics with their descriptions, you can call the `get_data_sources` method for [VM](https://xapi-project.github.io/new-docs/xen-api/classes/vm/), for [SR](https://xapi-project.github.io/new-docs/xen-api/classes/sr/) and also for [Host](https://xapi-project.github.io/new-docs/xen-api/classes/host/). +- A python script is provided at the end to get data sources. Using the script we can, for example, see: +```sh +# ./get_data_sources.py --vm 5a445deb-0a8e-c6fe-24c8-09a0508bbe21 + +List of data sources related to VM 5a445deb-0a8e-c6fe-24c8-09a0508bbe21 +cpu0 | CPU0 usage +cpu_usage | Domain CPU usage +memory | Memory currently allocated to VM +memory_internal_free | Memory used as reported by the guest agent +memory_target | Target of VM balloon driver +... +vbd_xvda_io_throughput_read | Data read from the VDI, in MiB/s +... +``` +- You can then set up an alarm when the data read from a VDI exceeds a certain level by doing: +``` +xe vm-param-set uuid=5a445deb-0a8e-c6fe-24c8-09a0508bbe21 \ + other-config:perfmon=' \ + \ + \ + \ + ' +``` +- Here is the script that allows you to get data sources: +```python +#!/usr/bin/env python3 + +import argparse +import sys +import XenAPI + + +def pretty_print(data_sources): + if not data_sources: + print("No data sources.") + return + + # Compute alignment for something nice + max_label_len = max(len(data["name_label"]) for data in data_sources) + + for data in data_sources: + label = data["name_label"] + desc = data["name_description"] + print(f"{label:<{max_label_len}} | {desc}") + + +def list_vm_data(session, uuid): + vm_ref = session.xenapi.VM.get_by_uuid(uuid) + data_sources = session.xenapi.VM.get_data_sources(vm_ref) + print(f"\nList of data sources related to VM {uuid}") + pretty_print(data_sources) + + +def list_host_data(session, uuid): + host_ref = session.xenapi.host.get_by_uuid(uuid) + data_sources = session.xenapi.host.get_data_sources(host_ref) + print(f"\nList of data sources related to Host {uuid}") + pretty_print(data_sources) + + +def list_sr_data(session, uuid): + sr_ref = session.xenapi.SR.get_by_uuid(uuid) + data_sources = session.xenapi.SR.get_data_sources(sr_ref) + print(f"\nList of data sources related to SR {uuid}") + pretty_print(data_sources) + + +def main(): + parser = argparse.ArgumentParser( + description="List data sources related to VM, host or SR" + ) + parser.add_argument("--vm", help="VM UUID") + parser.add_argument("--host", help="Host UUID") + parser.add_argument("--sr", help="SR UUID") + + args = parser.parse_args() + + # Connect to local XAPI: no identification required to access local socket + session = XenAPI.xapi_local() + + try: + session.xenapi.login_with_password("", "") + if args.vm: + list_vm_data(session, args.vm) + if args.host: + list_host_data(session, args.host) + if args.sr: + list_sr_data(session, args.sr) + except XenAPI.Failure as e: + print(f"XenAPI call failed: {e.details}") + sys.exit(1) + finally: + session.xenapi.session.logout() + + +if __name__ == "__main__": + main() +``` + diff --git a/doc/content/xapi/guides/howtos/add-function.md b/doc/content/xapi/guides/howtos/add-function.md index 8aeedfb27f..cbde59a991 100644 --- a/doc/content/xapi/guides/howtos/add-function.md +++ b/doc/content/xapi/guides/howtos/add-function.md @@ -172,8 +172,8 @@ the Host module: let price_of ~__context ~host ~item = info "Host.price_of for item %s" item; let local_fn = Local.Host.price_of ~host ~item in - do_op_on ~local_fn ~__context ~host - (fun session_id rpc -> Client.Host.price_of ~rpc ~session_id ~host ~item) + let remote_fn = Client.Host.price_of ~host ~item in + do_op_on ~local_fn ~__context ~host ~remote_fn After the ~__context parameter, the parameters of this new function should match the parameters we specified for the message. In this case, that is the diff --git a/doc/content/xapi/internals/certificates.md b/doc/content/xapi/internals/certificates.md index 63a4d0b84a..c63a2499d6 100644 --- a/doc/content/xapi/internals/certificates.md +++ b/doc/content/xapi/internals/certificates.md @@ -53,7 +53,7 @@ pool or host to be used as an API. certificate. * See below for xapi-stunnel-ca-bundle for additional certificates that can be added to a pool in support of a user-supplied host certificate. -* `xe reset-server-certificate` creates a new self-signed certificate. +* `xe host-reset-server-certificate` creates a new self-signed certificate. ### `xapi-pool-tls.pem` diff --git a/doc/content/xapi/storage/_index.md b/doc/content/xapi/storage/_index.md index a3159580bf..925d13296e 100644 --- a/doc/content/xapi/storage/_index.md +++ b/doc/content/xapi/storage/_index.md @@ -26,57 +26,60 @@ D --> F[SMAPIv3 plugins] ## SMAPIv1 -These are the files related to SMAPIv1 in `xen-api/ocaml/xapi/`: - -- sm.ml: OCaml "bindings" for the SMAPIv1 Python "drivers" (SM) -- sm_exec.ml: - support for implementing the above "bindings". The - parameters are converted to XML-RPC, passed to the relevant python - script ("driver"), and then the standard output of the program is - parsed as an XML-RPC response (we use - `xen-api-libs-transitional/http-svr/xMLRPC.ml` for parsing XML-RPC). +These are the files related to SMAPIv1 in [`/ocaml/xapi/`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi): + +- [`sm.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/sm.ml): + OCaml "bindings" for the SMAPIv1 Python "drivers" (SM) +- [`sm_exec.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/sm_exec.ml): + support for implementing the above "bindings". + The parameters are converted to XML-RPC, passed to the relevant python script ("driver"), + and then the standard output of the program is parsed as an XML-RPC response (we use + [`ocaml/libs/http-lib/xMLRPC.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/libs/http-lib/xMLRPC.ml) + for parsing XML-RPC). When adding new functionality, we can modify `type call` to add parameters, but when we don't add any common ones, we should just pass the new parameters in the args record. -- `smint.ml`: Contains types, exceptions, ... for the SMAPIv1 OCaml - interface -- `storage_smapiv1_wrapper.ml`: A state machine for SMAPIv1 operations. It computes - the required actions to reach the desired state from the current state. -- `storage_smapiv1.ml`: Contains the actual translation of SMAPIv2 calls to SMAPIv1 - calls, by calling the bindings provided in sm.ml. +- [`smint.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/smint.ml): + Contains types, exceptions, ... for the SMAPIv1 OCaml interface. +- [`storage_smapiv1_wrapper.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_smapiv1_wrapper.ml): + The [`Wrapper`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_smapiv1_wrapper.ml#L360) + module wraps a SMAPIv2 server (`Server_impl`) and takes care of + locking and datapaths (in case of multiple connections (=datapaths) + from VMs to the same VDI, using a state machine for SMAPIv1 operations. + It will use the superstate computed by the + [`vdi_automaton.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-idl/storage/vdi_automaton.ml) + in xapi-idl) to compute the required actions to reach the desired state from the current one. + It also implements some functionality, like the `DP` module, that is not implemented in lower layers. +- [`storage_smapiv1.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_smapiv1.ml): + a SMAPIv2 server that translates SMAPIv2 calls to SMAPIv1 ones, by calling + [`ocaml/xapi/sm.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/sm.ml). + It calls passes the XML-RPC requests as the first command-line argument to the + corresponding Python script, which returns an XML-RPC response on standard + output. ## SMAPIv2 These are the files related to SMAPIv2, which need to be modified to implement new calls: -- [xcp-idl/storage/storage\_interface.ml](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-idl/storage/storage_interface.ml): +- [`ocaml/xapi-idl/storage/storage_interface.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-idl/storage/storage_interface.ml): Contains the SMAPIv2 interface -- [xcp-idl/storage/storage\_skeleton.ml](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-idl/storage/storage_skeleton.ml): +- [`ocaml/xapi-idl/storage/storage_skeleton.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-idl/storage/storage_skeleton.ml): A stub SMAPIv2 storage server implementation that matches the SMAPIv2 storage server interface (this is verified by - [storage\_skeleton\_test.ml](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-idl/storage/storage_skeleton_test.ml)), + [`storage_skeleton_test.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-idl/storage/storage_skeleton_test.ml)), each of its function just raise a `Storage_interface.Unimplemented` error. This skeleton is used to automatically fill the unimplemented methods of the below storage servers to satisfy the interface. -- [xen-api/ocaml/xapi/storage\_smapiv1.ml](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_smapiv1.ml): - a SMAPIv2 server that does SMAPIv2 -> SMAPIv1 translation. - It passes the XML-RPC requests as the first command-line argument to the - corresponding Python script, which returns an XML-RPC response on standard - output. -- [xen-api/ocaml/xapi/storage_smapiv1_wrapper.ml](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_smapiv1_wrapper.ml): - The [Wrapper](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_smapiv1_wrapper.ml#L360) - module wraps a SMAPIv2 server (Server\_impl) and takes care of - locking and datapaths (in case of multiple connections (=datapaths) - from VMs to the same VDI, it will use the superstate computed by the - [Vdi_automaton](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-idl/storage/vdi_automaton.ml) - in xcp-idl). It also implements some functionality, like the `DP` - module, that is not implemented in lower layers. -- [xen-api/ocaml/xapi/storage\_mux.ml](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_mux.ml): +- [`ocaml/xapi/storage_mux.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_mux.ml): A SMAPIv2 server, which multiplexes between other servers. A different SMAPIv2 server can be registered for each SR. Then it forwards the calls for each SR to the "storage plugin" registered for that SR. +- [`ocaml/xapi/storage_smapiv1_wrapper.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_smapiv1_wrapper.ml): + Implements a state machine to compute SMAPIv1 actions needed to reach the desired state, see [SMAPIv1](#smapiv1). +- [`ocaml/xapi/storage_smapiv1.ml`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi/storage_smapiv1.ml): + Translates the SMAPIv2 calls to SMAPIv1, see [SMAPIv1](#smapiv1). ### How SMAPIv2 works: @@ -211,31 +214,28 @@ It also implements the `Policy` module from the SMAPIv2 interface. ## SMAPIv3 -[SMAPIv3](https://xapi-project.github.io/xapi-storage/) has a slightly -different interface from SMAPIv2.The -[xapi-storage-script](https://github.com/xapi-project/xen-api/tree/v25.11.0/ocaml/xapi-storage-script) -daemon is a SMAPIv2 plugin separate from xapi that is doing the SMAPIv2 -↔ SMAPIv3 translation. It keeps the plugins registered with xapi-idl -(their message-switch queues) up to date as their files appear or -disappear from the relevant directory. +[SMAPIv3](https://xapi-project.github.io/xapi-storage/) has a slightly different interface from SMAPIv2. +The +[`xapi-storage-script`](https://github.com/xapi-project/xen-api/tree/v25.11.0/ocaml/xapi-storage-script) +daemon is a SMAPIv2 plugin separate from xapi that is doing the SMAPIv2 ↔ SMAPIv3 translation. +It keeps the plugins registered with xapi-idl (their message-switch queues) +up to date as their files appear or disappear from the relevant directory. ### SMAPIv3 Interface The SMAPIv3 interface is defined using an OCaml-based IDL from the -[ocaml-rpc](https://github.com/mirage/ocaml-rpc) library, and is in this -repo: +[`ocaml-rpc`](https://github.com/mirage/ocaml-rpc) library, and is located at +[`xen-api/ocaml/xapi-storage`](https://github.com/xapi-project/xen-api/tree/v25.11.0/ocaml/xapi-storage) From this interface we generate -- OCaml RPC client bindings used in - [xapi-storage-script](https://github.com/xapi-project/xapi-storage-script) -- The [SMAPIv3 API - reference](https://xapi-project.github.io/xapi-storage) +- OCaml RPC client bindings used in `xapi-storage-script` +- The + [SMAPIv3 API reference](https://xapi-project.github.io/xapi-storage) - Python bindings, used by the SM scripts that implement the SMAPIv3 interface. - - These bindings are built by running "`make`" in the root - [xapi-storage](https://github.com/xapi-project/xapi-storage), - and appear in the` _build/default/python/xapi/storage/api/v5` + - These bindings are built by running `make` at the root level, + and appear in the` _build/default/ocaml/xapi-storage/python/xapi/storage/api/v5/` directory. - On a XenServer host, they are stored in the `/usr/lib/python3.6/site-packages/xapi/storage/api/v5/` @@ -258,20 +258,20 @@ stored in subdirectories of the `/usr/libexec/xapi-storage-script/volume/` and `/usr/libexec/xapi-storage-script/datapath/` directories, respectively. When it finds a new datapath plugin, it adds the plugin to a lookup table and -uses it the next time that datapath is required. When it finds a new volume -plugin, it binds a new [message-switch](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-storage-script/main.ml#L2023) queue named after the plugin's -subdirectory to a new server instance that uses these volume scripts. +uses it the next time that datapath is required. +When it finds a new volume plugin, it binds a new +[`message-switch`](https://github.com/xapi-project/xen-api/blob/v25.11.0/ocaml/xapi-storage-script/main.ml#L2023) +queue named after the plugin's subdirectory to a new server instance that uses these volume scripts. To invoke a SMAPIv3 method, it executes a program named -`.` in the plugin's directory, for -example +`.` in the plugin's directory, +for example `/usr/libexec/xapi-storage-script/volume/org.xen.xapi.storage.gfs2/SR.ls`. The inputs to each script can be passed as command-line arguments and -are type-checked using the generated Python bindings, and so are the -outputs. The URIs of the SRs that xapi-storage-script knows about are -stored in the `/var/run/nonpersistent/xapi-storage-script/state.db` -file, these URIs can be used on the command line when an sr argument is -expected. +are type-checked using the generated Python bindings, and so are the outputs. +The URIs of the SRs that xapi-storage-script knows about are stored in the + `/var/run/nonpersistent/xapi-storage-script/state.db` file, +these URIs can be used on the command line when an sr argument is expected. #### Registration of the various SMAPIv3 plugins diff --git a/doc/content/xapi/storage/sxm.md b/doc/content/xapi/storage/sxm/index.md similarity index 87% rename from doc/content/xapi/storage/sxm.md rename to doc/content/xapi/storage/sxm/index.md index 8b7971bed7..4a8a68ced5 100644 --- a/doc/content/xapi/storage/sxm.md +++ b/doc/content/xapi/storage/sxm/index.md @@ -9,7 +9,17 @@ Title: Storage migration - [Thought experiments on an alternative design](#thought-experiments-on-an-alternative-design) - [Design](#design) - [SMAPIv1 migration](#smapiv1-migration) + - [Preparation](#preparation) + - [Establishing mirror](#establishing-mirror) + - [Mirror](#mirror) + - [Snapshot](#snapshot) + - [Copy and compose](#copy-and-compose) + - [Finish](#finish) - [SMAPIv3 migration](#smapiv3-migration) + - [Preparation](#preparation-1) + - [Establishing mirror](#establishing-mirror-1) + - [Limitations](#limitations) + - [Finish](#finish-1) - [Error Handling](#error-handling) - [Preparation (SMAPIv1 and SMAPIv3)](#preparation-smapiv1-and-smapiv3) - [Snapshot and mirror failure (SMAPIv1)](#snapshot-and-mirror-failure-smapiv1) @@ -122,10 +132,44 @@ it will be handled just as before. ## SMAPIv1 migration +This section is about migration from SMAPIv1 SRs to SMAPIv1 or SMAPIv3 SRs, since +the migration is driven by the source host, it is usally the source host that +determines most of the logic during a storage migration. + +First we take a look at an overview diagram of what happens during SMAPIv1 SXM: +the diagram is labelled with S1, S2 ... which indicates different stages of the migration. +We will talk about each stage in more detail below. + +![overview-v1](sxm-overview-v1.svg) + +### Preparation + +Before we can start our migration process, there are a number of preparations +needed to prepare for the following mirror. For SMAPIv1 this involves: + +1. Create a new VDI (called leaf) that will be used as the receiving VDI for all the new writes +2. Create a dummy snapshot of the VDI above to make sure it is a differencing disk and can be composed later on +3. Create a VDI (called parent) that will be used to receive the existing content of the disk (the snapshot) + +Note that the leaf VDI needs to be attached and activated on the destination host (to a non-exsiting `mirror_vm`) +since it will later on accept writes to mirror what is written on the source host. + +The parent VDI may be created in two different ways: 1. If there is a "similar VDI", +clone it on the destination host and use it as the parent VDI; 2. If there is no +such VDI, create a new blank VDI. The similarity here is defined by the distances +between different VDIs in the VHD tree, which is exploiting the internal representation +of the storage layer, hence we will not go into too much detail about this here. + +Once these preparations are done, a `mirror_receive_result` data structure is then +passed back to the source host that will contain all the necessary information about +these new VDIs, etc. + +### Establishing mirror + At a high level, mirror establishment for SMAPIv1 works as follows: 1. Take a snapshot of a VDI that is attached to VM1. This gives us an immutable -copy of the current state of the VDI, with all the data until the point we took +copy of the current state of the VDI, with all the data up until the point we took the snapshot. This is illustrated in the diagram as a VDI and its snapshot connecting to a shared parent, which stores the shared content for the snapshot and the writable VDI from which we took the snapshot (snapshot) @@ -135,12 +179,174 @@ client VDI will also be written to the mirrored VDI on the remote host (mirror) 4. Compose the mirror and the snapshot to form a single VDI 5. Destroy the snapshot on the local host (cleanup) +#### Mirror + +The mirroring process for SMAPIv1 is rather unconventional, so it is worth +documenting how this works. Instead of a conventional client server architecture, +where the source client connects to the destination server directly through the +NBD protocol in tapdisk, the connection is established in xapi and then passed +onto tapdisk. It was done in this rather unusual way mainly due to authentication +issues. Because it is xapi that is creating the connection, tapdisk does not need +to be concerned about authentication of the connection, thus simplifying the storage +component. This is reasonable as the storage component should focus on handling +storage requests rather than worrying about network security. + +The diagram below illustrates this prcess. First, xapi on the source host will +initiate an https request to the remote xapi. This request contains the necessary +information about the VDI to be mirrored, and the SR that contains it, etc. This +information is then passed onto the https handler on the destination host (called +`nbd_handler`) which then processes this information. Now the unusual step is that +both the source and the destination xapi will pass this connection onto tapdisk, +by sending the fd representing the socket connection to the tapdisk process. On +the source this would be nbd client process of tapdisk, and on the destination +this would be the nbd server process of the tapdisk. After this step, we can consider +a client-server connection is established between two tapdisks on the client and +server, as if the tapdisk on the source host makes a request to the tapdisk on the +destination host and initiates the connection. On the diagram, this is indicated +by the dashed lines between the tapdisk processes. Logically, we can view this as +xapi creates the connection, and then passes this connection down into tapdisk. + +![mirror](sxm-mirror-v1.svg) + +#### Snapshot + +The next step would be create a snapshot of the VDI. This is easily done as a +`VDI.snapshot` operation. If the VDI was in VHD format, then internally this would +create two children for, one for the snapshot, which only contains the metadata +information and tends to be small, the other for the writable VDI where all the +new writes will go to. The shared base copy contains the shared blocks. + +![snapshot](sxm-snapshot-v1.svg) + +#### Copy and compose + +Once the snapshot is created, we can then copy the snapshot from the source +to the destination. This step is done by `sparse_dd` using the nbd protocol. This +is also the step that takes the most time to complete. + +`sparse_dd` is a process forked by xapi that does the copying of the disk blocks. +`sparse_dd` can supports a number of protocols, including nbd. In this case, `sparse_dd` +will initiate an https put request to the destination host, with a url of the form +`
/services/SM/nbdproxy//`. This https request then +gets handled by the https handler on the destination host B, which will then spawn +a handler thread. This handler will find the +"generic" nbd server[^2] of either tapdisk or qemu-dp, depending on the destination +SR type, and then start proxying data between the https connection socket and the +socket connected to the nbd server. + +[^2]: The server is generic because it does not accept fd passing, and I call those +"special" nbd server/fd receiver. + +![sxm new copy](sxm-new-copy-v1.svg) + +Once copying is done, the snapshot and mirrored VDI can be then composed into a +single VDI. + +#### Finish + +At this point the VDI is synchronised to the new host! Mirror is still working at this point +though because that will not be destroyed until the VM itself has been migrated +as well. Some cleanups are done at this point, such as deleting the snapshot +that is taken on the source, destroying the mirror datapath, etc. + +The end results look like the following. Note that VM2 is in dashed line as it +is not yet created yet. The next steps would be to migrate the VM1 itself to the +destination as well, but this is part of the VM migration process and will not +be covered here. + +![final](sxm-final-v1.svg) -more detail to come... ## SMAPIv3 migration -More detail to come... +This section covers the mechanism of migrations *from* SRs using SMAPIv3 (to +SMAPIv1 or SMAPIv3). Although the core ideas are the same, SMAPIv3 has a rather +different mechanism for mirroring: 1. it does not require xapi to take snapshot +of the VDI anymore, since the mirror itself will take care of replicating the +existing data to the destination; 2. there is no fd passing for connection establishment anymore, and instead proxies are used for connection setup. + +### Preparation + +The preparation work for SMAPIv3 is greatly simplified by the fact that the mirror +at the storage layer will copy the existing data in the VDI to the destination. +This means that snapshot of the source VDI is not required anymore. So we are left +with only one thing: + +1. Create a VDI used for mirroring the data of the source VDI + +For this reason, the implementation logic for SMAPIv3 preparation is also shorter, +as the complexity is now handled by the storage layer, which is where it is supposed +to be handled. + +### Establishing mirror + +The other significant difference is that the storage backend for SMAPIv3 `qemu-dp` +SRs no longer accepts fds, so xapi needs to proxy the data between two nbd client +and nbd server. + +SMAPIv3 provides the `Data.mirror uri domain remote` which needs three parameters: +`uri` for accessing the local disk, `doamin` for the domain slice on which mirroring +should happen, and most importantly for this design, a `remote` url which represents +the remote nbd server to which the blocks of data can be sent to. + +This function itself, when called by xapi and forwarded to the storage layer's qemu-dp +nbd client, will initiate a nbd connection to the nbd server pointed to by `remote`. +This works fine when the storage migration happens entirely within a local host, +where qemu-dp's nbd client and nbd server can communicate over unix domain sockets. +However, it does not work for inter-host migrations as qemu-dp's nbd server is not +exposed publicly over the network (just as tapdisk's nbd server). Therefore a proxying +service on the source host is needed for forwarding the nbd connection from the +source host to the destination host. And it would be the responsiblity of +xapi to manage this proxy service. + +The following diagram illustrates the mirroring process of a single VDI: + +![sxm mirror](sxm-mirror-v3.svg) + +The first step for xapi is then to set up a nbd proxy thread that will be listening +on a local unix domain socket with path `/var/run/nbdproxy/export/` where +domain is the `domain` parameter mentioned above in `Data.mirror`. The nbd proxy +thread will accept nbd connections (or rather any connections, it does not +speak/care about nbd protocol at all) and sends an https put request +to the remote xapi. The proxy itself will then forward the data exactly as it is +to the remote side through the https connection. + +Once the proxy is set up, xapi will call `Data.mirror`, which +will be forwarded to the xapi-storage-script and is further forwarded to the qemu-dp. +This call contains, among other parameters, the destination NBD server url (`remote`) +to be connected. In this case the destination nbd server is exactly the domain +socket to which the proxy thread is listening. Therefore the `remote` parameter +will be of the form `nbd+unix:///?socket=` where the export is provided +by the destination nbd server that represents the VDI prepared on the destination +host, and the socket will be the path of the unix domain socket where the proxy +thread (which we just created) is listening at. + +When this connection is set up, the proxy process will talk to the remote xapi via +https requests, and on the remote side, an https handler will proxy this request to +the appropriate nbd server of either tapdisk or qemu-dp, using exactly the same +[import proxy](#copy-and-compose) as mentioned before. + +Note that this proxying service is tightly integrated with outbound SXM of SMAPIv3 +SRs. This is to make it simple to focus on the migration itself. + +Although there is no need to explicitly copy the VDI anymore, we still need to +transfer the data and wait for it finish. For this we use `Data.stat` call provided +by the storage backend to query the status of the mirror, and wait for it to finish +as needed. + +#### Limitations + +This way of establishing the connection simplifies the implementation of the migration +for SMAPIv3, but it also has limitations: + +One proxy per live VDI migration is needed, which can potentially consume lots of resources in dom0, and we should measure the impact of this before we switch to using more resource-efficient ways such as wire guard that allows establishing a single connection between multiple hosts. + + +### Finish + +As there is no need to copy a VDI, there is also no need to compose or delete the +snapshot. The cleanup procedure would therefore just involve destroy the datapath +that was used for receiving writes for the mirrored VDI. ## Error Handling @@ -168,10 +374,10 @@ helps separate the error handling logic into the `with` part of a `try with` blo which is where they are supposed to be. Since we need to accommodate the existing SMAPIv1 migration (which has more stages than SMAPIv3), the following stages are introduced: preparation (v1,v3), snapshot(v1), mirror(v1, v3), copy(v1). Note that -each stage also roughly corresponds to a helper function that is called within `MIRROR.start`, +each stage also roughly corresponds to a helper function that is called within `Storage_migrate.start`, which is the wrapper function that initiates storage migration. And each helper functions themselves would also have error handling logic within themselves as -needed (e.g. see `Storage_smapiv1_migrate.receive_start) to deal with exceptions +needed (e.g. see `Storage_smapiv1_migrate.receive_start`) to deal with exceptions that happen within each helper functions. ### Preparation (SMAPIv1 and SMAPIv3) @@ -203,7 +409,16 @@ are migrating from. ### Mirror failure (SMAPIv3) -To be filled... +The `Data.stat` call in SMAPIv3 returns a data structure that includes the current +progress of the mirror job, whether it has completed syncing the existing data and +whether the mirorr has failed. Similar to how it is done in SMAPIv1, we wait for +the sync to complete once we issue the `Data.mirror` call, by repeatedly polling +the status of the mirror using the `Data.stat` call. During this process, the status +of the mirror is also checked and if a failure is detected, a `Migration_mirror_failure` +will be raised and then gets handled by the code in `storage_migrate.ml` by calling +`Storage_smapiv3_migrate.receive_cancel2`, which will clean up the mirror datapath +and destroy the mirror VDI, similar to what is done in SMAPIv1. + ### Copy failure (SMAPIv1) @@ -215,6 +430,14 @@ failure during copying. ## SMAPIv1 Migration implementation detail +{{% notice info %}} +The following doc refers to the xapi a [version](https://github.com/xapi-project/xen-api/blob/v24.37.0/ocaml/xapi/storage_migrate.ml) +of xapi that is before 24.37 after which point this code structure has undergone +many changes as part of adding support for SMAPIv3 SXM. Therefore the following +tutorial might be less relevant in terms of the implementation detail. Although +the general principle should remain the same. +{{% /notice %}} + ```mermaid sequenceDiagram participant local_tapdisk as local tapdisk diff --git a/doc/content/xapi/storage/sxm/sxm-final-v1.svg b/doc/content/xapi/storage/sxm/sxm-final-v1.svg new file mode 100644 index 0000000000..7cdb2d540a --- /dev/null +++ b/doc/content/xapi/storage/sxm/sxm-final-v1.svg @@ -0,0 +1,4 @@ + + + +
VM1
Host1
VDI
Host2
VDI
VM2
SR1
Mirror
SR2
 \ No newline at end of file diff --git a/doc/content/xapi/storage/sxm/sxm-mirror-v1.svg b/doc/content/xapi/storage/sxm/sxm-mirror-v1.svg new file mode 100644 index 0000000000..4b6f61131c --- /dev/null +++ b/doc/content/xapi/storage/sxm/sxm-mirror-v1.svg @@ -0,0 +1,4 @@ + + + +
xapi
xapi
VDI
VDI
xapi
xapi
tapdisk
tapdisk
Host A
Host A
Host B
Host B
http connection
http connection
pass client socket of the http connection
via SCM_RIGHTS
pass client socket o...
tapdisk
tapdisk
http handler
http handler
pass server socket of the http connection
pass server socket o...
VDI
VDI
mirror
mirrorText is not SVG - cannot display \ No newline at end of file diff --git a/doc/content/xapi/storage/sxm/sxm-mirror-v3.svg b/doc/content/xapi/storage/sxm/sxm-mirror-v3.svg new file mode 100644 index 0000000000..8ed03406ac --- /dev/null +++ b/doc/content/xapi/storage/sxm/sxm-mirror-v3.svg @@ -0,0 +1,4 @@ + + + +
xapi
xapi
Source Host A
Destination Host B
tapdisk
qemu-dp
generic nbd server
generic nbd server
xapi-storage-script
Data.mirror 
qemu-dp 
nbd client
Data.mirror 
nbd exporting proxy
http handler
http request
nbd import proxy
Legend
belongs/spawns
talks to
 \ No newline at end of file diff --git a/doc/content/xapi/storage/sxm/sxm-new-copy-v1.svg b/doc/content/xapi/storage/sxm/sxm-new-copy-v1.svg new file mode 100644 index 0000000000..891913850d --- /dev/null +++ b/doc/content/xapi/storage/sxm/sxm-new-copy-v1.svg @@ -0,0 +1,4 @@ + + + +
xapi
xapi
Host A
Host B
tapdisk
http connection
qemu-dp
generic nbd server
generic nbd server
proxy
sparse_dd
http handler
 \ No newline at end of file diff --git a/doc/content/xapi/storage/sxm/sxm-overview-v1.svg b/doc/content/xapi/storage/sxm/sxm-overview-v1.svg new file mode 100644 index 0000000000..b6002382db --- /dev/null +++ b/doc/content/xapi/storage/sxm/sxm-overview-v1.svg @@ -0,0 +1,4 @@ + + + +
VM1
Host1
VDI
VDI snapshot
Host2
VDI
VDI snapshot
VM2
SR1
SR2
S2:Mirror
S1:Snapshot
S3: Copy
S4: Compose
 \ No newline at end of file diff --git a/doc/content/xapi/storage/sxm/sxm-snapshot-v1.svg b/doc/content/xapi/storage/sxm/sxm-snapshot-v1.svg new file mode 100644 index 0000000000..5fe0f398c1 --- /dev/null +++ b/doc/content/xapi/storage/sxm/sxm-snapshot-v1.svg @@ -0,0 +1,4 @@ + + + +
VDI
VDI snapshot
base
 \ No newline at end of file diff --git a/doc/content/xapi/storage/sxm_mux_inbound.svg b/doc/content/xapi/storage/sxm/sxm_mux_inbound.svg similarity index 100% rename from doc/content/xapi/storage/sxm_mux_inbound.svg rename to doc/content/xapi/storage/sxm/sxm_mux_inbound.svg diff --git a/doc/content/xapi/storage/sxm_mux_outbound.svg b/doc/content/xapi/storage/sxm/sxm_mux_outbound.svg similarity index 100% rename from doc/content/xapi/storage/sxm_mux_outbound.svg rename to doc/content/xapi/storage/sxm/sxm_mux_outbound.svg diff --git a/doc/content/xcp-networkd/host-network-device-ordering-on-networkd.md b/doc/content/xcp-networkd/host-network-device-ordering-on-networkd.md new file mode 100644 index 0000000000..e142932d18 --- /dev/null +++ b/doc/content/xcp-networkd/host-network-device-ordering-on-networkd.md @@ -0,0 +1,342 @@ +--- +title: Host Network Device Ordering on Networkd +description: How does the host network device ordering work on networkd. +--- + +Purpose +------- + +One of the Toolstack's functions is to maintain a pool of hosts. A pool can be +constructed by joining a host into an existing pool. One challenge in this +process is determining which pool-wide network a network device on the joining +host should connect to. + +At first glance, this could be resolved by specifying a mapping between an +individual network device and a pool-wide network. However, this approach +would be burdensome for administrators when managing many hosts. It would be +more efficient if the Toolstack could determine this automatically. + +To achieve this, the Toolstack components on two hosts need to independently +work out consistent identifications for the host network devices and connect +the network devices with the same identification to the same pool-wide network. +The identifications on a host can be considered as an order, with each network +device assigned a unique position in the order as its identification. Network +devices with the same position will connect to the same network. + + +The assumption +-------------- + +Why can the Toolstack components on two hosts independently work out an expected +order without any communication? This is possible only under the assumption that +the hosts have identical hardware, firmware, software, and the way +network devices are plugged into them. For example, an administrator will always +plug the network devices into the same PCI slot position on multiple hosts if +they want these network devices to connect to the same network. + +The ordering is considered consistent if the positions of such network devices +(plugged into the same PCI slot position) in the generated orders are the same. + + +The biosdevname +--------------- +Particularly, when the assumption above holds, a consistent initial order can be +worked out on multiple hosts independently with the help of `biosdevname`. The +"all_ethN" policy of the `biosdevname` utility can generate a device order based +on whether the device is embedded or not, PCI cards in ascending slot order, and +ports in ascending PCI bus/device/function order breadth-first. Since the hosts +are identical, the orders generated by the `biosdevname` are consistent across +the hosts. + +An example of `biosdevname`'s output is as the following. The initial order can +be derived from the `BIOS device` field. + +``` +# biosdevname --policy all_ethN -d -x +BIOS device: eth0 +Kernel name: enp5s0 +Permanent MAC: 00:02:C9:ED:FD:F0 +Assigned MAC : 00:02:C9:ED:FD:F0 +Bus Info: 0000:05:00.0 +... + +BIOS device: eth1 +Kernel name: enp5s1 +Permanent MAC: 00:02:C9:ED:FD:F1 +Assigned MAC : 00:02:C9:ED:FD:F1 +Bus Info: 0000:05:01.0 +... +``` + +However, the `BIOS device` of a particular network device may change with the +addition or removal of devices. For example: + +``` +# biosdevname --policy all_ethN -d -x +BIOS device: eth0 +Kernel name: enp4s0 +Permanent MAC: EC:F4:BB:E6:D7:BB +Assigned MAC : EC:F4:BB:E6:D7:BB +Bus Info: 0000:04:00.0 +... + +BIOS device: eth1 +Kernel name: enp5s0 +Permanent MAC: 00:02:C9:ED:FD:F0 +Assigned MAC : 00:02:C9:ED:FD:F0 +Bus Info: 0000:05:00.0 +... + +BIOS device: eth2 +Kernel name: enp5s1 +Permanent MAC: 00:02:C9:ED:FD:F1 +Assigned MAC : 00:02:C9:ED:FD:F1 +Bus Info: 0000:05:01.0 +... +``` + +Therefore, the order derived from these values is used solely for determining +the initial order and the order of newly added devices. + +Principles +----------- +* Initially, the order is aligned with PCI slots. This is to make the connection +between cabling and order predictable: The network devices in identical PCI +slots have the same position. The rationale is that PCI slots are more +predictable than MAC addresses and correspond to physical locations. + +* Once a previous order has been established, the ordering should be maintained +as stable as possible despite changes to MAC addresses or PCI addresses. The +rationale is that the assumption is less likely to hold as long as the hosts are +experiencing updates and maintenance. Therefore, maintaining the stable order is +the best choice for automatic ordering. + +Notation +-------- + +``` +mac:pci:position +!mac:pci:position +``` + +A network device is characterised by + +* MAC address, which is unique. +* PCI slot, which is not unique and multiple network devices can share a PCI +slot. PCI addresses correspond to hardware PCI slots and thus are physically +observable. +* position, the position assigned to this network device by xcp-networkd. At any +given time, no position is assigned twice but the sequence of positions may have +holes. +* The `!mac:pci:position` notation indicates that this postion was previously +used but currently is free because the device it was assgined was removed. + +On a Linux system, MAC and PCI addresses have specific formats. However, for +simplicity, symbolic names are used here: MAC addresses use lowercase letters, +PCI addresses use uppercase letters, and positions use numbers. + +Scenarios +--------- + +### The initial order + +As mentioned above, the `biosdevname` can be used to generate consistent orders +for the network devices on multiple hosts. + +``` +current input: a:A b:D c:C +initial order: a:A:0 c:C:1 b:D:2 +``` + +This only works if the assumption of identical hardware, firmware, software, and +network device placement holds. And it is considered that the assumption will +hold for the majority of the use cases. + +Otherwise, the order can be generated from a user's configuration. The user can +specify the order explicilty for individual hosts. However, administrators would +prefer to avoid this as much as possible when managing many hosts. + +``` +user spec: a::0 c::1 b::2 +current input: a:A b:D c:C +initial order: a:A:0 c:C:1 b:D:2 +``` + +### Keep the order as stable as possible + +Once an initial order is created on an individual host, it should be kept as +stable as possible across host boot-ups and at runtime. For example, unless +there are hardware changes, the position of a network device in the initial +order should remain the same regardless of how many times the host is rebooted. + +To achieve this, the initial order should be saved persistently on the host's +local storage so it can be referenced in subsequent orderings. When performing +another ordering after the initial order has been saved, the position of a +currently unordered network device should be determined by finding its position +in the last saved order. The MAC address of the network device is a reliable +attribute for this purpose, as it is considered unique for each network device +globally. + +Therefore, the network devices in the saved order should have their MAC +addresses saved together, effectively mapping each position to a MAC address. +When performing an ordering, the stable position can be found by searching the +last saved order using the MAC address. + +``` +last order: a:A:0 c:C:1 b:D:2 +current input: a:A b:D c:C +new order: a:A:0 c:C:1 b:D:2 +``` + +Name labels of the network devices are not considered reliable enough to +identify particular devices. For example, if the name labels are determined by +the PCI address via systemd, and a firmware update changes the PCI addresses of +the network devices, the name labels will also change. + +The PCI addresses are not considered reliable as well. They may change due to +the firmeware update/setting changes or even plugging/unpluggig other devices. + +``` +last order: a:A:0 c:C:1 b:D:2 +current input: a:A b:B c:E +new order: a:A:0 c:E:1 b:B:2 +``` + +### Replacement + +However, what happens when the MAC address of an unordered network device cannot +be found in the last saved order? There are two possible scenarios: + +1. It's a newly added network device since the last ordering. +2. It's a new device that replaces an existing network device. + +Replacement is a supported scenario, as an administrator might replace a broken +network device with a new one. + +This can be recognized by comparing the PCI address where the network device is +located. Therefore, the PCI address of each network device should also be saved +in the order. In this case, searching the PCI address in the order results in +one of the following: + +1. Not found: This means the PCI address was not occupied during the last +ordering, indicating a newly added network device. +2. Found with a MAC address, but another device with this MAC address is still +present in the system: This suggests that the PCI address of an existing +network device (with the same MAC address) has changed since the last ordering. +This may be caused by either a device move or others like a firmware update. In +this case, the current unordered network device is considered newly added. + +``` +last order: a:A:0 c:C:1 b:D:2 +current input: a:A b:B c:C d:D +new order: a:A:0 c:C:1 b:B:2 d:D:3 +``` + +3. Found with a MAC address, and no current devices have this MAC address: This +indicates that a new network device has replaced the old one in the same PCI +slot. +The replacing network device should be assigned the same position as the +replaced one. + +``` +last order: a:A:0 c:C:1 b:D:2 +current input: a:A c:C d:D +new order: a:A:0 c:C:1 d:D:2 +``` + +### Removed devices + +A network device can be removed or unplugged since the last ordering. Its +position, MAC address, and PCI address are saved for future reference, and its +position will be reserved. This means there may be a gap in the order: a +position that was previously assigned to a network device is now vacant because +the device has been removed. + +``` +last order: a:A:0 c:C:1 b:D:2 +current input: a:A b:D +new order: a:A:0 !c:C:1 d:D:2 +``` + +### Newly added devices + +As long as `the assumption` holds, newly added devices since the last ordering +can be assigned positions consistently across multiple hosts. Newly added +devices will not be assigned the positions reserved for removed devices. + +``` +last order: a:A:0 !c:C:1 d:D:2 +current input: a:A d:D e:E +new order: a:A:0 !c:C:1 d:D:2 e:E:3 +``` + +### Removed and then added back + +It is a supported scenario for a removed device to be plugged back in, +regardless of whether it is in the same PCI slot or not. This can be recognized +by searching for the device in the saved removed devices using its MAC address. +The reserved position will be reassigned to the device when it is added back. + +``` +last order: a:A:0 !c:C:1 d:D:2 +current input: a:A c:F d:D e:E +new order: a:A:0 c:F:1 d:D:2 e:E:3 +``` + +### Multinic functions + +The multinic function is a special kind of network device. When this type of +physical device is plugged into a PCI slot, multiple network devices are +reported at a single PCI address. Additionally, the number of reported network +devices may change due to driver updates. + +``` +current input: a:A b:A c:A d:A +initial order: a:A:0 b:A:1 c:A:2 d:A:3 +``` + +As long as `the assumption` holds, the initial order of these devices can be +generated automatically and kept stable by using MAC addresses to identify +individual devices. However, `biosdevname` cannot reliably generate an order for +all devices reported at one PCI address. For devices located at the same PCI +address, their MAC addresses are used to generate the initial order. + +``` +last order: a:A:0 b:A:1 c:A:2 d:A:3 m:M:4 n:N:5 +current input: a:A b:A c:A d:A e:A f:A m:M n:N +new order: a:A:0 b:A:1 c:A:2 d:A:3 m:M:4 n:N:5 e:A:6 f:A:7 +``` + +For example, suppose `biosdevname` generates an order for a multinic function +and other non-multinic devices. Within this order, the N devices of the +multinic function with MAC addresses mac[1], ..., mac[N] are assigned positions +pos[1], ..., pos[N] correspondingly. `biosdevname` cannot ensure that the device +with mac[1] is always assigned position pos[1]. Instead, it ensures that the +entire set of positions pos[1], ..., pos[N] remains stable for the devices of +the multinic function. Therefore, to ensure the order follows the MAC address +order, the devices of the multinic function need to be sorted by their MAC +addresses within the set of positions. + +``` +last order: a:A:0 b:A:1 c:A:2 d:A:3 m:M:4 +current input: e:A f:A g:A h:A m:M +new order: e:A:0 f:A:1 g:A:2 h:A:3 m:M:4 +``` + +Rare cases that can not be handled automatically +------------------------------------------------ + +In summary, to keep the order stable, the auto-generated order needs to be saved +for the next ordering. When performing an automatic ordering for the current +network devices, either the MAC address or the PCI address is used to recognize +the device that was assigned the same position in the last ordering. If neither +the MAC address nor the PCI address can be used to find a position from the last +ordering, the device is considered newly added and is assigned a new position. + +However, following this sorting logic, the ordering result may not always be as +expected. In practice, this can be caused by various rare cases, such as +switching an existing network device to connect to another network, performing +firmware updates, changing firmware settings, or plugging/unplugging network +devices. It is not worth complicating the entire function for these rare cases. +Instead, the initial user's configuration can be used to handle these rare +scenarios. diff --git a/dune-project b/dune-project index 5ad3b3a0ff..8d329288de 100644 --- a/dune-project +++ b/dune-project @@ -1,771 +1,881 @@ -(lang dune 3.15) +(lang dune 3.20) + +(formatting + (enabled_for ocaml)) -(formatting (enabled_for ocaml)) (using menhir 2.0) + (using directory-targets 0.1) + (opam_file_location inside_opam_directory) (cram enable) + (implicit_transitive_deps false) + (generate_opam_files true) (name "xapi") -(source (github xapi-project/xen-api)) -(license "LGPL-2.1-only WITH OCaml-LGPL-linking-exception") -(authors "xen-api@lists.xen.org") -(maintainers "Xapi project maintainers") -(homepage "https://xapi-project.github.io/") - -(package - (name zstd) -) - - -(package - (name clock) - (synopsis "Xapi's library for managing time") - (authors "Jonathan Ludlam" "Pau Ruiz Safont") - (depends - (ocaml (>= 4.12)) - (alcotest :with-test) - astring - fmt - mtime - ptime - (xapi-log (= :version)) - (qcheck-core :with-test) - (qcheck-alcotest :with-test) - ) -) - -(package - (name tgroup) - (depends - xapi-log - xapi-stdext-unix) -) - -(package - (name xml-light2) -) - -(package - (name xapi-sdk) - (license "BSD-2-Clause") - (synopsis "Xen API SDK generation code") - (depends - (alcotest :with-test) - astring - (fmt :with-test) - mustache - (xapi-datamodel (= :version)) - (xapi-stdext-unix (and (= :version) :with-test)) - (xapi-test-utils :with-test) - ) - (allow_empty) -) -(package - (name xen-api-client-lwt) -) - -(package - (name xen-api-client) - (synopsis "Xen-API client library for remotely-controlling a xapi host") - (authors "David Scott" "Anil Madhavapeddy" "Jerome Maloberti" "John Else" "Jon Ludlam" "Thomas Sanders" "Mike McClurg") - (depends - (alcotest :with-test) - astring - (cohttp (>= "0.22.0")) - re - rpclib - uri - (uuid (= :version)) - (xapi-client (= :version)) - (xapi-idl (= :version)) - (xapi-rrd (= :version)) - (xapi-types (= :version)) - xmlm - ) -) +(source + (github xapi-project/xen-api)) -(package - (name xe) -) - -(package - (name xapi-types) -) - -(package - (name xapi-tracing) - (depends - ocaml - dune - (alcotest :with-test) - (fmt :with-test) - ppx_deriving_yojson - re - uri - (uuid :with-test) - (xapi-log (= :version)) - (xapi-stdext-threads (= :version)) - yojson - ) - (synopsis "Allows to instrument code to generate tracing information") - (description "This library provides modules to allow gathering runtime traces.") -) - -(package - (name xapi-tracing-export) - (depends - ocaml - cohttp-posix - dune - cohttp - ptime - result - rresult - rpclib - ppx_deriving_rpc - uri - (xapi-log (= :version)) - (xapi-open-uri (= :version)) - (xapi-stdext-threads (= :version)) - (xapi-stdext-unix (= :version)) - (xapi-tracing (= :version)) - (zstd (= :version)) - ) - (synopsis "Export traces in multiple protocols and formats") - (description "This library export traces is able to push traces to http endpoints or generate compressed tarballs in the filesystem.") -) - -(package - (name xapi-storage-script) -) - -(package - (name xapi-storage-cli) - (depends - cmdliner - re - rpclib - ppx_deriving_rpc - (xapi-client (= :version)) - (xapi-idl (= :version)) - (xapi-types (= :version)) - ) - (synopsis "A CLI for xapi storage services") - (description "The CLI allows you to directly manipulate virtual disk images, without them being attached to VMs.") -) - -(package - (name xapi-storage) -) - -(package - (name xapi-schema) -) - -(package - (name rrdd-plugin) - (synopsis "A plugin library for the xapi performance monitoring daemon") - (description "This library allows one to expose a datasource which can then be sampled by the performance monitoring daemon.") - (depends - ocaml - astring - rpclib - (rrd-transport (= :version)) - (xapi-forkexecd (= :version)) - (xapi-stdext-pervasives (= :version)) - (xapi-stdext-std (= :version)) - (xapi-stdext-threads (= :version)) - (xapi-stdext-unix (= :version)) - (xapi-idl (= :version)) - xenstore - xenstore_transport - ) -) - -(package - (name xapi-open-uri) -) - -(package - (name xapi-nbd) -) - -(package - (name xapi-log) -) - -(package - (name xapi-idl) -) - -(package - (name xapi-forkexecd) - (synopsis "Sub-process control service for xapi") - (description "This daemon creates and manages sub-processes on behalf of xapi.") - (depends - astring - (forkexec (= :version)) - (uuid (= :version)) - (xapi-stdext-unix (= :version)) - ) -) - -(package - (name xapi-expiry-alerts) -) - -(package - (name xapi-datamodel) -) - -(package - (name xapi-consts) -) - -(package - (name xapi-compression) -) - -(package - (name xapi-client) -) - -(package - (name xapi-cli-protocol) -) +(license "LGPL-2.1-only WITH OCaml-LGPL-linking-exception") -(package - (name xapi-debug) - (synopsis "Debugging tools for XAPI") - (description "Tools installed into the non-standard /opt/xensource/debug location") - (depends - alcotest - angstrom - astring - base64 - cmdliner - cohttp - cstruct - ctypes - domain-name - fd-send-recv - fmt - hex - integers - ipaddr - logs - magic-mime - mirage-crypto - mirage-crypto-pk - mirage-crypto-rng - mtime - pci - polly - ppx_deriving - ppx_deriving_rpc - ppx_sexp_conv - psq - ptime - qcheck-alcotest - qcheck-core - re - result - rpclib - rrdd-plugin - rresult - sexplib - sexplib0 - sha - tar - tar-unix - uri - uuidm - uutf - x509 - xapi-backtrace - xapi-log - xapi-types - xapi-stdext-pervasives - xapi-stdext-unix - xen-api-client - xen-api-client-lwt - xenctrl - xenstore_transport - xmlm - yojson - ) -) +(authors "xen-api@lists.xen.org") -(package - (name xapi-tools) - (synopsis "Various daemons and CLI applications required by XAPI") - (description "Includes message-switch, xenopsd, forkexecd, ...") - (depends - astring - base64 - cmdliner - cstruct-unix - fmt - logs - lwt - mtime - netlink - qmp - re - result - rpclib - rresult - uri - xenctrl - xmlm - yojson - ; can't use '= version' here yet, - ; 'xapi-tools' will have version ~dev, not 'master' like all the others - ; because it is not in xs-opam yet - rrd-transport - rrdd-plugin - xapi-tracing-export - xen-api-client - (alcotest :with-test) - (ppx_deriving_rpc :with-test) - (qcheck-core :with-test) - (xapi-test-utils :with-test) - (xenstore_transport :with-test) - ) -) +(maintainers "Xapi project maintainers") -(package - (name xapi) - (synopsis "The toolstack daemon which implements the XenAPI") - (description "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts.") - (depends - (ocaml (>= 4.09)) - (alcotest :with-test) - angstrom - astring - base-threads - base64 - (bos :with-test) - cdrom - (clock (= :version)) - cmdliner - cohttp - conf-pam - (crowbar :with-test) - cstruct - ctypes - ctypes-foreign - domain-name - (ezxenstore (= :version)) - fmt - fd-send-recv - hex - (http-lib (and :with-test (= :version))) ; the public library is only used for testing - integers - ipaddr - logs - magic-mime - mirage-crypto - mirage-crypto-pk - (mirage-crypto-rng (>= "0.11.0")) - (message-switch-unix (= :version)) - mtime - opentelemetry-client-ocurl - pci - (pciutil (= :version)) - polly - ppx_deriving_rpc - ppx_sexp_conv - ppx_deriving - psq - ptime - qcheck-alcotest - qcheck-core - re - result - rpclib - (rrdd-plugin (= :version)) - rresult - sexpr - sexplib - sexplib0 - sha - (stunnel (= :version)) - tar - tar-unix - uri - tgroup - (uuid (= :version)) - uutf - uuidm - x509 - xapi-backtrace - (xapi-client (= :version)) - (xapi-cli-protocol (= :version)) - (xapi-consts (= :version)) - (xapi-datamodel (= :version)) - (xapi-expiry-alerts (= :version)) - (xapi-idl (= :version)) - (xapi-inventory (= :version)) - (xapi-log (= :version)) - (xapi-stdext-pervasives (= :version)) - (xapi-stdext-std (= :version)) - (xapi-stdext-threads (= :version)) - (xapi-stdext-unix (= :version)) - (xapi-stdext-zerocheck (= :version)) - (xapi-test-utils :with-test) - (xapi-tracing (= :version)) - (xapi-tracing-export (= :version)) - (xapi-types (= :version)) - (xen-api-client-lwt (= :version)) - xenctrl ; for quicktest - xenstore_transport - xmlm - (xml-light2 (= :version)) - yojson - (zstd (= :version)) - ) -) +(homepage "https://xapi-project.github.io/") (package - (name vhd-tool) - (synopsis "Manipulate .vhd files") - (tags ("org.mirage" "org:xapi-project")) + (name zstd)) + +(package + (name clock) + (synopsis "Xapi's library for managing time") + (authors "Jonathan Ludlam" "Pau Ruiz Safont") + (depends + (ocaml + (>= 4.12)) + (alcotest :with-test) + astring + fmt + mtime + ptime + (xapi-log + (= :version)) + (qcheck-core :with-test) + (qcheck-alcotest :with-test))) + +(package + (name tgroup) + (depends xapi-log xapi-stdext-unix)) + +(package + (name xml-light2)) + +(package + (name xapi-sdk) + (license "BSD-2-Clause") + (synopsis "Xen API SDK generation code") + (depends + (alcotest :with-test) + astring + (fmt :with-test) + mustache + (xapi-datamodel + (= :version)) + (xapi-stdext-unix + (and + (= :version) + :with-test)) + (xapi-test-utils :with-test)) + (allow_empty)) + +(package + (name xen-api-client-lwt)) + +(package + (name xen-api-client) + (synopsis "Xen-API client library for remotely-controlling a xapi host") + (authors + "David Scott" + "Anil Madhavapeddy" + "Jerome Maloberti" + "John Else" + "Jon Ludlam" + "Thomas Sanders" + "Mike McClurg") + (depends + (alcotest :with-test) + astring + (cohttp + (>= "0.22.0")) + re + rpclib + uri + (uuid + (= :version)) + (xapi-client + (= :version)) + (xapi-idl + (= :version)) + (xapi-rrd + (= :version)) + (xapi-types + (= :version)) + xmlm)) + +(package + (name xe)) + +(package + (name xapi-types)) + +(package + (name xapi-tracing) + (depends + ocaml + dune + (alcotest :with-test) + (fmt :with-test) + ppx_deriving_yojson + re + uri + (uuid :with-test) + (xapi-log + (= :version)) + (xapi-stdext-threads + (= :version)) + yojson) + (synopsis "Allows to instrument code to generate tracing information") + (description + "This library provides modules to allow gathering runtime traces.")) + +(package + (name xapi-tracing-export) + (depends + ocaml + cohttp-posix + dune + cohttp + ptime + result + rresult + rpclib + ppx_deriving_rpc + uri + (xapi-log + (= :version)) + (xapi-open-uri + (= :version)) + (xapi-stdext-threads + (= :version)) + (xapi-stdext-unix + (= :version)) + (xapi-tracing + (= :version)) + (zstd + (= :version))) + (synopsis "Export traces in multiple protocols and formats") + (description + "This library export traces is able to push traces to http endpoints or generate compressed tarballs in the filesystem.")) + +(package + (name xapi-storage-script)) + +(package + (name xapi-storage-cli) + (depends + cmdliner + re + rpclib + ppx_deriving_rpc + (xapi-client + (= :version)) + (xapi-idl + (= :version)) + (xapi-types + (= :version)) + (xapi-stdext-zerocheck + (= :version))) + (synopsis "A CLI for xapi storage services") + (description + "The CLI allows you to directly manipulate virtual disk images, without them being attached to VMs.")) + +(package + (name xapi-storage)) + +(package + (name xapi-schema)) + +(package + (name rrdd-plugin) + (synopsis "A plugin library for the xapi performance monitoring daemon") + (description + "This library allows one to expose a datasource which can then be sampled by the performance monitoring daemon.") + (depends + ocaml + astring + rpclib + (rrd-transport + (= :version)) + (xapi-forkexecd + (= :version)) + (xapi-stdext-pervasives + (= :version)) + (xapi-stdext-std + (= :version)) + (xapi-stdext-threads + (= :version)) + (xapi-stdext-unix + (= :version)) + (xapi-idl + (= :version)) + xenstore + xenstore_transport)) + +(package + (name xapi-open-uri)) + +(package + (name xapi-nbd)) + +(package + (name xapi-log) + (synopsis "A Logs library required by xapi") + (description + "This package is provided for backwards compatibility only. No new package should use it.") + (depends + astring + fmt + logs + mtime + xapi-backtrace + (xapi-stdext-pervasives (= :version)))) + +(package + (name xapi-idl)) + +(package + (name xapi-forkexecd) + (synopsis "Sub-process control service for xapi") + (description + "This daemon creates and manages sub-processes on behalf of xapi.") + (depends + astring + (forkexec + (= :version)) + (uuid + (= :version)) + (xapi-stdext-unix + (= :version)))) + +(package + (name xapi-expiry-alerts)) + +(package + (name xapi-datamodel)) + +(package + (name xapi-consts)) + +(package + (name xapi-compression)) + +(package + (name xapi-client)) + +(package + (name xapi-cli-protocol)) + +(package + (name xapi-debug) + (synopsis "Debugging tools for XAPI") + (description + "Tools installed into the non-standard /opt/xensource/debug location") + (depends + alcotest + angstrom + astring + base64 + cmdliner + cohttp + cstruct + ctypes + domain-name + fd-send-recv + fmt + hex + integers + ipaddr + logs + magic-mime + mirage-crypto + mirage-crypto-pk + mirage-crypto-rng + mtime + pci + polly + ppx_deriving + ppx_deriving_rpc + ppx_sexp_conv + psq + ptime + qcheck-alcotest + qcheck-core + re + result + rpclib + rrdd-plugin + rresult + sexplib + sexplib0 + sha + tar + tar-unix + uri + uuidm + uutf + x509 + xapi-backtrace + xapi-log + xapi-types + xapi-stdext-pervasives + xapi-stdext-unix + xapi-stdext-zerocheck + xen-api-client + xen-api-client-lwt + xenctrl + xenstore_transport + xmlm + yojson)) + +(package + (name xapi-tools) + (synopsis "Various daemons and CLI applications required by XAPI") + (description "Includes message-switch, xenopsd, forkexecd, ...") + (depends + astring + base64 + cmdliner + cstruct-unix + fmt + logs + lwt + mtime + netlink + qmp + re + result + rpclib + rresult + uri + tyre + xenctrl + xmlm + yojson + ; can't use '= version' here yet, + ; 'xapi-tools' will have version ~dev, not 'master' like all the others + ; because it is not in xs-opam yet + rrd-transport + rrdd-plugin + xapi-tracing-export + xen-api-client + (alcotest :with-test) + (ppx_deriving_rpc :with-test) + (qcheck-core :with-test) + (xapi-test-utils :with-test) + (xenstore_transport :with-test))) + +(package + (name xapi) + (synopsis "The toolstack daemon which implements the XenAPI") + (description + "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts.") + (depends + (ocaml + (>= 4.09)) + (alcotest :with-test) + angstrom + astring + base-threads + base64 + (bos :with-test) + cdrom + (clock + (= :version)) + cmdliner + cohttp + conf-pam + (crowbar :with-test) + cstruct + ctypes + ctypes-foreign + domain-name + (ezxenstore + (= :version)) + fmt + fd-send-recv + hex + (http-lib + (and + :with-test + (= :version))) ; the public library is only used for testing + integers + ipaddr + logs + magic-mime + mirage-crypto + mirage-crypto-pk + (mirage-crypto-rng + (>= "0.11.0")) + (message-switch-unix + (= :version)) + mtime + opentelemetry-client-ocurl + pci + (pciutil + (= :version)) + polly + ppx_deriving_rpc + ppx_sexp_conv + ppx_deriving + psq + ptime + qcheck-alcotest + qcheck-core + re + result + rpclib + (rrdd-plugin + (= :version)) + rresult + sexpr + sexplib + sexplib0 + sha + (stunnel + (= :version)) + tar + tar-unix + uri + tgroup + (uuid + (= :version)) + uutf + uuidm + x509 + xapi-backtrace + (xapi-client + (= :version)) + (xapi-cli-protocol + (= :version)) + (xapi-consts + (= :version)) + (xapi-datamodel + (= :version)) + (xapi-expiry-alerts + (= :version)) + (xapi-idl + (= :version)) + (xapi-inventory + (= :version)) + (xapi-log + (= :version)) + (xapi-stdext-pervasives + (= :version)) + (xapi-stdext-std + (= :version)) + (xapi-stdext-threads + (= :version)) + (xapi-stdext-unix + (= :version)) + (xapi-stdext-zerocheck + (= :version)) + (xapi-test-utils :with-test) + (xapi-tracing + (= :version)) + (xapi-tracing-export + (= :version)) + (xapi-types + (= :version)) + (xen-api-client-lwt + (= :version)) + xenctrl ; for quicktest + xenstore_transport + xmlm + (xml-light2 + (= :version)) + yojson + (zstd + (= :version)))) + +(package + (name vhd-tool) + (synopsis "Manipulate .vhd files") + (tags + ("org.mirage" "org:xapi-project")) + (depends + (alcotest-lwt :with-test) + astring + bigarray-compat + cmdliner + cohttp + cohttp-lwt + conf-libssl + (cstruct + (>= "3.0.0")) + (ezxenstore + (= :version)) + (forkexec + (= :version)) + io-page + lwt + lwt_ssl + nbd + nbd-unix + ppx_cstruct + ppx_deriving_rpc + re + result + rpclib + ssl + sha + tar + uri + (vhd-format + (= :version)) + (vhd-format-lwt + (= :version)) + (xapi-idl + (= :version)) + (xapi-log + (= :version)) + (xen-api-client-lwt + (= :version)) + xenstore + xenstore_transport)) + +(package + (name vhd-format)) + +(package + (name vhd-format-lwt) + (synopsis "Lwt interface to read/write VHD format data") + (description + "A pure OCaml library to read and write\n[vhd](http://en.wikipedia.org/wiki/VHD_(file_format)) format data, plus a\nsimple command-line tool which allows vhd files to be interrogated,\nmanipulated, format-converted and streamed to and from files and remote\nservers.\n\nThis package provides an Lwt compatible interface to the library.") + (authors "Jon Ludlam" "Dave Scott") + (maintainers "Dave Scott ") + (tags + ("org:mirage" "org:xapi-project")) + (homepage "https://github.com/mirage/ocaml-vhd") + (source + (github mirage/ocaml-vhd)) + (depends + (ocaml + (>= "4.10.0")) + (alcotest :with-test) + (alcotest-lwt + (and + :with-test + (>= "1.0.0"))) + (bigarray-compat + (>= "1.1.0")) + (cstruct + (>= "6.0.0")) + cstruct-lwt + (fmt :with-test) + (lwt + (>= "3.2.0")) + (mirage-block + (>= "3.0.0")) + (rresult + (>= "0.7.0")) + (vhd-format + (= :version)) + (io-page + (and + :with-test + (>= "2.4.0"))))) + +(package + (name qcow-stream-tool) + (synopsis "Minimal CLI wrapper for qcow-stream") (depends - (alcotest-lwt :with-test) - astring - bigarray-compat + qcow-stream cmdliner - cohttp - cohttp-lwt - conf-libssl - (cstruct (>= "3.0.0")) - (ezxenstore (= :version)) - (forkexec (= :version)) - io-page - lwt - lwt_ssl - nbd - nbd-unix - ppx_cstruct - ppx_deriving_rpc - re - result - rpclib - ssl - sha - tar - uri - (vhd-format (= :version)) - (vhd-format-lwt (= :version)) - (xapi-idl (= :version)) - (xapi-log (= :version)) - (xen-api-client-lwt (= :version)) - xenstore - xenstore_transport - ) -) - -(package - (name vhd-format) -) - -(package - (name vhd-format-lwt) - (synopsis "Lwt interface to read/write VHD format data") - (description "A pure OCaml library to read and write -[vhd](http://en.wikipedia.org/wiki/VHD_(file_format)) format data, plus a -simple command-line tool which allows vhd files to be interrogated, -manipulated, format-converted and streamed to and from files and remote -servers. - -This package provides an Lwt compatible interface to the library.") - (authors "Jon Ludlam" "Dave Scott") - (maintainers "Dave Scott ") - (tags ("org:mirage" "org:xapi-project")) - (homepage "https://github.com/mirage/ocaml-vhd") - (source (github mirage/ocaml-vhd)) - (depends - (ocaml (>= "4.10.0")) - (alcotest :with-test) - (alcotest-lwt (and :with-test (>= "1.0.0"))) - (bigarray-compat (>= "1.1.0")) - (cstruct (>= "6.0.0")) - cstruct-lwt - (fmt :with-test) - (lwt (>= "3.2.0")) - (mirage-block (>= "3.0.0")) - (rresult (>= "0.7.0")) - (vhd-format (= :version)) - (io-page (and :with-test (>= "2.4.0"))) - ) -) - -(package - (name varstored-guard) -) - -(package - (name uuid) -) - -(package - (name stunnel) - (synopsis "Library used by xapi to herd stunnel processes") - (description "This library allows xapi to configure, launch and terminate stunnel processes that act as clients and servers.") - (depends - astring - (forkexec (= :version)) - (safe-resources (= :version)) - (uuid (= :version)) - (xapi-consts (= :version)) - xapi-inventory - (xapi-log (= :version)) - (xapi-stdext-pervasives (= :version)) - (xapi-stdext-threads (= :version)) - (xapi-stdext-unix (= :version)) - (odoc :with-doc) ) ) (package - (name sexpr) -) - -(package - (name safe-resources) -) - -(package - (name rrd-transport) - (synopsis "Shared-memory protocols for exposing system metrics") - (description "VMs running on a Xen host can use this library to expose performance counters which can be sampled by xapi's metric daemon.") - (authors "John Else") - (depends - (alcotest :with-test) - astring - bigarray-compat - cstruct - crc - (fmt :with-test) - rpclib - yojson - (xapi-idl (= :version)) - (xapi-rrd (= :version)) - (odoc :with-doc) - ) -) - -(package - (name pciutil) -) - -(package - (name message-switch-lwt) -) - -(package - (name message-switch-core) - (synopsis "A simple store-and-forward message switch") - (description "The switch stores messages in queues with well-known names. Clients use a simple HTTP protocol to enqueue and dequeue messages.") - (depends - astring - (cohttp (>= "0.21.1")) - ppx_deriving_rpc - ppx_sexp_conv - rpclib - sexplib - sexplib0 - uri - (xapi-log (= :version)) - (xapi-stdext-threads (= :version)) - (odoc :with-doc) - ) -) - -(package - (name message-switch-cli) -) - -(package - (name message-switch-unix) - (synopsis "A simple store-and-forward message switch") - (description "The switch stores messages in queues with well-known names. Clients use a simple HTTP protocol to enqueue and dequeue messages.") - (depends - base-threads - cohttp - (message-switch-core (= :version)) - ppx_deriving_rpc - rpclib - (xapi-stdext-threads (= :version)) - ) -) - -(package - (name message-switch) -) - -(package - (name http-lib) - (synopsis "An HTTP required used by xapi") - (description "This library allows xapi to perform varios activities related to the HTTP protocol.") - (depends - (alcotest :with-test) - astring - (base64 (>= "3.1.0")) - (clock (= :version)) - fmt - ipaddr - mtime - ppx_deriving_rpc - (qcheck-core :with-test) - rpclib - (safe-resources(= :version)) - sha - (stunnel (= :version)) - tgroup - uri - (uuid (= :version)) - xapi-backtrace - (xapi-idl (= :version)) - (xapi-log (= :version)) - (xapi-stdext-pervasives (= :version)) - (xapi-stdext-threads (= :version)) - (xapi-tracing (= :version)) - (xml-light2 (= :version)) - (odoc :with-doc) - ) -) - -(package - (name gzip) -) - -(package - (name forkexec) - (synopsis "Process-spawning library") - (description "Client and server library to spawn processes.") - (depends - astring - base-threads - (fd-send-recv (>= "2.0.0")) - ppx_deriving_rpc - rpclib - (uuid (= :version)) - xapi-backtrace - (xapi-log (= :version)) - (xapi-stdext-pervasives (= :version)) - (xapi-stdext-unix (= :version)) - (xapi-tracing (= :version)) - ) -) - -(package - (name ezxenstore) -) - -(package - (name cohttp-posix) -) - -(package - (name xapi-rrd) -) - -(package - (name xapi-inventory) -) - -(package - (name xapi-stdext-encodings) - (synopsis "Xapi's standard library extension, Encodings") - (authors "Jonathan Ludlam") - (depends - (ocaml (>= 4.13.0)) - (alcotest (and (>= 0.6.0) :with-test)) - (odoc :with-doc) - (bechamel :with-test) - (bechamel-notty :with-test) - (notty :with-test) - ) -) - -(package - (name xapi-stdext-pervasives) - (synopsis "Xapi's standard library extension, Pervasives") - (authors "Jonathan Ludlam") - (depends - (ocaml (>= 4.08)) - logs - (odoc :with-doc) - xapi-backtrace - ) -) - -(package - (name xapi-stdext-std) - (synopsis "Xapi's standard library extension, Stdlib") - (depends - (ocaml (>= 4.08.0)) - (alcotest :with-test) - (odoc :with-doc) - ) -) - -(package - (name xapi-stdext-threads) - (synopsis "Xapi's standard library extension, Threads") - (authors "Jonathan Ludlam") - (depends - ambient-context - base-threads - base-unix - (alcotest :with-test) - (clock (= :version)) - (fmt :with-test) - mtime - tgroup - (xapi-log (= :version)) - (xapi-stdext-pervasives (= :version)) - (xapi-stdext-unix (= :version)) - ) -) - -(package - (name xapi-stdext-unix) - (synopsis "Xapi's standard library extension, Unix") - (authors "Jonathan Ludlam") - (depends - (ocaml (>= 4.12.0)) - (alcotest :with-test) - astring - base-unix - (bisect_ppx :with-test) - (clock (and (= :version) :with-test)) - (fd-send-recv (>= 2.0.0)) - fmt - integers - (mtime (and (>= 2.0.0) :with-test)) - (logs :with-test) - (qcheck-core (and (>= 0.21.2) :with-test)) - (odoc :with-doc) - xapi-backtrace - unix-errno - (xapi-stdext-pervasives (= :version)) - polly - ) -) - -(package - (name xapi-stdext-zerocheck) - (synopsis "Xapi's standard library extension, Zerocheck") - (authors "Jonathan Ludlam") - (depends - (odoc :with-doc) - ) -) + (name varstored-guard)) + +(package + (name uuid)) + +(package + (name stunnel) + (synopsis "Library used by xapi to herd stunnel processes") + (description + "This library allows xapi to configure, launch and terminate stunnel processes that act as clients and servers.") + (depends + astring + (forkexec + (= :version)) + (safe-resources + (= :version)) + (uuid + (= :version)) + (xapi-consts + (= :version)) + xapi-inventory + (xapi-log + (= :version)) + (xapi-stdext-pervasives + (= :version)) + (xapi-stdext-std + (= :version)) + (xapi-stdext-threads + (= :version)) + (xapi-stdext-unix + (= :version)) + (odoc :with-doc))) + +(package + (name sexpr)) + +(package + (name safe-resources)) + +(package + (name rrd-transport) + (synopsis "Shared-memory protocols for exposing system metrics") + (description + "VMs running on a Xen host can use this library to expose performance counters which can be sampled by xapi's metric daemon.") + (authors "John Else") + (depends + (alcotest :with-test) + astring + bigarray-compat + cstruct + crc + (fmt :with-test) + rpclib + yojson + (xapi-idl + (= :version)) + (xapi-rrd + (= :version)) + (odoc :with-doc))) + +(package + (name pciutil)) + +(package + (name message-switch-lwt)) + +(package + (name message-switch-core) + (synopsis "A simple store-and-forward message switch") + (description + "The switch stores messages in queues with well-known names. Clients use a simple HTTP protocol to enqueue and dequeue messages.") + (depends + astring + (cohttp + (>= "0.21.1")) + ppx_deriving_rpc + ppx_sexp_conv + rpclib + sexplib + sexplib0 + uri + (xapi-log + (= :version)) + (xapi-stdext-threads + (= :version)) + (xapi-tracing (= :version)) + (odoc :with-doc))) + +(package + (name message-switch-cli)) + +(package + (name message-switch-unix) + (synopsis "A simple store-and-forward message switch") + (description + "The switch stores messages in queues with well-known names. Clients use a simple HTTP protocol to enqueue and dequeue messages.") + (depends + base-threads + cohttp + (message-switch-core + (= :version)) + ppx_deriving_rpc + rpclib + (xapi-stdext-threads + (= :version)) + (xapi-tracing (= :version)))) + +(package + (name message-switch)) + +(package + (name http-lib) + (synopsis "An HTTP required used by xapi") + (description + "This library allows xapi to perform varios activities related to the HTTP protocol.") + (depends + (alcotest :with-test) + astring + (base64 + (>= "3.1.0")) + (clock + (= :version)) + fmt + ipaddr + mtime + ppx_deriving_rpc + (qcheck-core :with-test) + rpclib + (safe-resources + (= :version)) + sha + (stunnel + (= :version)) + tgroup + uri + (uuid + (= :version)) + xapi-backtrace + (xapi-idl + (= :version)) + (xapi-log + (= :version)) + (xapi-stdext-pervasives + (= :version)) + (xapi-stdext-threads + (= :version)) + (xapi-tracing + (= :version)) + (xml-light2 + (= :version)) + (odoc :with-doc))) + +(package + (name gzip)) + +(package + (name forkexec) + (synopsis "Process-spawning library") + (description "Client and server library to spawn processes.") + (depends + astring + base-threads + (fd-send-recv + (>= "2.0.0")) + ppx_deriving_rpc + rpclib + (uuid + (= :version)) + xapi-backtrace + (xapi-log + (= :version)) + (xapi-stdext-pervasives + (= :version)) + (xapi-stdext-unix + (= :version)) + (xapi-tracing + (= :version)))) + +(package + (name ezxenstore)) + +(package + (name cohttp-posix)) + +(package + (name xapi-rrd)) + +(package + (name xapi-inventory)) + +(package + (name xapi-stdext-encodings) + (synopsis "Xapi's standard library extension, Encodings") + (authors "Jonathan Ludlam") + (depends + (ocaml + (>= 4.13.0)) + (alcotest + (and + (>= 0.6.0) + :with-test)) + (odoc :with-doc) + (bechamel :with-test) + (bechamel-notty :with-test) + (notty :with-test))) + +(package + (name xapi-stdext-pervasives) + (synopsis "Xapi's standard library extension, Pervasives") + (authors "Jonathan Ludlam") + (depends + (ocaml + (>= 4.08)) + logs + (odoc :with-doc) + xapi-backtrace)) + +(package + (name xapi-stdext-std) + (synopsis "Xapi's standard library extension, Stdlib") + (depends + (ocaml + (>= 4.08.0)) + (alcotest :with-test) + (odoc :with-doc))) + +(package + (name xapi-stdext-threads) + (synopsis "Xapi's standard library extension, Threads") + (authors "Jonathan Ludlam") + (depends + ambient-context + base-threads + base-unix + (alcotest :with-test) + (clock + (= :version)) + (fmt :with-test) + mtime + tgroup + (xapi-log + (= :version)) + (xapi-stdext-pervasives + (= :version)) + (xapi-stdext-unix + (= :version)))) + +(package + (name xapi-stdext-unix) + (synopsis "Xapi's standard library extension, Unix") + (authors "Jonathan Ludlam") + (depends + (ocaml + (>= 4.12.0)) + (alcotest :with-test) + astring + base-unix + (bisect_ppx :with-test) + (clock + (and + (= :version) + :with-test)) + (fd-send-recv + (>= 2.0.0)) + fmt + integers + (mtime + (and + (>= 2.0.0) + :with-test)) + (logs :with-test) + (qcheck-core + (and + (>= 0.21.2) + :with-test)) + (odoc :with-doc) + xapi-backtrace + unix-errno + (xapi-stdext-pervasives + (= :version)) + polly)) + +(package + (name xapi-stdext-zerocheck) + (synopsis "Xapi's standard library extension, Zerocheck") + (authors "Jonathan Ludlam") + (depends + (alcotest :with-test) + (odoc :with-doc))) diff --git a/ocaml/database/block_device_io.mli b/ocaml/database/block_device_io.mli new file mode 100644 index 0000000000..cabf42bbb8 --- /dev/null +++ b/ocaml/database/block_device_io.mli @@ -0,0 +1 @@ +(* this file is empty on purpose: this is an executable file *) diff --git a/ocaml/database/block_device_io_errors.mli b/ocaml/database/block_device_io_errors.mli new file mode 100644 index 0000000000..260c8b701e --- /dev/null +++ b/ocaml/database/block_device_io_errors.mli @@ -0,0 +1,19 @@ +(* + * 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. + *) + +val timeout_error_msg : string + +val not_enough_space_error_msg : string + +val not_initialised_error_msg : string diff --git a/ocaml/database/database_server_main.ml b/ocaml/database/database_server_main.ml index e75539a559..a4ebb21ab4 100644 --- a/ocaml/database/database_server_main.ml +++ b/ocaml/database/database_server_main.ml @@ -33,8 +33,9 @@ let remote_database_access_handler_v2 req bio = flush stdout ; raise e +open Xapi_database module Local_tests = - Xapi_database.Database_test.Tests (Xapi_database.Db_cache_impl) + Database_test.Tests (Db_interface_compat.OfCached (Db_cache_impl)) let schema = Test_schemas.schema diff --git a/ocaml/database/database_server_main.mli b/ocaml/database/database_server_main.mli new file mode 100644 index 0000000000..cabf42bbb8 --- /dev/null +++ b/ocaml/database/database_server_main.mli @@ -0,0 +1 @@ +(* this file is empty on purpose: this is an executable file *) diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index dc176488f3..2bc6ec398e 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -205,11 +205,13 @@ functor let db = db |> add_row "bar" "bar:1" - (Row.add 0L Db_names.ref (String "bar:1") + (Row.add 0L Db_names.ref + (Schema.Value.string "bar:1") (Row.add 0L "foos" (Set []) Row.empty) ) |> add_row "foo" "foo:1" - (Row.add 0L Db_names.ref (String "foo:1") + (Row.add 0L Db_names.ref + (Schema.Value.string "foo:1") (Row.add 0L "bars" (Set []) Row.empty) ) |> set_field "foo" "foo:1" "bars" (add_to_set "bar:1" (Set [])) @@ -219,7 +221,7 @@ functor Table.find "bar:1" (TableSet.find "bar" (Database.tableset db)) in let bar_foos = Row.find "foos" bar_1 in - if bar_foos <> Set ["foo:1"] then + if bar_foos <> Schema.Value.set ["foo:1"] then failwith_fmt "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s" (Schema.Value.marshal bar_foos) ; @@ -235,13 +237,13 @@ functor failwith_fmt "check_many_to_many: bar(bar:1).foos expected () got %s" (Schema.Value.marshal bar_foos) ; (* add 'bar' to foo.bars *) - let db = set_field "foo" "foo:1" "bars" (Set ["bar:1"]) db in + let db = set_field "foo" "foo:1" "bars" (Schema.Value.set ["bar:1"]) db in (* check that 'bar.foos' includes 'foo' *) let bar_1 = Table.find "bar:1" (TableSet.find "bar" (Database.tableset db)) in let bar_foos = Row.find "foos" bar_1 in - if bar_foos <> Set ["foo:1"] then + if bar_foos <> Schema.Value.set ["foo:1"] then failwith_fmt "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2" (Schema.Value.marshal bar_foos) ; @@ -269,9 +271,9 @@ functor let row = Db_cache_types.Table.find r table in let s = Db_cache_types.Row.fold_over_recent g - (fun k _ v acc -> + (fun k _ cached acc -> Printf.sprintf "%s %s=%s" acc k - (Schema.Value.marshal v) + (Schema.CachedValue.string_of cached) ) row "" in @@ -461,6 +463,7 @@ functor (* reference which we create *) let valid_ref = "ref1" in let valid_uuid = "uuid1" in + let new_uuid = "uuid2" in let invalid_ref = "foo" in let invalid_uuid = "bar" in let t = @@ -624,6 +627,32 @@ functor "read_field_where " ; test_invalid_where_record "read_field_where" (Client.read_field_where t) ; + + (* before changing the UUID, the new UUID should be missing *) + expect_missing_uuid "VM" new_uuid (fun () -> + let (_ : string) = Client.db_get_by_uuid t "VM" new_uuid in + () + ) ; + (* change UUID, can happen during VM import *) + Client.write_field t "VM" valid_ref Db_names.uuid new_uuid ; + let old_uuid = valid_uuid in + (* new UUID should be found *) + let r = Client.db_get_by_uuid t "VM" new_uuid in + if r <> valid_ref then + failwith_fmt "db_get_by_uuid : got %s; expected %s" r + valid_ref ; + let r = Client.db_get_by_uuid_opt t "VM" new_uuid in + ( if r <> Some valid_ref then + let rs = Option.value ~default:"None" r in + failwith_fmt "db_get_by_uuid_opt : got %s; expected %s" rs + valid_ref + ) ; + (* old UUID should not be found anymore *) + expect_missing_uuid "VM" old_uuid (fun () -> + let (_ : string) = Client.db_get_by_uuid t "VM" old_uuid in + () + ) ; + Printf.printf "write_field \n" ; expect_missing_tbl "Vm" (fun () -> let (_ : unit) = Client.write_field t "Vm" "" "" "" in @@ -840,5 +869,23 @@ functor ) in Printf.printf "bad sequence: %.2f calls/sec\n%!" malign_time - ) + ) ; + Client.delete_row t "VM" valid_ref ; + (* after deleting the row, both old and new uuid must be missing *) + expect_missing_uuid "VM" new_uuid (fun () -> + let (_ : string) = Client.db_get_by_uuid t "VM" new_uuid in + () + ) ; + expect_missing_uuid "VM" old_uuid (fun () -> + let (_ : string) = Client.db_get_by_uuid t "VM" old_uuid in + () + ) ; + let r = Client.db_get_by_uuid_opt t "VM" old_uuid in + if not (Option.is_none r) then + failwith_fmt "db_get_by_uuid_opt : got %s; expected None" + valid_ref ; + let r = Client.db_get_by_uuid_opt t "VM" new_uuid in + if not (Option.is_none r) then + failwith_fmt "db_get_by_uuid_opt : got %s; expected None" + valid_ref end diff --git a/ocaml/database/db_action_helper.ml b/ocaml/database/db_action_helper.ml index a553846e3d..87ff488493 100644 --- a/ocaml/database/db_action_helper.ml +++ b/ocaml/database/db_action_helper.ml @@ -20,16 +20,5 @@ let __callback : let events_register f = __callback := Some f -let events_unregister () = __callback := None - let events_notify ?snapshot ty op ref = match !__callback with None -> () | Some f -> f ?snapshot ty op ref - -(* -exception Db_set_or_map_parse_fail of string - -let parse_sexpr s : SExpr.t list = - match SExpr_TS.of_string s with - | SExpr.Node xs -> xs - | _ -> raise (Db_set_or_map_parse_fail s) -*) diff --git a/ocaml/database/db_action_helper.mli b/ocaml/database/db_action_helper.mli new file mode 100644 index 0000000000..81fb7eb480 --- /dev/null +++ b/ocaml/database/db_action_helper.mli @@ -0,0 +1,18 @@ +(* + * 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. + *) + +val events_register : + (?snapshot:Rpc.t -> string -> string -> string -> unit) -> unit + +val events_notify : ?snapshot:Rpc.t -> string -> string -> string -> unit diff --git a/ocaml/database/db_backend.ml b/ocaml/database/db_backend.ml index 92954540c3..b92b021dad 100644 --- a/ocaml/database/db_backend.ml +++ b/ocaml/database/db_backend.ml @@ -21,11 +21,11 @@ let db_FLUSH_TIMER = 2.0 (* --------------------- Util functions on db datastructures *) -let master_database = ref (Db_cache_types.Database.make Schema.empty) +let master_database = Atomic.make (Db_cache_types.Database.make Schema.empty) -let __test_set_master_database db = master_database := db +let __test_set_master_database db = Atomic.set master_database db -let make () = Db_ref.in_memory (ref master_database) +let make () = Db_ref.in_memory master_database (* !!! Right now this is called at cache population time. It would probably be preferable to call it on flush time instead, so we don't waste writes storing non-persistent field values on disk.. At the moment there's not much to worry about, since there are @@ -43,7 +43,10 @@ let blow_away_non_persistent_fields (schema : Schema.t) db = let col = Schema.Table.find name schema in let empty = col.Schema.Column.empty in let v', modified' = - if col.Schema.Column.persistent then (v, modified) else (empty, g) + if col.Schema.Column.persistent then + (Schema.CachedValue.value_of v, modified) + else + (empty, g) in ( Row.update modified' name empty (fun _ -> v') diff --git a/ocaml/database/db_cache.ml b/ocaml/database/db_cache.ml index eba091889e..c6ec25d613 100644 --- a/ocaml/database/db_cache.ml +++ b/ocaml/database/db_cache.ml @@ -19,30 +19,32 @@ module D = Debug.Make (struct let name = "db_cache" end) open D (** Masters will use this to modify the in-memory cache directly *) -module Local_db : DB_ACCESS = Db_cache_impl +module Local_db : DB_ACCESS2 = Db_cache_impl (** Slaves will use this to call the master by XMLRPC *) -module Remote_db : DB_ACCESS = Db_rpc_client_v1.Make (struct +module Remote_db : DB_ACCESS2 = +Db_interface_compat.OfCompat (Db_rpc_client_v1.Make (struct let initialise () = ignore (Master_connection.start_master_connection_watchdog ()) ; ignore (Master_connection.open_secure_connection ()) let rpc request = Master_connection.execute_remote_fn request -end) +end)) let get = function | Db_ref.In_memory _ -> - (module Local_db : DB_ACCESS) + (module Local_db : DB_ACCESS2) | Db_ref.Remote -> - (module Remote_db : DB_ACCESS) + (module Remote_db : DB_ACCESS2) let lifecycle_state_of ~obj fld = let open Datamodel in let {fld_states; _} = StringMap.find obj all_lifecycles in StringMap.find fld fld_states +module DB = Db_interface_compat.OfCached (Local_db) + let apply_delta_to_cache entry db_ref = - let module DB : DB_ACCESS = Local_db in match entry with | Redo_log.CreateRow (tblname, objref, kvs) -> debug "Redoing create_row %s (%s)" tblname objref ; diff --git a/ocaml/database/db_cache.mli b/ocaml/database/db_cache.mli new file mode 100644 index 0000000000..ed1de2cd9a --- /dev/null +++ b/ocaml/database/db_cache.mli @@ -0,0 +1,17 @@ +(* + * 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. + *) + +val get : Db_ref.t -> (module Db_interface.DB_ACCESS2) + +val apply_delta_to_cache : Redo_log.t -> Db_ref.t -> unit diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index 7bbf062bd0..56ab07cab4 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -19,6 +19,8 @@ functions have the suffix "_locked" to clearly identify them. 2. functions which only read must only call "get_database" once, to ensure they see a consistent snapshot. + With the exception of looking at the database schema, which is assumed to not change + concurrently. *) open Db_exn open Db_lock @@ -34,6 +36,10 @@ open Db_ref let fist_delay_read_records_where = ref false +type field_in = Schema.Value.t + +type field_out = Schema.maybe_cached_value + (* Only needed by the DB_ACCESS signature *) let initialise () = () @@ -47,14 +53,13 @@ let is_valid_ref t objref = let read_field_internal _ tblname fldname objref db = try - Row.find fldname + Row.find' fldname (Table.find objref (TableSet.find tblname (Database.tableset db))) with Not_found -> raise (DBCache_NotFound ("missing row", tblname, objref)) (* Read field from cache *) let read_field t tblname fldname objref = - Schema.Value.marshal - (read_field_internal t tblname fldname objref (get_database t)) + read_field_internal t tblname fldname objref (get_database t) (** Finds the longest XML-compatible UTF-8 prefix of the given string, by truncating the string at the first incompatible @@ -62,36 +67,49 @@ let read_field t tblname fldname objref = occurs. *) let ensure_utf8_xml string = let length = String.length string in - let prefix = - Xapi_stdext_encodings.Encodings.UTF8_XML.longest_valid_prefix string - in + let prefix = Xapi_stdext_encodings.Utf8.XML.longest_valid_prefix string in if length > String.length prefix then warn "string truncated to: '%s'." prefix ; prefix +let ensure_utf8_xml_and_share string = string |> ensure_utf8_xml |> Share.merge + (* Write field in cache *) let write_field_locked t tblname objref fldname newval = let current_val = get_field tblname objref fldname (get_database t) in if current_val <> newval then ( - ( match newval with - | Schema.Value.String s -> - if not (Xapi_stdext_encodings.Encodings.UTF8_XML.is_valid s) then - raise Invalid_value - | _ -> - () - ) ; update_database t (set_field tblname objref fldname newval) ; Database.notify (WriteField (tblname, objref, fldname, current_val, newval)) (get_database t) ) +(** Ensure a value is conforming to UTF-8 with XML restrictions *) +let is_valid v = + let valid = Xapi_stdext_encodings.Utf8.XML.is_valid in + let valid_pair (x, y) = valid x && valid y in + match v with + | Schema.Value.String s -> + valid s + | Schema.Value.Set ss -> + List.for_all valid ss + | Schema.Value.Pairs pairs -> + List.for_all valid_pair pairs + +let share_string = function + | Schema.Value.String s -> + Schema.Value.String (Share.merge s) + | v -> + (* we assume strings in the tree have been shared already *) + v + let write_field t tblname objref fldname newval = - let db = get_database t in - let schema = Schema.table tblname (Database.schema db) in - let column = Schema.Table.find fldname schema in - let newval = Schema.Value.unmarshal column.Schema.Column.ty newval in - with_lock (fun () -> write_field_locked t tblname objref fldname newval) + if not @@ is_valid newval then + raise Invalid_value + else + with_lock (fun () -> + write_field_locked t tblname objref fldname (share_string newval) + ) let touch_row t tblname objref = update_database t (touch tblname objref) ; @@ -103,7 +121,7 @@ let touch_row t tblname objref = and iterates through set-refs [returning (fieldname, ref list) list; where fieldname is the name of the Set Ref field in tbl; and ref list is the list of foreign keys from related table with remote-fieldname=objref] *) -let read_record_internal db tblname objref = +let read_record_internal conv db tblname objref = try let tbl = TableSet.find tblname (Database.tableset db) in let row = Table.find objref tbl in @@ -116,84 +134,80 @@ let read_record_internal db tblname objref = else None in - let map_fvlist v = Schema.Value.marshal v in (* Unfortunately the interface distinguishes between Set(Ref _) types and ordinary fields *) Row.fold - (fun k _ d (accum_fvlist, accum_setref) -> + (fun k _ cached (accum_fvlist, accum_setref) -> let accum_setref = - match map_setref_opt k d with + match map_setref_opt k (Schema.CachedValue.value_of cached) with | Some v -> (k, v) :: accum_setref | None -> accum_setref in - let accum_fvlist = (k, map_fvlist d) :: accum_fvlist in + let accum_fvlist = (k, conv cached) :: accum_fvlist in (accum_fvlist, accum_setref) ) row ([], []) with Not_found -> raise (DBCache_NotFound ("missing row", tblname, objref)) -let read_record t = read_record_internal (get_database t) +let read_record t = + read_record_internal Schema.CachedValue.open_present (get_database t) (* Delete row from tbl *) let delete_row_locked t tblname objref = try - W.debug "delete_row %s (%s)" tblname objref ; let tbl = TableSet.find tblname (Database.tableset (get_database t)) in let row = Table.find objref tbl in let db = get_database t in Database.notify (PreDelete (tblname, objref)) db ; update_database t (remove_row tblname objref) ; Database.notify - (Delete (tblname, objref, Row.fold (fun k _ v acc -> (k, v) :: acc) row []) + (Delete + ( tblname + , objref + , Row.fold + (fun k _ v acc -> (k, Schema.CachedValue.value_of v) :: acc) + row [] + ) ) (get_database t) with Not_found -> raise (DBCache_NotFound ("missing row", tblname, objref)) let delete_row t tblname objref = + W.debug "delete_row %s (%s)" tblname objref ; with_lock (fun () -> delete_row_locked t tblname objref) (* Create new row in tbl containing specified k-v pairs *) let create_row_locked t tblname kvs' new_objref = let db = get_database t in - let schema = Schema.table tblname (Database.schema db) in - let kvs' = - List.map - (fun (key, value) -> - let value = ensure_utf8_xml value in - let column = Schema.Table.find key schema in - (key, Schema.Value.unmarshal column.Schema.Column.ty value) - ) - kvs' - in - (* we add the reference to the row itself so callers can use read_field_where to - return the reference: awkward if it is just the key *) - let kvs' = (Db_names.ref, Schema.Value.String new_objref) :: kvs' in - let g = Manifest.generation (Database.manifest (get_database t)) in + let g = Manifest.generation (Database.manifest db) in let row = - List.fold_left (fun row (k, v) -> Row.add g k v row) Row.empty kvs' + List.fold_left (fun row (k, v) -> Row.add' g k v row) Row.empty kvs' in - let schema = Schema.table tblname (Database.schema (get_database t)) in + let schema = Schema.table tblname (Database.schema db) in (* fill in default values if kv pairs for these are not supplied already *) let row = Row.add_defaults g schema row in - W.debug "create_row %s (%s) [%s]" tblname new_objref - (String.concat "," (List.map (fun (k, _) -> Printf.sprintf "(%s,v)" k) kvs')) ; update_database t (add_row tblname new_objref row) ; Database.notify (Create - (tblname, new_objref, Row.fold (fun k _ v acc -> (k, v) :: acc) row []) + ( tblname + , new_objref + , Row.fold + (fun k _ v acc -> (k, Schema.CachedValue.value_of v) :: acc) + row [] + ) ) (get_database t) let fld_check t tblname objref (fldname, value) = let v = - Schema.Value.marshal + Schema.CachedValue.string_of (read_field_internal t tblname fldname objref (get_database t)) in - (v = value, fldname, v) + (v = Schema.CachedValue.string_of value, fldname, v) -let create_row t tblname kvs' new_objref = +let create_row' t tblname kvs' new_objref = with_lock (fun () -> if is_valid_ref t new_objref then let uniq_check_list = List.map (fld_check t tblname new_objref) kvs' in @@ -206,43 +220,74 @@ let create_row t tblname kvs' new_objref = | _ -> () else + (* we add the reference to the row itself so callers can use read_field_where to + return the reference: awkward if it is just the key *) + let kvs' = + (Db_names.ref, Schema.Value.string new_objref |> Schema.CachedValue.v) + :: kvs' + in + W.debug "create_row %s (%s) [%s]" tblname new_objref + (String.concat "," + (List.map (fun (k, _) -> Printf.sprintf "(%s,v)" k) kvs') + ) ; create_row_locked t tblname kvs' new_objref ) +let create_row t tblname kvs' new_objref = + let kvs' = + List.map + (fun (key, value) -> + let value = + match value with + | Schema.Value.String x -> + Schema.Value.String (ensure_utf8_xml_and_share x) + | Schema.Value.Pairs ps -> + Schema.Value.Pairs + (List.map + (fun (x, y) -> + (ensure_utf8_xml_and_share x, ensure_utf8_xml_and_share y) + ) + ps + ) + | Schema.Value.Set xs -> + Schema.Value.Set (List.map ensure_utf8_xml_and_share xs) + in + (key, Schema.CachedValue.v value) + ) + kvs' + in + create_row' t tblname kvs' new_objref + (* Do linear scan to find field values which match where clause *) -let read_field_where t rcd = +let read_field_where' conv t rcd = let db = get_database t in let tbl = TableSet.find rcd.table (Database.tableset db) in Table.fold (fun _ _ row acc -> - let field = Schema.Value.marshal (Row.find rcd.where_field row) in + let field = + Schema.CachedValue.string_of (Row.find' rcd.where_field row) + in if field = rcd.where_value then - Schema.Value.marshal (Row.find rcd.return row) :: acc + conv (Row.find' rcd.return row) :: acc else acc ) tbl [] +let read_field_where t rcd = read_field_where' Fun.id t rcd + let db_get_by_uuid t tbl uuid_val = - match - read_field_where t - { - table= tbl - ; return= Db_names.ref - ; where_field= Db_names.uuid - ; where_value= uuid_val - } - with - | [] -> - raise (Read_missing_uuid (tbl, "", uuid_val)) - | [r] -> + let db = get_database t in + match Database.lookup_uuid uuid_val db with + | Some (tbl', r) when String.equal tbl tbl' -> r | _ -> - raise (Too_many_values (tbl, "", uuid_val)) + (* we didn't find the UUID, or it belonged to another table *) + raise (Read_missing_uuid (tbl, "", uuid_val)) let db_get_by_uuid_opt t tbl uuid_val = match - read_field_where t + read_field_where' Schema.CachedValue.string_of t { table= tbl ; return= Db_names.ref @@ -257,7 +302,7 @@ let db_get_by_uuid_opt t tbl uuid_val = (** Return reference fields from tbl that matches specified name_label field *) let db_get_by_name_label t tbl label = - read_field_where t + read_field_where' Schema.CachedValue.string_of t { table= tbl ; return= Db_names.ref @@ -291,17 +336,17 @@ let find_refs_with_filter_internal db (tblname : Db_interface.table) let find_refs_with_filter t = find_refs_with_filter_internal (get_database t) -let read_records_where t tbl expr = +let read_records_where' conv t tbl expr = let db = get_database t in let reqd_refs = find_refs_with_filter_internal db tbl expr in if !fist_delay_read_records_where then Thread.delay 0.5 ; - List.map (fun ref -> (ref, read_record_internal db tbl ref)) reqd_refs + List.map (fun ref -> (ref, read_record_internal conv db tbl ref)) reqd_refs + +let read_records_where t tbl expr = + read_records_where' Schema.CachedValue.open_present t tbl expr let process_structured_field_locked t (key, value) tblname fld objref proc_fn_selector = - (* Ensure that both keys and values are valid for UTF-8-encoded XML. *) - let key = ensure_utf8_xml key in - let value = ensure_utf8_xml value in try let tbl = TableSet.find tblname (Database.tableset (get_database t)) in let row = Table.find objref tbl in @@ -338,6 +383,9 @@ let process_structured_field_locked t (key, value) tblname fld objref let process_structured_field t (key, value) tblname fld objref proc_fn_selector = + (* Ensure that both keys and values are valid for UTF-8-encoded XML. *) + let key = ensure_utf8_xml_and_share key in + let value = ensure_utf8_xml_and_share value in with_lock (fun () -> process_structured_field_locked t (key, value) tblname fld objref proc_fn_selector @@ -426,24 +474,24 @@ let spawn_db_flush_threads () = try Thread.delay Db_backend.db_FLUSH_TIMER ; (* If I have some writing capacity left in this write period then consider doing a write; or - if the connection is not write-limited then consider doing a write too. - We also have to consider doing a write if exit_on_next_flush is set: because when this is - set (by a signal handler) we want to do a flush whether or not our write limit has been - exceeded. + if the connection is not write-limited then consider doing a write too. + We also have to consider doing a write if exit_on_next_flush is set: because when this is + set (by a signal handler) we want to do a flush whether or not our write limit has been + exceeded. *) + (* always flush straight away; this request is urgent + otherwise, we only write if + (i) "coalesscing period has come to an end"; and + (ii) "write limiting requirements are met": *) ( if !Db_connections.exit_on_next_flush - (* always flush straight away; this request is urgent *) - || (* otherwise, we only write if (i) "coalesscing period has come to an end"; and (ii) "write limiting requirements are met": *) - (not (in_coallescing_period ())) - (* see (i) above *) - && (!my_writes_this_period - < dbconn.Parse_db_conf.write_limit_write_cycles - || dbconn.Parse_db_conf.mode - = Parse_db_conf.No_limit - (* (ii) above *) - ) - then (* debug "[%s] considering flush" db_path; *) + || (not (in_coallescing_period ())) + && (!my_writes_this_period + < dbconn.Parse_db_conf.write_limit_write_cycles + || dbconn.Parse_db_conf.mode + = Parse_db_conf.No_limit + ) + then let was_anything_flushed = Xapi_stdext_threads.Threadext.Mutex.execute Db_lock.global_flush_mutex (fun () -> @@ -453,7 +501,7 @@ let spawn_db_flush_threads () = if was_anything_flushed then ( my_writes_this_period := !my_writes_this_period + 1 ; (* when we do a write, reset the coallesce_period_start to now -- recall that this - variable tracks the time since last write *) + variable tracks the time since last write *) coallesce_period_start := Unix.gettimeofday () ) ) ; @@ -497,3 +545,41 @@ let stats t = ) (Database.tableset (get_database t)) [] + +module Compat = struct + type field_in = string + + type field_out = string + + let read_field_where t rcd = + read_field_where' Schema.CachedValue.string_of t rcd + + let read_field t tblname fldname objref = + read_field t tblname fldname objref |> Schema.CachedValue.string_of + + let write_field t tblname objref fldname newval = + let db = get_database t in + let schema = Schema.table tblname (Database.schema db) in + let column = Schema.Table.find fldname schema in + let newval = Schema.Value.unmarshal column.Schema.Column.ty newval in + write_field t tblname objref fldname newval + + let read_record t = + read_record_internal Schema.CachedValue.string_of (get_database t) + + let read_records_where t tbl expr = + read_records_where' Schema.CachedValue.string_of t tbl expr + + let create_row t tblname kvs' new_objref = + let db = get_database t in + let schema = Schema.table tblname (Database.schema db) in + let kvs' = + List.map + (fun (key, value) -> + let column = Schema.Table.find key schema in + (key, Schema.CachedValue.of_typed_string column.Schema.Column.ty value) + ) + kvs' + in + create_row' t tblname kvs' new_objref +end diff --git a/ocaml/database/db_cache_impl.mli b/ocaml/database/db_cache_impl.mli index b9b26cfc0e..8dd161b0f8 100644 --- a/ocaml/database/db_cache_impl.mli +++ b/ocaml/database/db_cache_impl.mli @@ -1,4 +1,4 @@ -include Db_interface.DB_ACCESS +include Db_interface.DB_ACCESS2 val make : Db_ref.t -> Parse_db_conf.db_connection list -> Schema.t -> unit (** [make t connections default_schema] initialises the in-memory cache *) diff --git a/ocaml/database/db_cache_test.ml b/ocaml/database/db_cache_test.ml index ed2a329694..aa472419bf 100644 --- a/ocaml/database/db_cache_test.ml +++ b/ocaml/database/db_cache_test.ml @@ -29,11 +29,13 @@ let check_many_to_many () = let db = db |> add_row "bar" "bar:1" - (Row.add 0L Db_names.ref (Schema.Value.String "bar:1") + (Row.add 0L Db_names.ref + (Schema.Value.string "bar:1") (Row.add 0L "foos" (Schema.Value.Set []) Row.empty) ) |> add_row "foo" "foo:1" - (Row.add 0L Db_names.ref (Schema.Value.String "foo:1") + (Row.add 0L Db_names.ref + (Schema.Value.string "foo:1") (Row.add 0L "bars" (Schema.Value.Set []) Row.empty) ) |> set_field "foo" "foo:1" "bars" (add_to_set "bar:1" (Schema.Value.Set [])) @@ -41,7 +43,7 @@ let check_many_to_many () = (* check that 'bar.foos' includes 'foo' *) let bar_1 = Table.find "bar:1" (TableSet.find "bar" (Database.tableset db)) in let bar_foos = Row.find "foos" bar_1 in - if bar_foos <> Schema.Value.Set ["foo:1"] then + if bar_foos <> Schema.Value.set ["foo:1"] then failwith (Printf.sprintf "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s" @@ -59,11 +61,11 @@ let check_many_to_many () = (Sexplib.Sexp.to_string (Schema.Value.sexp_of_t bar_foos)) ) ; (* add 'bar' to foo.bars *) - let db = set_field "foo" "foo:1" "bars" (Schema.Value.Set ["bar:1"]) db in + let db = set_field "foo" "foo:1" "bars" (Schema.Value.set ["bar:1"]) db in (* check that 'bar.foos' includes 'foo' *) let bar_1 = Table.find "bar:1" (TableSet.find "bar" (Database.tableset db)) in let bar_foos = Row.find "foos" bar_1 in - if bar_foos <> Schema.Value.Set ["foo:1"] then + if bar_foos <> Schema.Value.set ["foo:1"] then failwith (Printf.sprintf "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2" diff --git a/ocaml/database/db_cache_test.mli b/ocaml/database/db_cache_test.mli new file mode 100644 index 0000000000..cabf42bbb8 --- /dev/null +++ b/ocaml/database/db_cache_test.mli @@ -0,0 +1 @@ +(* this file is empty on purpose: this is an executable file *) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index be73b91958..f266fd8b51 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -24,11 +24,33 @@ module HashedString = struct let hash = Hashtbl.hash end -module StringPool = Weak.Make (HashedString) - -let share = - let pool = StringPool.create 2048 in - StringPool.merge pool +module Share : sig + val merge : string -> string + (** [merge str] merges [str] into the stringpool. + It returns a string equal to [str]. + + This function is thread-safe, it skips adding the string to the pool + when called concurrently. + For best results call this while holding another lock. + *) +end = struct + module StringPool = Weak.Make (HashedString) + + let pool = StringPool.create 2048 + + let merge_running = Atomic.make 0 + + let merge str = + let str = + if Atomic.fetch_and_add merge_running 1 = 0 then + StringPool.merge pool str + else + (* no point in using a mutex here, just fall back to not sharing, + which is quicker. *) + str + in + Atomic.decr merge_running ; str +end module Stat = struct type t = {created: Time.t; modified: Time.t; deleted: Time.t} @@ -45,7 +67,7 @@ module StringMap = struct let compare = String.compare end) - let add key v t = add (share key) v t + let add key v t = add (Share.merge key) v t end module type VAL = sig @@ -136,27 +158,37 @@ functor end module Row = struct - include Make (Schema.Value) - - let add gen key v = - add gen key - @@ - match v with - | Schema.Value.String x -> - Schema.Value.String (share x) - | Schema.Value.Pairs ps -> - Schema.Value.Pairs (List.map (fun (x, y) -> (share x, share y)) ps) - | Schema.Value.Set xs -> - Schema.Value.Set (List.map share xs) + module CachedValue = struct + type t = Schema.cached_value + + let v = Schema.CachedValue.v + end + + include Make (CachedValue) + + let add' = add + + let add gen key v = add' gen key @@ CachedValue.v v type t = map_t type value = Schema.Value.t - let find key t = - try find key t + let iter f t = iter (fun k v -> f k (Schema.CachedValue.value_of v)) t + + let touch generation key default row = + touch generation key (CachedValue.v default) row + + let update gen key default f row = + let f v = v |> Schema.CachedValue.value_of |> f |> CachedValue.v in + update gen key (CachedValue.v default) f row + + let find' key t = + try find key t |> Schema.CachedValue.open_present with Not_found -> raise (DBCache_NotFound ("missing field", key, "")) + let find key t = find' key t |> Schema.CachedValue.value_of + let add_defaults g (schema : Schema.Table.t) t = let schema = Schema.Table.t'_of_t schema in List.fold_left @@ -476,6 +508,8 @@ module Database = struct let lookup_key key db = KeyMap.find_opt (Ref key) db.keymap + let lookup_uuid key db = KeyMap.find_opt (Uuid key) db.keymap + let make schema = { tables= TableSet.empty @@ -518,9 +552,11 @@ let get_field tblname objref fldname db = (Table.find objref (TableSet.find tblname (Database.tableset db))) with Not_found -> raise (DBCache_NotFound ("missing row", tblname, objref)) +let empty = Schema.Value.string "" + let unsafe_set_field g tblname objref fldname newval = (fun _ -> newval) - |> Row.update g fldname (Schema.Value.String "") + |> Row.update g fldname empty |> Table.update g objref Row.empty |> TableSet.update g tblname Table.empty |> Database.update @@ -581,6 +617,33 @@ let update_many_to_many g tblname objref f db = db (Schema.many_to_many tblname (Database.schema db)) +let uuid_of ~tblname ~objref db = + try + Some + (Schema.Value.Unsafe_cast.string + (Row.find Db_names.uuid + (Table.find objref (TableSet.find tblname (Database.tableset db))) + ) + ) + with _ -> None + +let maybe_update_uuid_keymap ~tblname ~objref ~fldname ~newval db = + if fldname = Db_names.uuid then + db + |> Database.update_keymap @@ fun keymap -> + let keymap = + match uuid_of ~tblname ~objref db with + | None -> + keymap + | Some uuid -> + KeyMap.remove (Uuid uuid) keymap + in + KeyMap.add_unique tblname Db_names.uuid + (Uuid (Schema.Value.Unsafe_cast.string newval)) + (tblname, objref) keymap + else + db + let set_field tblname objref fldname newval db = if fldname = Db_names.ref then failwith (Printf.sprintf "Cannot safely update field: %s" fldname) ; @@ -598,11 +661,12 @@ let set_field tblname objref fldname newval db = if need_other_table_update then let g = Manifest.generation (Database.manifest db) in db + |> maybe_update_uuid_keymap ~tblname ~objref ~fldname ~newval |> update_many_to_many g tblname objref remove_from_set |> update_one_to_many g tblname objref remove_from_set |> Database.update ((fun _ -> newval) - |> Row.update g fldname (Schema.Value.String "") + |> Row.update g fldname empty |> Table.update g objref Row.empty |> TableSet.update g tblname Table.empty ) @@ -612,8 +676,9 @@ let set_field tblname objref fldname newval db = else let g = Manifest.generation (Database.manifest db) in db + |> maybe_update_uuid_keymap ~tblname ~objref ~fldname ~newval |> ((fun _ -> newval) - |> Row.update g fldname (Schema.Value.String "") + |> Row.update g fldname empty |> Table.update g objref Row.empty |> TableSet.update g tblname Table.empty |> Database.update @@ -662,16 +727,7 @@ let add_row tblname objref newval db = |> Database.increment let remove_row tblname objref db = - let uuid = - try - Some - (Schema.Value.Unsafe_cast.string - (Row.find Db_names.uuid - (Table.find objref (TableSet.find tblname (Database.tableset db))) - ) - ) - with _ -> None - in + let uuid = uuid_of ~tblname ~objref db in let g = db.Database.manifest.Manifest.generation_count in db |> Database.update_keymap (fun m -> diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 2ffe79c411..0e96c753d0 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -79,9 +79,39 @@ module type MAP = sig On exit there will be a binding of [key] whose modification time is [now] *) end +module Share : sig + val merge : string -> string + (** [merge str] merges [str] into the stringpool. + It returns a string equal to [str]. + + This function is thread-safe, it skips adding the string to the pool + when called concurrently. + For best results call this while holding another lock. + *) +end + module Row : sig include MAP with type value = Schema.Value.t + val add' : Time.t -> string -> Schema.cached_value -> t -> t + (** [add now key value map] returns a new map with [key] associated with [value], + with creation time [now] *) + + val find' : string -> t -> [> Schema.present] Schema.CachedValue.t + (** [find key t] returns the value associated with [key] in [t] or raises + [DBCache_NotFound] *) + + val fold : + (string -> Stat.t -> Schema.cached_value -> 'b -> 'b) -> t -> 'b -> 'b + (** [fold f t initial] folds [f key stats value acc] over the items in [t] *) + + val fold_over_recent : + Time.t + -> (string -> Stat.t -> Schema.cached_value -> 'b -> 'b) + -> t + -> 'b + -> 'b + val add_defaults : Time.t -> Schema.Table.t -> t -> t (** [add_defaults now schema t]: returns a row which is [t] extended to contain all the columns specified in the schema, with default values set if not already @@ -165,6 +195,8 @@ module Database : sig val lookup_key : string -> t -> (string * string) option + val lookup_uuid : string -> t -> (string * string) option + val reindex : t -> t val register_callback : string -> (update -> t -> unit) -> t -> t diff --git a/ocaml/database/db_connections.ml b/ocaml/database/db_connections.ml index 9b390967fc..18152a18c4 100644 --- a/ocaml/database/db_connections.ml +++ b/ocaml/database/db_connections.ml @@ -62,22 +62,12 @@ let preferred_write_db () = List.hd (Db_conn_store.read_db_connections ()) let exit_on_next_flush = ref false (* db flushing thread refcount: the last thread out of the door does the exit(0) when flush_on_exit is true *) -let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute +let db_flush_thread_refcount = Atomic.make 0 -let db_flush_thread_refcount_m = Mutex.create () - -let db_flush_thread_refcount = ref 0 - -let inc_db_flush_thread_refcount () = - with_lock db_flush_thread_refcount_m (fun () -> - db_flush_thread_refcount := !db_flush_thread_refcount + 1 - ) +let inc_db_flush_thread_refcount () = Atomic.incr db_flush_thread_refcount let dec_and_read_db_flush_thread_refcount () = - with_lock db_flush_thread_refcount_m (fun () -> - db_flush_thread_refcount := !db_flush_thread_refcount - 1 ; - !db_flush_thread_refcount - ) + Atomic.fetch_and_add db_flush_thread_refcount (-1) let pre_exit_hook () = (* We're about to exit. Close the active redo logs. *) diff --git a/ocaml/database/db_connections.mli b/ocaml/database/db_connections.mli new file mode 100644 index 0000000000..81ec405a58 --- /dev/null +++ b/ocaml/database/db_connections.mli @@ -0,0 +1,29 @@ +(* + * 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. + *) + +val get_dbs_and_gen_counts : unit -> (int64 * Parse_db_conf.db_connection) list + +val choose : + Parse_db_conf.db_connection list -> Parse_db_conf.db_connection option + +val preferred_write_db : unit -> Parse_db_conf.db_connection + +val exit_on_next_flush : bool ref + +val inc_db_flush_thread_refcount : unit -> unit + +val flush_dirty_and_maybe_exit : + Parse_db_conf.db_connection -> int option -> bool + +val flush : Parse_db_conf.db_connection -> Db_cache_types.Database.t -> unit diff --git a/ocaml/database/db_exn.mli b/ocaml/database/db_exn.mli new file mode 100644 index 0000000000..53b686e1f4 --- /dev/null +++ b/ocaml/database/db_exn.mli @@ -0,0 +1,39 @@ +(* + * 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. + *) + +(** class * field * uuid * key *) +exception Duplicate_key of string * string * string * string + +(** message * class * key *) +exception DBCache_NotFound of string * string * string + +(** class * field * key *) +exception Uniqueness_constraint_violation of string * string * string + +(** class * field * value *) +exception Integrity_violation of string * string * string + +(** class * _ * uuid *) +exception Read_missing_uuid of string * string * string + +(** class * _ * uuid *) +exception Too_many_values of string * string * string + +exception Remote_db_server_returned_unknown_exception + +exception Remote_db_server_returned_bad_message + +exception Empty_key_in_map + +exception Invalid_value diff --git a/ocaml/database/db_filter.ml b/ocaml/database/db_filter.ml index 25a171c838..915162ae8d 100644 --- a/ocaml/database/db_filter.ml +++ b/ocaml/database/db_filter.ml @@ -18,33 +18,6 @@ open Db_filter_types -let string_of_val = function - | Field x -> - "Field " ^ x - | Literal x -> - "Literal " ^ x - -let rec string_of_expr = - let binexpr name a b = - Printf.sprintf "%s (%s, %s)" name (string_of_expr a) (string_of_expr b) - in - let binval name a b = - Printf.sprintf "%s (%s, %s)" name (string_of_val a) (string_of_val b) - in - function - | True -> - "True" - | False -> - "False" - | Not x -> - Printf.sprintf "Not ( %s )" (string_of_expr x) - | And (a, b) -> - binexpr "And" a b - | Or (a, b) -> - binexpr "Or" a b - | Eq (a, b) -> - binval "Eq" a b - exception XML_unmarshall_error let val_of_xml xml = diff --git a/ocaml/database/db_filter.mli b/ocaml/database/db_filter.mli new file mode 100644 index 0000000000..392974c470 --- /dev/null +++ b/ocaml/database/db_filter.mli @@ -0,0 +1,25 @@ +(* + * 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. + *) + +exception XML_unmarshall_error + +exception Expression_error of (string * exn) + +val expr_of_xml : XMLRPC.xmlrpc -> Db_filter_types.expr + +val expr_of_string : string -> Db_filter_types.expr + +val xml_of_expr : Db_filter_types.expr -> XMLRPC.xmlrpc + +val eval_expr : (Db_filter_types._val -> string) -> Db_filter_types.expr -> bool diff --git a/ocaml/database/db_filter_lex.mli b/ocaml/database/db_filter_lex.mli new file mode 100644 index 0000000000..6383496508 --- /dev/null +++ b/ocaml/database/db_filter_lex.mli @@ -0,0 +1,15 @@ +(* + * 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. + *) + +val lexer : Lexing.lexbuf -> Db_filter_parse.token diff --git a/ocaml/database/db_filter_types.mli b/ocaml/database/db_filter_types.mli new file mode 100644 index 0000000000..1584d7b349 --- /dev/null +++ b/ocaml/database/db_filter_types.mli @@ -0,0 +1,31 @@ +(* + * 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. + *) + +type _val = Field of string | Literal of string + +val rpc_of__val : _val -> Rpc.t + +val _val_of_rpc : Rpc.t -> _val + +type expr = + | True + | False + | Not of expr + | Eq of _val * _val + | And of expr * expr + | Or of expr * expr + +val rpc_of_expr : expr -> Rpc.t + +val expr_of_rpc : Rpc.t -> expr diff --git a/ocaml/database/db_globs.mli b/ocaml/database/db_globs.mli new file mode 100644 index 0000000000..d51d569907 --- /dev/null +++ b/ocaml/database/db_globs.mli @@ -0,0 +1,67 @@ +(* + * 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. + *) + +val redo_log_block_device_io : string ref + +val redo_log_connect_delay : float ref + +val redo_log_max_block_time_empty : float ref + +val redo_log_max_block_time_read : float ref + +val redo_log_max_block_time_writedelta : float ref + +val redo_log_max_block_time_writedb : float ref + +val redo_log_initial_backoff_delay : int + +val redo_log_exponentiation_base : int + +val redo_log_maximum_backoff_delay : int + +val redo_log_max_dying_processes : int + +val redo_log_comms_socket_stem : string + +val redo_log_max_startup_time : float ref + +val redo_log_length_of_half : int + +val ha_metadata_db : string + +val gen_metadata_db : string + +val static_vdis_dir : string ref + +val http_limit_max_rpc_size : int + +val idempotent_map : bool ref + +val permanent_master_failure_retry_interval : float ref + +val master_connection_reset_timeout : float ref + +val master_connection_retry_timeout : float ref + +val master_connection_default_timeout : float ref + +val pool_secret : Db_secret_string.t ref + +val restart_fn : (unit -> unit) ref + +val https_port : int ref + +val snapshot_db : string + +val db_conf_path : string ref diff --git a/ocaml/database/db_interface.ml b/ocaml/database/db_interface.mli similarity index 78% rename from ocaml/database/db_interface.ml rename to ocaml/database/db_interface.mli index 9343ed87e8..af1d457290 100644 --- a/ocaml/database/db_interface.ml +++ b/ocaml/database/db_interface.mli @@ -33,15 +33,15 @@ type db_ref = string type uuid = string -type regular_fields = (field_name * field) list +type 'field regular_fields = (field_name * 'field) list type associated_fields = (field_name * db_ref list) list (** dictionary of regular fields x dictionary of associated set_ref values *) -type db_record = regular_fields * associated_fields +type 'field db_record = 'field regular_fields * associated_fields (** The client interface to the database *) -module type DB_ACCESS = sig +module type DB_ACCESS_COMMON = sig val initialise : unit -> unit (** [initialise ()] must be called before any other function in this interface *) @@ -61,11 +61,6 @@ module type DB_ACCESS = sig (** [find_refs_with_filter tbl expr] returns a list of all references to rows which match [expr] *) - val read_field_where : Db_ref.t -> Db_cache_types.where_record -> field list - (** [read_field_where {tbl,return,where_field,where_value}] returns a - list of the [return] fields in table [tbl] where the [where_field] - equals [where_value] *) - val db_get_by_uuid : Db_ref.t -> table -> uuid -> db_ref (** [db_get_by_uuid tbl uuid] returns the single object reference associated with [uuid] *) @@ -79,40 +74,76 @@ module type DB_ACCESS = sig (** [db_get_by_name_label tbl label] returns the list of object references associated with [label] *) - val create_row : Db_ref.t -> table -> regular_fields -> db_ref -> unit - (** [create_row tbl kvpairs ref] create a new row in [tbl] with - key [ref] and contents [kvpairs] *) - val delete_row : Db_ref.t -> db_ref -> table -> unit (** [delete_row context tbl ref] deletes row [ref] from table [tbl] *) - val write_field : Db_ref.t -> table -> db_ref -> field_name -> field -> unit + val process_structured_field : + Db_ref.t + -> field_name * string + -> table + -> field_name + -> db_ref + -> Db_cache_types.structured_op_t + -> unit + (** [process_structured_field context kv tbl fld ref op] modifies the + value of field [fld] in row [ref] in table [tbl] according to [op] + which may be one of AddSet RemoveSet AddMap RemoveMap with + arguments [kv] *) +end + +module type DB_ACCESS_FIELD = sig + type field_in + + type field_out + + val read_field_where : + Db_ref.t -> Db_cache_types.where_record -> field_out list + (** [read_field_where {tbl,return,where_field,where_value}] returns a + list of the [return] fields in table [tbl] where the [where_field] + equals [where_value] *) + + val create_row : + Db_ref.t -> table -> field_in regular_fields -> db_ref -> unit + (** [create_row tbl kvpairs ref] create a new row in [tbl] with + key [ref] and contents [kvpairs] *) + + val write_field : + Db_ref.t -> table -> db_ref -> field_name -> field_in -> unit (** [write_field context tbl ref fld val] changes field [fld] to [val] in row [ref] in table [tbl] *) - val read_field : Db_ref.t -> table -> field_name -> db_ref -> field + val read_field : Db_ref.t -> table -> field_name -> db_ref -> field_out (** [read_field context tbl fld ref] returns the value of field [fld] in row [ref] in table [tbl] *) - val read_record : Db_ref.t -> table -> db_ref -> db_record + val read_record : Db_ref.t -> table -> db_ref -> field_out db_record (** [read_record tbl ref] returns [ (field, value) ] * [ (set_ref fieldname * [ ref ]) ] *) val read_records_where : - Db_ref.t -> table -> Db_filter_types.expr -> (db_ref * db_record) list + Db_ref.t + -> table + -> Db_filter_types.expr + -> (db_ref * field_out db_record) list (** [read_records_where tbl expr] returns a list of the values returned by read_record that match the expression *) +end - val process_structured_field : - Db_ref.t - -> field_name * field - -> table - -> field_name - -> db_ref - -> Db_cache_types.structured_op_t - -> unit - (** [process_structured_field context kv tbl fld ref op] modifies the - value of field [fld] in row [ref] in table [tbl] according to [op] - which may be one of AddSet RemoveSet AddMap RemoveMap with - arguments [kv] *) +module type DB_ACCESS = sig + include DB_ACCESS_COMMON + + include + DB_ACCESS_FIELD with type field_in = string and type field_out = string +end + +module type DB_ACCESS2 = sig + include DB_ACCESS_COMMON + + include + DB_ACCESS_FIELD + with type field_in = Schema.Value.t + and type field_out = Schema.maybe_cached_value + + module Compat : + DB_ACCESS_FIELD with type field_in = string and type field_out = string end diff --git a/ocaml/database/db_interface_compat.ml b/ocaml/database/db_interface_compat.ml new file mode 100644 index 0000000000..a1c981a9e7 --- /dev/null +++ b/ocaml/database/db_interface_compat.ml @@ -0,0 +1,61 @@ +(* + * 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 Db_interface + +module OfCached (DB : DB_ACCESS2) : DB_ACCESS = struct + include DB include DB.Compat +end + +module OfCompat (DB : DB_ACCESS) : DB_ACCESS2 = struct + module Compat = DB + include Compat + + type field_in = Schema.Value.t + + type field_out = Schema.maybe_cached_value + + let field_of_compat = Schema.CachedValue.of_string + + let compat_of_field = Schema.Value.marshal + + let regular_field_of_compat (k, v) = (k, field_of_compat v) + + let regular_fields_of_compat l = List.map regular_field_of_compat l + + let compat_of_regular_field (k, v) = (k, compat_of_field v) + + let compat_of_regular_fields l = List.map compat_of_regular_field l + + let db_record_of_compat (regular, assoc) = + (regular_fields_of_compat regular, assoc) + + let db_record_entry_of_compat (ref, record) = (ref, db_record_of_compat record) + + let read_field_where t where = + read_field_where t where |> List.map field_of_compat + + let create_row t tbl fields ref = + create_row t tbl (compat_of_regular_fields fields) ref + + let write_field t tbl ref fld field = + write_field t tbl ref fld (compat_of_field field) + + let read_field t tbl fld ref = read_field t tbl fld ref |> field_of_compat + + let read_record t tbl ref = read_record t tbl ref |> db_record_of_compat + + let read_records_where t tbl expr = + read_records_where t tbl expr |> List.map db_record_entry_of_compat +end diff --git a/ocaml/database/db_interface_compat.mli b/ocaml/database/db_interface_compat.mli new file mode 100644 index 0000000000..a735cf122d --- /dev/null +++ b/ocaml/database/db_interface_compat.mli @@ -0,0 +1,18 @@ +(* + * 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 Db_interface + +module OfCached : functor (_ : DB_ACCESS2) -> DB_ACCESS + +module OfCompat : functor (_ : DB_ACCESS) -> DB_ACCESS2 diff --git a/ocaml/database/db_lock.ml b/ocaml/database/db_lock.ml index e893050f58..648ca94dc2 100644 --- a/ocaml/database/db_lock.ml +++ b/ocaml/database/db_lock.ml @@ -59,9 +59,7 @@ module ReentrantLock : REENTRANT_LOCK = struct type t = { holder: tid option Atomic.t (* The holder of the lock *) ; mutable holds: int (* How many holds the holder has on the lock *) - ; lock: Mutex.t (* Barrier to signal waiting threads *) - ; condition: Condition.t - (* Waiting threads are signalled via this condition to reattempt to acquire the lock *) + ; lock: Mutex.t (* Mutex held by the holder thread *) ; statistics: statistics (* Bookkeeping of time taken to acquire lock *) } @@ -73,7 +71,6 @@ module ReentrantLock : REENTRANT_LOCK = struct holder= Atomic.make None ; holds= 0 ; lock= Mutex.create () - ; condition= Condition.create () ; statistics= create_statistics () } @@ -94,9 +91,7 @@ module ReentrantLock : REENTRANT_LOCK = struct let intended = Some me in let counter = Mtime_clock.counter () in Mutex.lock l.lock ; - while not (Atomic.compare_and_set l.holder None intended) do - Condition.wait l.condition l.lock - done ; + Atomic.set l.holder intended ; lock_acquired () ; let stats = l.statistics in let delta = Clock.Timer.span_to_s (Mtime_clock.count counter) in @@ -104,7 +99,7 @@ module ReentrantLock : REENTRANT_LOCK = struct stats.min_time <- Float.min delta stats.min_time ; stats.max_time <- Float.max delta stats.max_time ; stats.acquires <- stats.acquires + 1 ; - Mutex.unlock l.lock ; + (* do not unlock, it will be done when holds reaches 0 instead *) l.holds <- 1 let unlock l = @@ -114,10 +109,8 @@ module ReentrantLock : REENTRANT_LOCK = struct l.holds <- l.holds - 1 ; if l.holds = 0 then ( let () = Atomic.set l.holder None in - Mutex.lock l.lock ; - Condition.signal l.condition ; - Mutex.unlock l.lock ; - lock_released () + (* the lock is held (acquired in [lock]), we only need to unlock *) + Mutex.unlock l.lock ; lock_released () ) | _ -> failwith diff --git a/ocaml/database/db_names.mli b/ocaml/database/db_names.mli new file mode 100644 index 0000000000..b1bb79d751 --- /dev/null +++ b/ocaml/database/db_names.mli @@ -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. + *) + +val uuid : string + +val ref : string + +val suspend_VDI : string + +val vm : string + +val console : string + +val name_label : string + +val power_state : string + +val allowed_operations : string + +val current_operations : string + +val memory_dynamic_max : string + +val memory_dynamic_min : string + +val memory_static_max : string + +val memory_static_min : string + +val memory_target : string + +val is_a_template : string + +val is_default_template : string + +val is_a_snapshot : string + +val is_control_domain : string + +val platform : string + +val other_config : string + +val metrics : string + +val guest_metrics : string + +val parent : string + +val snapshot_of : string + +val snapshot_time : string + +val transportable_snapshot_id : string + +val resident_on : string + +val scheduled_to_be_resident_on : string + +val domid : string + +val ha_always_run : string + +val host : string + +val pool : string + +val master : string + +val bios_strings : string + +val protection_policy : string + +val snapshot_schedule : string diff --git a/ocaml/database/db_ref.ml b/ocaml/database/db_ref.ml index c1819e5aa2..100fea3701 100644 --- a/ocaml/database/db_ref.ml +++ b/ocaml/database/db_ref.ml @@ -12,15 +12,15 @@ * GNU Lesser General Public License for more details. *) -type t = In_memory of Db_cache_types.Database.t ref ref | Remote +type t = In_memory of Db_cache_types.Database.t Atomic.t | Remote exception Database_not_in_memory -let in_memory (rf : Db_cache_types.Database.t ref ref) = In_memory rf +let in_memory (rf : Db_cache_types.Database.t Atomic.t) = In_memory rf let get_database = function | In_memory x -> - !(!x) + Atomic.get x | Remote -> raise Database_not_in_memory @@ -28,6 +28,6 @@ let update_database t f = match t with | In_memory x -> let d : Db_cache_types.Database.t = f (get_database t) in - !x := d + Atomic.set x d | Remote -> raise Database_not_in_memory diff --git a/ocaml/database/db_ref.mli b/ocaml/database/db_ref.mli new file mode 100644 index 0000000000..93ab865586 --- /dev/null +++ b/ocaml/database/db_ref.mli @@ -0,0 +1,24 @@ +(* + * 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. + *) + +type t = In_memory of Db_cache_types.Database.t Atomic.t | Remote + +exception Database_not_in_memory + +val in_memory : Db_cache_types.Database.t Atomic.t -> t + +val get_database : t -> Db_cache_types.Database.t + +val update_database : + t -> (Db_cache_types.Database.t -> Db_cache_types.Database.t) -> unit diff --git a/ocaml/database/db_remote_cache_access_v1.ml b/ocaml/database/db_remote_cache_access_v1.ml index 1499fa3fc1..6cb7af729c 100644 --- a/ocaml/database/db_remote_cache_access_v1.ml +++ b/ocaml/database/db_remote_cache_access_v1.ml @@ -6,9 +6,7 @@ module DBCacheRemoteListener = struct exception DBCacheListenerUnknownMessageName of string - let ctr_mutex = Mutex.create () - - let calls_processed = ref 0 + let calls_processed = Atomic.make 0 let success xml = let resp = XMLRPC.To.array [XMLRPC.To.string "success"; xml] in @@ -28,14 +26,14 @@ module DBCacheRemoteListener = struct (* update_lengths xml resp; *) resp - module DBCache : Db_interface.DB_ACCESS = Db_cache_impl + module DBCache : Db_interface.DB_ACCESS = + Db_interface_compat.OfCached (Db_cache_impl) (** Unmarshals the request, calls the DBCache function and marshals the result. Note that, although the messages still contain the pool_secret for historical reasons, access has already been applied by the RBAC code in Xapi_http.add_handler. *) let process_xmlrpc xml = - let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute in - with_lock ctr_mutex (fun () -> calls_processed := !calls_processed + 1) ; + Atomic.incr calls_processed ; let fn_name, args = match XMLRPC.From.array (fun x -> x) xml with | [fn_name; _; args] -> diff --git a/ocaml/database/db_remote_cache_access_v2.ml b/ocaml/database/db_remote_cache_access_v2.ml index 754fd2fa34..51a1177cab 100644 --- a/ocaml/database/db_remote_cache_access_v2.ml +++ b/ocaml/database/db_remote_cache_access_v2.ml @@ -19,7 +19,8 @@ open Db_exn (** Convert a marshalled Request Rpc.t into a marshalled Response Rpc.t *) let process_rpc (req : Rpc.t) = - let module DB : Db_interface.DB_ACCESS = Db_cache_impl in + let module DB : Db_interface.DB_ACCESS = + Db_interface_compat.OfCached (Db_cache_impl) in let t = Db_backend.make () in Response.rpc_of_t ( try diff --git a/ocaml/database/db_rpc_client_v1.ml b/ocaml/database/db_rpc_client_v1.ml index 7adbcd6bbe..9219779966 100644 --- a/ocaml/database/db_rpc_client_v1.ml +++ b/ocaml/database/db_rpc_client_v1.ml @@ -22,6 +22,10 @@ functor struct exception Remote_db_server_returned_unknown_exception + type field_in = string + + type field_out = string + (* Process an exception returned from server, throwing local exception *) let process_exception_xml xml = match XMLRPC.From.array (fun x -> x) xml with diff --git a/ocaml/database/db_rpc_client_v2.ml b/ocaml/database/db_rpc_client_v2.ml index 2e03f06949..434677d399 100644 --- a/ocaml/database/db_rpc_client_v2.ml +++ b/ocaml/database/db_rpc_client_v2.ml @@ -22,6 +22,10 @@ functor (RPC : Db_interface.RPC) -> struct + type field_in = string + + type field_out = string + let initialise = RPC.initialise let rpc x = RPC.rpc (Jsonrpc.to_string x) |> Jsonrpc.of_string diff --git a/ocaml/database/db_rpc_common_v1.mli b/ocaml/database/db_rpc_common_v1.mli new file mode 100644 index 0000000000..baba04f45d --- /dev/null +++ b/ocaml/database/db_rpc_common_v1.mli @@ -0,0 +1,175 @@ +(* + * 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. + *) + +exception DB_remote_marshall_error + +val marshall_4strings : string * string * string * string -> XMLRPC.xmlrpc + +val unmarshall_4strings : XMLRPC.xmlrpc -> string * string * string * string + +val marshall_3strings : string * string * string -> XMLRPC.xmlrpc + +val unmarshall_3strings : XMLRPC.xmlrpc -> string * string * string + +val marshall_get_table_from_ref_args : string -> XMLRPC.xmlrpc + +val unmarshall_get_table_from_ref_args : XMLRPC.xmlrpc -> string + +val marshall_get_table_from_ref_response : string option -> XMLRPC.xmlrpc + +val unmarshall_get_table_from_ref_response : XMLRPC.xmlrpc -> string option + +val marshall_is_valid_ref_args : string -> XMLRPC.xmlrpc + +val unmarshall_is_valid_ref_args : XMLRPC.xmlrpc -> string + +val marshall_is_valid_ref_response : bool -> XMLRPC.xmlrpc + +val unmarshall_is_valid_ref_response : XMLRPC.xmlrpc -> bool + +val marshall_read_refs_args : string -> XMLRPC.xmlrpc + +val unmarshall_read_refs_args : XMLRPC.xmlrpc -> string + +val marshall_read_refs_response : string list -> XMLRPC.xmlrpc + +val unmarshall_read_refs_response : XMLRPC.xmlrpc -> string list + +val marshall_read_field_where_args : + Db_cache_types.where_record -> XMLRPC.xmlrpc + +val unmarshall_read_field_where_args : + XMLRPC.xmlrpc -> Db_cache_types.where_record + +val marshall_read_field_where_response : string list -> XMLRPC.xmlrpc + +val unmarshall_read_field_where_response : XMLRPC.xmlrpc -> string list + +val marshall_db_get_by_uuid_args : string * string -> XMLRPC.xmlrpc + +val unmarshall_db_get_by_uuid_args : XMLRPC.xmlrpc -> string * string + +val marshall_db_get_by_uuid_response : string -> XMLRPC.xmlrpc + +val marshall_db_get_by_uuid_opt_response : string option -> XMLRPC.xmlrpc + +val unmarshall_db_get_by_uuid_response : XMLRPC.xmlrpc -> string + +val unmarshall_db_get_by_uuid_opt_response : XMLRPC.xmlrpc -> string option + +val marshall_db_get_by_name_label_args : string * string -> XMLRPC.xmlrpc + +val unmarshall_db_get_by_name_label_args : XMLRPC.xmlrpc -> string * string + +val marshall_db_get_by_name_label_response : string list -> XMLRPC.xmlrpc + +val unmarshall_db_get_by_name_label_response : XMLRPC.xmlrpc -> string list + +val marshall_create_row_args : + string * (string * string) list * string -> XMLRPC.xmlrpc + +val unmarshall_create_row_args : + XMLRPC.xmlrpc -> string * (string * string) list * string + +val marshall_create_row_response : unit -> XMLRPC.xmlrpc + +val unmarshall_create_row_response : XMLRPC.xmlrpc -> unit + +val marshall_delete_row_args : string * string -> XMLRPC.xmlrpc + +val unmarshall_delete_row_args : XMLRPC.xmlrpc -> string * string + +val marshall_delete_row_response : unit -> XMLRPC.xmlrpc + +val unmarshall_delete_row_response : XMLRPC.xmlrpc -> unit + +val marshall_write_field_args : + string * string * string * string -> XMLRPC.xmlrpc + +val unmarshall_write_field_args : + XMLRPC.xmlrpc -> string * string * string * string + +val marshall_write_field_response : unit -> XMLRPC.xmlrpc + +val unmarshall_write_field_response : XMLRPC.xmlrpc -> unit + +val marshall_read_field_args : string * string * string -> XMLRPC.xmlrpc + +val unmarshall_read_field_args : XMLRPC.xmlrpc -> string * string * string + +val marshall_read_field_response : string -> XMLRPC.xmlrpc + +val unmarshall_read_field_response : XMLRPC.xmlrpc -> string + +val marshall_find_refs_with_filter_args : + string * Db_filter_types.expr -> XMLRPC.xmlrpc + +val unmarshall_find_refs_with_filter_args : + XMLRPC.xmlrpc -> string * Db_filter_types.expr + +val marshall_find_refs_with_filter_response : string list -> XMLRPC.xmlrpc + +val unmarshall_find_refs_with_filter_response : XMLRPC.xmlrpc -> string list + +val marshall_process_structured_field_args : + (string * string) + * string + * string + * string + * Db_cache_types.structured_op_t + -> XMLRPC.xmlrpc + +val unmarshall_process_structured_field_args : + XMLRPC.xmlrpc + -> (string * string) + * string + * string + * string + * Db_cache_types.structured_op_t + +val marshall_process_structured_field_response : unit -> XMLRPC.xmlrpc + +val unmarshall_process_structured_field_response : XMLRPC.xmlrpc -> unit + +val marshall_read_record_args : string * string -> XMLRPC.xmlrpc + +val unmarshall_read_record_args : XMLRPC.xmlrpc -> string * string + +val marshall_read_record_response : + (string * string) list * (string * string list) list -> XMLRPC.xmlrpc + +val unmarshall_read_record_response : + XMLRPC.xmlrpc -> (string * string) list * (string * string list) list + +val marshall_read_records_where_args : + string * Db_filter_types.expr -> XMLRPC.xmlrpc + +val unmarshall_read_records_where_args : + XMLRPC.xmlrpc -> string * Db_filter_types.expr + +val marshall_read_records_where_response : + (string * ((string * string) list * (string * string list) list)) list + -> XMLRPC.xmlrpc + +val unmarshall_read_records_where_response : + XMLRPC.xmlrpc + -> (string * ((string * string) list * (string * string list) list)) list + +val marshall_stringstringlist : (string * string) list -> Xml.xml + +val unmarshall_stringstringlist : Xml.xml -> (string * string) list + +val marshall_structured_op : Db_cache_types.structured_op_t -> Xml.xml + +val unmarshall_structured_op : Xml.xml -> Db_cache_types.structured_op_t diff --git a/ocaml/database/db_rpc_common_v2.mli b/ocaml/database/db_rpc_common_v2.mli new file mode 100644 index 0000000000..3555e69609 --- /dev/null +++ b/ocaml/database/db_rpc_common_v2.mli @@ -0,0 +1,70 @@ +(* + * 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. + *) + +module Request : sig + type t = + | Get_table_from_ref of string + | Is_valid_ref of string + | Read_refs of string + | Find_refs_with_filter of string * Db_filter_types.expr + | Read_field_where of Db_cache_types.where_record + | Db_get_by_uuid of string * string + | Db_get_by_uuid_opt of string * string + | Db_get_by_name_label of string * string + | Create_row of string * (string * string) list * string + | Delete_row of string * string + | Write_field of string * string * string * string + | Read_field of string * string * string + | Read_record of string * string + | Read_records_where of string * Db_filter_types.expr + | Process_structured_field of + (string * string) + * string + * string + * string + * Db_cache_types.structured_op_t + + val t_of_rpc : Rpc.t -> t + + val rpc_of_t : t -> Rpc.t +end + +module Response : sig + type t = + | Get_table_from_ref of string option + | Is_valid_ref of bool + | Read_refs of string list + | Find_refs_with_filter of string list + | Read_field_where of string list + | Db_get_by_uuid of string + | Db_get_by_uuid_opt of string option + | Db_get_by_name_label of string list + | Create_row of unit + | Delete_row of unit + | Write_field of unit + | Read_field of string + | Read_record of (string * string) list * (string * string list) list + | Read_records_where of + (string * ((string * string) list * (string * string list) list)) list + | Process_structured_field of unit + | Dbcache_notfound of string * string * string + | Duplicate_key_of of string * string * string * string + | Uniqueness_constraint_violation of string * string * string + | Read_missing_uuid of string * string * string + | Too_many_values of string * string * string + + val rpc_of_t : t -> Rpc.t + + val t_of_rpc : Rpc.t -> t +end diff --git a/ocaml/database/db_secret_string.mli b/ocaml/database/db_secret_string.mli index f04812ebad..e0587875a4 100644 --- a/ocaml/database/db_secret_string.mli +++ b/ocaml/database/db_secret_string.mli @@ -13,10 +13,10 @@ *) (* Prevent direct conversions to string to avoid accidental misuse. - * It is still possible to convert it to Rpc.t and recover it that way, - * it is not a protection against willfully recovering the protected string - * (we do need to send these as parameters in RPCs). - * *) + It is still possible to convert it to Rpc.t and recover it that way, + it is not a protection against willfully recovering the protected string + (we do need to send these as parameters in RPCs). +*) (** a type with no direct conversions to string *) type t diff --git a/ocaml/database/db_upgrade.mli b/ocaml/database/db_upgrade.mli new file mode 100644 index 0000000000..90eb5bf691 --- /dev/null +++ b/ocaml/database/db_upgrade.mli @@ -0,0 +1,16 @@ +(* + * 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. + *) + +val generic_database_upgrade : + Db_cache_types.Database.t -> Db_cache_types.Database.t diff --git a/ocaml/database/db_xml.ml b/ocaml/database/db_xml.ml index 1795cdef3b..b9224f5ce5 100644 --- a/ocaml/database/db_xml.ml +++ b/ocaml/database/db_xml.ml @@ -39,8 +39,6 @@ module To = struct Xmlm.output output `El_end (* Write out a string *) - let string (output : Xmlm.output) (key : string) (x : string) = - pair output key x (* Write out an int *) let int (output : Xmlm.output) (key : string) (x : int) = @@ -68,7 +66,8 @@ module To = struct (List.rev (Row.fold (fun k _ v acc -> - (k, Xml_spaces.protect (Schema.Value.marshal v)) :: acc + (k, Xml_spaces.protect (Schema.CachedValue.string_of v)) + :: acc ) row preamble ) diff --git a/ocaml/database/db_xml.mli b/ocaml/database/db_xml.mli new file mode 100644 index 0000000000..24a969c95c --- /dev/null +++ b/ocaml/database/db_xml.mli @@ -0,0 +1,27 @@ +(* + * 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. + *) + +exception Unmarshall_error of string + +module To : sig + val fd : Unix.file_descr -> Db_cache_types.Database.t -> unit + + val file : string -> Db_cache_types.Database.t -> unit +end + +module From : sig + val file : Schema.t -> string -> Db_cache_types.Database.t + + val channel : Schema.t -> in_channel -> Db_cache_types.Database.t +end diff --git a/ocaml/database/dune b/ocaml/database/dune index 1b67e2146d..74b6c512d6 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -1,134 +1,137 @@ (ocamllex db_filter_lex) -(menhir (modules db_filter_parse)) +(menhir + (modules db_filter_parse)) (library - (name xapi_schema) - (public_name xapi-schema) - (modules - db_names db_exn schema string_marshall_helper string_unmarshall_helper - test_schemas) - (libraries - sexpr - xapi-log - xapi-stdext-encodings - ) - (wrapped false) - (preprocess (per_module ((pps ppx_sexp_conv) Schema))) -) + (name xapi_schema) + (public_name xapi-schema) + (modules + db_names + db_exn + schema + string_marshall_helper + string_unmarshall_helper + test_schemas) + (libraries sexpr xapi-log xapi-stdext-encodings) + (wrapped false) + (preprocess + (per_module + ((pps ppx_sexp_conv) + Schema)))) (library - (name xapi_database) - (modes best) - (modules - (:standard \ database_server_main db_cache_test db_names db_exn - block_device_io string_marshall_helper string_unmarshall_helper schema - test_schemas unit_test_marshall unit_test_sql)) - (libraries - forkexec - gzip - mtime - mtime.clock.os - clock - rpclib.core - rpclib.json - safe-resources - stunnel - threads.posix - http_lib - httpsvr - uuid - xapi-backtrace - xapi-datamodel - xapi-log - (re_export xapi-schema) - xapi-idl.updates - xapi-stdext-encodings - xapi-stdext-pervasives - xapi-stdext-std - xapi-stdext-threads - xapi-stdext-unix - xapi_timeslice - xml-light2 - xmlm - ) - (preprocess - (per_module - ((pps ppx_deriving_rpc) - Db_cache_types Db_filter_types Db_rpc_common_v2 Db_secret_string))) -) + (name xapi_database) + (modes best) + (modules + (:standard + \ + database_server_main + db_cache_test + db_names + db_exn + block_device_io + string_marshall_helper + string_unmarshall_helper + schema + test_schemas + unit_test_marshall + unit_test_sql)) + (modules_without_implementation db_interface) + (libraries + forkexec + gzip + mtime + mtime.clock.os + clock + rpclib.core + rpclib.json + safe-resources + stunnel + threads.posix + http_lib + httpsvr + unix + uuid + xapi-backtrace + xapi-datamodel + xapi-log + (re_export xapi-schema) + xapi-idl.updates + xapi-stdext-encodings + xapi-stdext-pervasives + xapi-stdext-std + xapi-stdext-threads + xapi-stdext-unix + xapi_timeslice + xml-light2 + xmlm) + (preprocess + (per_module + ((pps ppx_deriving_rpc) + Db_cache_types + Db_filter_types + Db_rpc_common_v2 + Db_secret_string)))) (executable - (modes exe) - (name block_device_io) - (modules block_device_io) - (libraries - - xapi_database - xapi-log - xapi-stdext-pervasives - xapi-stdext-unix - uuid - ) -) + (modes exe) + (name block_device_io) + (modules block_device_io) + (libraries + unix + xapi_database + xapi-log + xapi-stdext-pervasives + xapi-stdext-unix + uuid)) (install - (package xapi) - (files (block_device_io.exe as block_device_io)) - (section libexec_root) -) + (package xapi) + (files + (block_device_io.exe as block_device_io)) + (section libexec_root)) (executable - (name database_server_main) - (modes exe) - (modules database_server_main) - (libraries - - http_lib - httpsvr - threads.posix - xapi_database - xapi-stdext-threads - xapi-stdext-unix - ) -) + (name database_server_main) + (modes exe) + (modules database_server_main) + (libraries + http_lib + httpsvr + threads.posix + unix + xapi_database + xapi-stdext-threads + xapi-stdext-unix)) (tests - (names unit_test_marshall db_cache_test) - (modes exe) - (package xapi) - (modules db_cache_test unit_test_marshall) - (libraries - alcotest - http_lib - rpclib.xml - sexplib - sexplib0 - xapi_database - xml-light2 - ) -) + (names unit_test_marshall db_cache_test) + (modes exe) + (package xapi) + (modules db_cache_test unit_test_marshall) + (libraries + alcotest + http_lib + rpclib.xml + sexplib + sexplib0 + unix + xapi_database + xml-light2)) (test - (name unit_test_sql) - (modes exe) - (package xapi) - (modules unit_test_sql) - (deps - sql_msg_example.txt - ) - (libraries - alcotest - xapi_database - xml-light2 - ) -) + (name unit_test_sql) + (modes exe) + (package xapi) + (modules unit_test_sql) + (deps sql_msg_example.txt) + (libraries alcotest xapi_database xml-light2)) (rule - (alias runtest) - (deps - (:x database_server_main.exe) - ) - (package xapi) - (action (run %{x} --master db.xml --test)) -) + (alias runtest) + (deps + (:x database_server_main.exe)) + (package xapi) + (action + (run %{x} --master db.xml --test))) diff --git a/ocaml/database/generation.mli b/ocaml/database/generation.mli new file mode 100644 index 0000000000..4a5dd6c90e --- /dev/null +++ b/ocaml/database/generation.mli @@ -0,0 +1,25 @@ +(* + * Copyright (C) 2006-2009 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. + *) + +type t = int64 + +val of_string : string -> t + +val to_string : int64 -> string + +val add_int : int64 -> int -> int64 + +val null_generation : int64 + +val suffix : string diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index d7faff1cd6..09fde7dcee 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -20,8 +20,6 @@ open Safe_resources -type db_record = (string * string) list * (string * string list) list - module D = Debug.Make (struct let name = "master_connection" end) open D diff --git a/ocaml/database/master_connection.mli b/ocaml/database/master_connection.mli new file mode 100644 index 0000000000..eca6c22d02 --- /dev/null +++ b/ocaml/database/master_connection.mli @@ -0,0 +1,43 @@ +(* + * 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. + *) + +val delay : Scheduler.PipeDelay.t + +exception Uninitialised + +val is_slave : (unit -> bool) ref + +val get_master_address : (unit -> string) ref + +val master_rpc_path : string ref + +exception Cannot_connect_to_master + +val force_connection_reset : unit -> unit + +val start_master_connection_watchdog : unit -> unit + +exception Goto_handler + +val on_database_connection_established : (unit -> unit) ref + +val open_secure_connection : unit -> unit + +val connection_timeout : float ref + +val restart_on_connection_timeout : bool ref + +exception Content_length_required + +val execute_remote_fn : string -> Db_interface.response diff --git a/ocaml/database/parse_db_conf.ml b/ocaml/database/parse_db_conf.ml index 8eb55ee2af..67aa5c70d8 100644 --- a/ocaml/database/parse_db_conf.ml +++ b/ocaml/database/parse_db_conf.ml @@ -62,9 +62,6 @@ let generation_read dbconn = try Generation.of_string (Unixext.string_of_file gencount_fname) with _ -> 0L -(* The db conf used for bootstrap purposes, e.g. mounting the 'real' db on shared storage *) -let db_snapshot_dbconn = {dummy_conf with path= Db_globs.snapshot_db} - let from_mode v = match v with Write_limit -> "write_limit" | No_limit -> "no_limit" diff --git a/ocaml/database/parse_db_conf.mli b/ocaml/database/parse_db_conf.mli new file mode 100644 index 0000000000..95004fdb61 --- /dev/null +++ b/ocaml/database/parse_db_conf.mli @@ -0,0 +1,44 @@ +(* + * 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. + *) + +type db_connection_mode = Write_limit | No_limit + +type db_connection = { + path: string + ; mode: db_connection_mode + ; compress: bool + ; write_limit_period: int + ; write_limit_write_cycles: int + ; is_on_remote_storage: bool + ; other_parameters: (string * string) list + ; mutable last_generation_count: Generation.t +} + +val dummy_conf : db_connection + +val make : string -> db_connection + +val generation_filename : db_connection -> string + +val generation_read : db_connection -> Generation.t + +val write_db_conf : db_connection list -> unit + +exception Cannot_parse_database_config_file + +exception Cannot_have_multiple_dbs_in_sr + +val parse_db_conf : string -> db_connection list + +val get_db_conf : string -> db_connection list diff --git a/ocaml/database/redo_log.ml b/ocaml/database/redo_log.ml index 429646dcce..8c2c95928d 100644 --- a/ocaml/database/redo_log.ml +++ b/ocaml/database/redo_log.ml @@ -77,8 +77,7 @@ type redo_log_conf = { ; backoff_delay: int ref ; sock: Unix.file_descr option ref ; pid: (Forkhelpers.pidty * string * string) option ref - ; dying_processes_mutex: Mutex.t - ; num_dying_processes: int ref + ; num_dying_processes: int Atomic.t ; mutex: Mutex.t (** exclusive access to this configuration *) } @@ -585,14 +584,10 @@ let shutdown log = (Thread.create (fun () -> D.debug "Waiting for I/O process with pid %d to die..." ipid ; - with_lock log.dying_processes_mutex (fun () -> - log.num_dying_processes := !(log.num_dying_processes) + 1 - ) ; + Atomic.incr log.num_dying_processes ; ignore (Forkhelpers.waitpid p) ; D.debug "Finished waiting for process with pid %d" ipid ; - with_lock log.dying_processes_mutex (fun () -> - log.num_dying_processes := !(log.num_dying_processes) - 1 - ) + Atomic.decr log.num_dying_processes ) () ) ; @@ -633,13 +628,11 @@ let startup log = () (* We're already started *) | None -> ( (* Don't start if there are already some processes hanging around *) - with_lock log.dying_processes_mutex (fun () -> - if - !(log.num_dying_processes) - >= Db_globs.redo_log_max_dying_processes - then - raise TooManyProcesses - ) ; + if + Atomic.get log.num_dying_processes + >= Db_globs.redo_log_max_dying_processes + then + raise TooManyProcesses ; match !(log.device) with | None -> D.info "Could not find block device" ; @@ -793,8 +786,7 @@ let create ~name ~state_change_callback ~read_only = ; backoff_delay= ref Db_globs.redo_log_initial_backoff_delay ; sock= ref None ; pid= ref None - ; dying_processes_mutex= Mutex.create () - ; num_dying_processes= ref 0 + ; num_dying_processes= Atomic.make 0 ; mutex= Mutex.create () } in diff --git a/ocaml/database/schema.ml b/ocaml/database/schema.ml index 6577bc7cfc..06a2dc391d 100644 --- a/ocaml/database/schema.ml +++ b/ocaml/database/schema.ml @@ -40,6 +40,12 @@ module Value = struct | Pairs of (string * string) list [@@deriving sexp_of] + let string s = String s + + let set xs = Set xs + + let pairs xs = Pairs xs + let marshal = function | String x -> x @@ -84,6 +90,49 @@ module Value = struct end end +(** We have a Value.t *) +type present = [`Present of Value.t] + +(** We don't have a Value.t. For backwards compatibility with DB RPC protocols. *) +type absent = [`Absent] + +type maybe = [present | absent] + +module CachedValue = struct + type !+'a t = {v: 'a; marshalled: string} + + let v v = {v= `Present v; marshalled= Value.marshal v} + + let of_string marshalled = {v= `Absent; marshalled} + + let string_of t = t.marshalled + + let value_of {v= `Present v; _} = v + + let unmarshal ty t = + match t.v with + | `Present v -> + v + | `Absent -> + Value.unmarshal ty t.marshalled + + let of_typed_string ty marshalled = + let v = Value.unmarshal ty marshalled in + {v= `Present v; marshalled} + + let maybe_unmarshal ty = function + | {v= `Present _; _} as p -> + p + | {v= `Absent; marshalled} -> + of_typed_string ty marshalled + + let open_present ({v= `Present _; _} as t) = t +end + +type cached_value = present CachedValue.t + +type maybe_cached_value = maybe CachedValue.t + module Column = struct type t = { name: string diff --git a/ocaml/database/schema.mli b/ocaml/database/schema.mli new file mode 100644 index 0000000000..8a248d4995 --- /dev/null +++ b/ocaml/database/schema.mli @@ -0,0 +1,232 @@ +(* + * 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. + *) + +module Type : sig + type t = String | Set | Pairs [@@deriving sexp_of] + + exception Error of t * t +end + +module Value : sig + type t = + | String of string + | Set of string list + | Pairs of (string * string) list + [@@deriving sexp_of] + + val string : string -> t + + val set : string list -> t + + val pairs : (string * string) list -> t + + val marshal : t -> string + + val unmarshal : Type.t -> string -> t + + module Unsafe_cast : sig + val string : t -> string + + val set : t -> string list + + val pairs : t -> (string * string) list + end +end + +type present = [`Present of Value.t] + +type absent = [`Absent] + +type maybe = [`Absent | `Present of Value.t] + +(** Abstract type, ensuring marshalled form was created from a Value.t. + + For backwards compatibility this can also be created from a marshalled form, + but then retrieving the value requires its {Type.t} to be known. + + A polymorphic variant is used to decide at the type level when we are always guaranteed to have + a {type:Value.t} available, from the situations where we do not. + + When {type:Value.t} is not available at construction time then unmarshaling can incurr a performance + overhead every time it is called, because the value here is immutable, and caching only happens at construction time. + + No guarantee is made about the encoding of the values (in the future we could also cache whether we've already checked + for [utf8_xml] compatibility). + *) +module CachedValue : sig + type +!'a t + + val v : Value.t -> [> present] t + (** [v value] creates a cached value, storing the value and its serialized form. + + [O(1)] for strings, and [O(n)] for sets and maps, where [n] is the result size in marshalled form. + *) + + val of_string : string -> [> absent] t + (** [of_string marshalled] created a cached value from a marshalled form. + + This is provided for backwards compatibility, e.g. for DB RPC calls which only send the marshalled form without type information. + [O(1)] operation, but {!val:unmarshal} can be [O(n)] for sets and maps. + *) + + val string_of : 'a t -> string + (** [string_of t] returns [t] in marshalled form. + + This works on any cached value types. + + [O(1)] operation, marshaling happens at construction time. + *) + + val of_typed_string : Type.t -> string -> [> present] t + (** [of_typed_string ty marshalled] creates a cached value, storing both the serialized form and the value. + + Same complexity as {!val:unmarshal} + *) + + val value_of : [< present] t -> Value.t + (** [value_of t] returns [t] in {!type:Value.t} form. + + This only works on cached values created by {!val:v}. + + [O(1)] operation, stored at construction time. + *) + + val unmarshal : Type.t -> [< maybe] t -> Value.t + (** [unmarshal ty t] returns [t] in Value.t form if known, or unmarshals it. + + This works on any cached value. + When the value was created by {!val:v} this is an [O(1)] operation. + When the value was created by {!val:of_string} this is an [O(1)] operation for strings, + and [O(n)] operation for sets and maps, as it requires unmarshaling. + The unmarshalled value is not cached, so each unmarshal call has the same cost. + *) + + val maybe_unmarshal : Type.t -> [< maybe] t -> present t + (** [maybe_unmarshal ty t] returns [t] with both a Value and its marshaled form. + + Called {!val:unmarshal} internally if [t] doesn't contain a {type:Value.t}. + + Same complexity as !{val:unmarshal}. + *) + + val open_present : [< present] t -> [> present] t + (** [open_present t] returns [t] as an open polymorphic variant, that can be merged with [absent]. *) +end + +type cached_value = present CachedValue.t + +type maybe_cached_value = maybe CachedValue.t + +module Column : sig + type t = { + name: string + ; persistent: bool + ; empty: Value.t + ; default: Value.t option + ; ty: Type.t + ; issetref: bool + } + [@@deriving sexp_of] + + val name_of : t -> string +end + +val tabulate : 'a list -> key_fn:('a -> 'b) -> ('b, 'a) Hashtbl.t + +val values_of_table : ('a, 'b) Hashtbl.t -> 'b list + +module Table : sig + type t' = {name: string; columns: Column.t list; persistent: bool} + [@@deriving sexp_of] + + val sexp_of_t' : t' -> Sexplib0.Sexp.t + + type t = { + name: string + ; columns: (string, Column.t) Hashtbl.t + ; persistent: bool + } + [@@deriving sexp_of] + + val t'_of_t : t -> t' + + val t_of_t' : t' -> t + + val find : string -> t -> Column.t + + val create : name:string -> columns:Column.t list -> persistent:bool -> t + + val name_of : t -> string +end + +type relationship = OneToMany of string * string * string * string + +val sexp_of_relationship : relationship -> Sexplib0.Sexp.t + +module Database : sig + type t' = {tables: Table.t list} + + val sexp_of_t' : t' -> Sexplib0.Sexp.t + + type t = {tables: (string, Table.t) Hashtbl.t} + + val t_of_t' : t' -> t + + val t'_of_t : t -> t' + + val sexp_of_t : t -> Sexplib0.Sexp.t + + val find : string -> t -> Table.t + + val of_tables : Table.t list -> t +end + +type foreign = (string * string * string) list + +val sexp_of_foreign : foreign -> Sexplib0.Sexp.t + +module ForeignMap : sig + include Map.S with type key = string + + type t' = (key * foreign) list + + val sexp_of_t' : t' -> Sexplib0.Sexp.t + + type m = foreign t [@@deriving sexp_of] +end + +type t = { + major_vsn: int + ; minor_vsn: int + ; database: Database.t + ; one_to_many: ForeignMap.m + ; many_to_many: ForeignMap.m +} +[@@deriving sexp_of] + +val database : t -> Database.t + +val table : string -> t -> Table.t + +val empty : t + +val is_table_persistent : t -> string -> bool + +val is_field_persistent : t -> string -> string -> bool + +val table_names : t -> string list + +val one_to_many : ForeignMap.key -> t -> foreign + +val many_to_many : ForeignMap.key -> t -> foreign diff --git a/ocaml/libs/http-lib/mime.mli b/ocaml/database/static_vdis_list.mli similarity index 78% rename from ocaml/libs/http-lib/mime.mli rename to ocaml/database/static_vdis_list.mli index 4566fe15b0..4e59f5b75c 100644 --- a/ocaml/libs/http-lib/mime.mli +++ b/ocaml/database/static_vdis_list.mli @@ -11,12 +11,13 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -type t -val mime_of_file : string -> t +type vdi = { + uuid: string + ; reason: string + ; delete_next_boot: bool + ; currently_attached: bool + ; path: string option +} -val string_of_mime : t -> string - -val mime_of_ext : t -> string -> string - -val mime_of_file_name : t -> string -> string +val list : unit -> vdi list diff --git a/ocaml/database/stats.ml b/ocaml/database/stats.ml index 8bf4f55de4..25f98dbc26 100644 --- a/ocaml/database/stats.ml +++ b/ocaml/database/stats.ml @@ -68,8 +68,12 @@ let sd (p : Normal_population.t) = in sqrt v -let string_of (p : Normal_population.t) = - Printf.sprintf "%f [sd = %f]" (mean p) (sd p) +let string_of ?(counts = false) (p : Normal_population.t) = + match counts with + | false -> + Printf.sprintf "%f [sd = %f]" (mean p) (sd p) + | true -> + Printf.sprintf "%f [sd = %f, n=%d]" (mean p) (sd p) p.n (** [sample thing t] records new time [t] for population named [thing] *) let sample (name : string) (x : float) : unit = @@ -104,7 +108,7 @@ let time_this (name : string) f = name ) -let summarise () = +let summarise ?(counts = false) () = with_lock timings_m (fun () -> - Hashtbl.fold (fun k v acc -> (k, string_of v) :: acc) timings [] + Hashtbl.fold (fun k v acc -> (k, string_of ~counts v) :: acc) timings [] ) diff --git a/ocaml/database/stats.mli b/ocaml/database/stats.mli index 1cef437b03..6a0d053540 100644 --- a/ocaml/database/stats.mli +++ b/ocaml/database/stats.mli @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -val summarise : unit -> (string * string) list +val summarise : ?counts:bool -> unit -> (string * string) list (** Produce a string name -> string mean, standard deviation summary for each population *) val time_this : string -> (unit -> 'a) -> 'a diff --git a/ocaml/database/string_marshall_helper.ml b/ocaml/database/string_marshall_helper.ml index ba003bee96..1add3aef7b 100644 --- a/ocaml/database/string_marshall_helper.ml +++ b/ocaml/database/string_marshall_helper.ml @@ -22,9 +22,7 @@ module D = Debug.Make (struct let name = __MODULE__ end) let ensure_utf8_xml string = let length = String.length string in - let prefix = - Xapi_stdext_encodings.Encodings.UTF8_XML.longest_valid_prefix string - in + let prefix = Xapi_stdext_encodings.Utf8.XML.longest_valid_prefix string in if length > String.length prefix then D.warn "Whilst doing 'set' of structured field, string truncated to: '%s'." prefix ; diff --git a/ocaml/database/string_marshall_helper.mli b/ocaml/database/string_marshall_helper.mli new file mode 100644 index 0000000000..2fc57ff97b --- /dev/null +++ b/ocaml/database/string_marshall_helper.mli @@ -0,0 +1,19 @@ +(* + * 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. + *) + +val ensure_utf8_xml : string -> string + +val set : ('a -> string) -> 'a list -> string + +val map : ('a -> string) -> ('b -> string) -> ('a * 'b) list -> string diff --git a/ocaml/database/string_unmarshall_helper.mli b/ocaml/database/string_unmarshall_helper.mli new file mode 100644 index 0000000000..3362c9659f --- /dev/null +++ b/ocaml/database/string_unmarshall_helper.mli @@ -0,0 +1,19 @@ +(* + * 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. + *) + +exception Failure of string + +val set : (string -> 'a) -> string -> 'a list + +val map : (string -> 'a) -> (string -> 'b) -> string -> ('a * 'b) list diff --git a/ocaml/database/test_schemas.ml b/ocaml/database/test_schemas.ml index fa2519b5f6..57b92cce06 100644 --- a/ocaml/database/test_schemas.ml +++ b/ocaml/database/test_schemas.ml @@ -1,9 +1,11 @@ +let empty = Schema.Value.string "" + let schema = let _ref = { Schema.Column.name= Db_names.ref ; persistent= true - ; empty= Schema.Value.String "" + ; empty ; default= None ; ty= Schema.Type.String ; issetref= false @@ -13,7 +15,7 @@ let schema = { Schema.Column.name= Db_names.uuid ; persistent= true - ; empty= Schema.Value.String "" + ; empty ; default= None ; ty= Schema.Type.String ; issetref= false @@ -23,7 +25,7 @@ let schema = { Schema.Column.name= Db_names.name_label ; persistent= true - ; empty= Schema.Value.String "" + ; empty ; default= None ; ty= Schema.Type.String ; issetref= false @@ -33,7 +35,7 @@ let schema = { Schema.Column.name= "name__description" ; persistent= true - ; empty= Schema.Value.String "" + ; empty ; default= None ; ty= Schema.Type.String ; issetref= false @@ -43,7 +45,7 @@ let schema = { Schema.Column.name= "type" ; persistent= true - ; empty= Schema.Value.String "" + ; empty ; default= None ; ty= Schema.Type.String ; issetref= false @@ -73,8 +75,8 @@ let schema = { Schema.Column.name= "protection_policy" ; persistent= true - ; empty= Schema.Value.String "" - ; default= Some (Schema.Value.String "OpaqueRef:NULL") + ; empty + ; default= Some (Schema.Value.string "OpaqueRef:NULL") ; ty= Schema.Type.String ; issetref= false } @@ -93,7 +95,7 @@ let schema = { Schema.Column.name= "VM" ; persistent= true - ; empty= Schema.Value.String "" + ; empty ; default= None ; ty= Schema.Type.String ; issetref= false diff --git a/ocaml/database/test_schemas.mli b/ocaml/database/test_schemas.mli new file mode 100644 index 0000000000..fa4cb6ebac --- /dev/null +++ b/ocaml/database/test_schemas.mli @@ -0,0 +1,17 @@ +(* + * 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. + *) + +val schema : Schema.t + +val many_to_many : Schema.t diff --git a/ocaml/database/unit_test_marshall.mli b/ocaml/database/unit_test_marshall.mli new file mode 100644 index 0000000000..cabf42bbb8 --- /dev/null +++ b/ocaml/database/unit_test_marshall.mli @@ -0,0 +1 @@ +(* this file is empty on purpose: this is an executable file *) diff --git a/ocaml/database/unit_test_sql.mli b/ocaml/database/unit_test_sql.mli new file mode 100644 index 0000000000..cabf42bbb8 --- /dev/null +++ b/ocaml/database/unit_test_sql.mli @@ -0,0 +1 @@ +(* this file is empty on purpose: this is an executable file *) diff --git a/ocaml/database/xml_spaces.mli b/ocaml/database/xml_spaces.mli new file mode 100644 index 0000000000..4ec7f9016d --- /dev/null +++ b/ocaml/database/xml_spaces.mli @@ -0,0 +1,17 @@ +(* + * 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. + *) + +val protect : string -> string + +val unprotect : string -> string diff --git a/ocaml/doc/dune b/ocaml/doc/dune index 9c4bb6cd47..061ba77823 100644 --- a/ocaml/doc/dune +++ b/ocaml/doc/dune @@ -5,6 +5,7 @@ mustache rpclib.core rpclib.json + unix uuid xapi-consts xapi-datamodel diff --git a/ocaml/forkexecd/.gitignore b/ocaml/forkexecd/.gitignore index d9b5b8ca4b..2c89ac5c34 100644 --- a/ocaml/forkexecd/.gitignore +++ b/ocaml/forkexecd/.gitignore @@ -1,4 +1,7 @@ _build/ +helper/*.o +helper/*.o.d +helper/vfork_helper .merlin *.install diff --git a/ocaml/forkexecd/cli/dune b/ocaml/forkexecd/cli/dune index 2189925a2b..e0fbc15d32 100644 --- a/ocaml/forkexecd/cli/dune +++ b/ocaml/forkexecd/cli/dune @@ -1,7 +1,7 @@ (executable (modes exe) (name fe_cli) - (libraries forkexec)) + (libraries forkexec unix)) (install (package xapi-forkexecd) diff --git a/ocaml/forkexecd/helper/Makefile b/ocaml/forkexecd/helper/Makefile index 2bfc3b07e3..6c14a3aeb6 100644 --- a/ocaml/forkexecd/helper/Makefile +++ b/ocaml/forkexecd/helper/Makefile @@ -5,7 +5,7 @@ LDFLAGS ?= all:: vfork_helper clean:: - rm -f vfork_helper *.o + rm -f vfork_helper *.o *.o.d %.o: %.c $(CC) $(CFLAGS) -MMD -MP -MF $@.d -c -o $@ $< diff --git a/ocaml/forkexecd/helper/vfork_helper.c b/ocaml/forkexecd/helper/vfork_helper.c index 434afba612..0afd285e09 100644 --- a/ocaml/forkexecd/helper/vfork_helper.c +++ b/ocaml/forkexecd/helper/vfork_helper.c @@ -335,14 +335,49 @@ reset_signal_handlers(void) static void clear_cgroup(void) { - int fd = open("/sys/fs/cgroup/systemd/cgroup.procs", O_WRONLY|O_CLOEXEC); - if (fd >= 0) { - char string_pid[32]; - int ignored __attribute__((unused)); - sprintf(string_pid, "%d\n", (int) getpid()); - ignored = write(fd, string_pid, strlen(string_pid)); + // list of files to try, terminated by NULL + static const char *const cgroup_files[] = { + "/sys/fs/cgroup/systemd/cgroup.procs", + "/sys/fs/cgroup/cgroup.procs", + NULL + }; + + char string_pid[32]; + int last_error = 0; + const char *last_error_operation = NULL; + const char *last_fn = NULL; + + snprintf(string_pid, sizeof(string_pid), "%ld\n", (long int) getpid()); + + for (const char *const *fn = cgroup_files; *fn != NULL; ++fn) { + last_fn = *fn; + int fd = open(*fn, O_WRONLY|O_CLOEXEC); + if (fd < 0) { + last_error = errno; + last_error_operation = "opening"; + continue; + } + + // Here we are writing to a virtual file system, partial write is + // not possible. + ssize_t written = write(fd, string_pid, strlen(string_pid)); + if (written < 0) { + last_error = errno; + last_error_operation = "writing"; + } + // Error ignored, we are using a virtual file system, only potential + // errors would be if we have a race and the file was replaced or a + // memory error in the kernel. close(fd); + if (written >= 0) + return; } + + // If we reach this point something went wrong. + // Report error and exit, unless we are not root user, we should be + // root so probably we are testing. + if (last_error_operation && geteuid() == 0) + error(last_error, "Error %s file %s", last_error_operation, last_fn); } static const char * diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index 213ee173e1..90db94c2a5 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -10,6 +10,7 @@ rpclib.core rpclib.json rpclib.xml + unix uuid xapi-backtrace xapi-log diff --git a/ocaml/forkexecd/lib/fe_systemctl.ml b/ocaml/forkexecd/lib/fe_systemctl.ml index 84350c167a..00b4371445 100644 --- a/ocaml/forkexecd/lib/fe_systemctl.ml +++ b/ocaml/forkexecd/lib/fe_systemctl.ml @@ -107,10 +107,10 @@ let show ~service = let stop ~service = action ~service "stop" ; (* Stopping shouldn't fail because it should fall back to SIGKILL which should almost always work, - * unless there is a kernel bug that keeps a process stuck. - * In the unlikely scenario that this does fail we leave the transient service file behind - * so that the failure can be investigated. - * *) + unless there is a kernel bug that keeps a process stuck. + In the unlikely scenario that this does fail we leave the transient service file behind + so that the failure can be investigated. + *) let status = show ~service in (* allow systemd to garbage-collect the status and the unit, preventing leaks. * See CollectMode in systemd.unit(5) for details. *) @@ -162,7 +162,7 @@ let start_transient ?env ?properties ?(exec_ty = Type.Simple) ~service cmd args (* If start failed we do not know what state the service is in: * try to stop it and clean up. * Stopping could fail as well, in which case report the original exception. - * *) + *) ( try let (_ : status) = stop ~service in () diff --git a/ocaml/forkexecd/src/child.ml b/ocaml/forkexecd/src/child.ml index 5f79f2fb6c..76a1611ee8 100644 --- a/ocaml/forkexecd/src/child.ml +++ b/ocaml/forkexecd/src/child.ml @@ -274,7 +274,7 @@ let run state comms_sock fd_sock fd_sock_path = let (_ : int list) = Unix.sigprocmask Unix.SIG_BLOCK [Sys.sigchld] in (* First test whether the child has exited - if it has then report this - * via the socket and exit. *) + * via the socket and exit. *) match Unix.waitpid [Unix.WNOHANG] result with | pid, status when pid = result -> report_child_exit comms_sock args result status ; diff --git a/ocaml/forkexecd/src/dune b/ocaml/forkexecd/src/dune index 77c396de6b..a31f143e8e 100644 --- a/ocaml/forkexecd/src/dune +++ b/ocaml/forkexecd/src/dune @@ -5,6 +5,7 @@ astring fd-send-recv forkexec + unix uuid xapi-log xapi-stdext-unix diff --git a/ocaml/forkexecd/test/dune b/ocaml/forkexecd/test/dune index bba6499fd1..1ab42b893b 100644 --- a/ocaml/forkexecd/test/dune +++ b/ocaml/forkexecd/test/dune @@ -1,7 +1,7 @@ (executable (modes exe) (name fe_test) - (libraries fmt forkexec mtime clock mtime.clock.os uuid xapi-stdext-unix fd-send-recv xapi-log)) + (libraries fmt forkexec mtime clock mtime.clock.os str uuid xapi-stdext-unix fd-send-recv xapi-log unix)) ; preload library to redirect "/dev/log" (rule diff --git a/ocaml/forkexecd/test/syslog.c b/ocaml/forkexecd/test/syslog.c index 10e3dc3c79..ba13281743 100644 --- a/ocaml/forkexecd/test/syslog.c +++ b/ocaml/forkexecd/test/syslog.c @@ -6,6 +6,7 @@ #include #include #include +#include #include #include #include @@ -103,7 +104,7 @@ static void vsyslog_internal(int priority, const char *format, va_list ap) struct sockaddr_un addr; addr.sun_family = AF_UNIX; strcpy(addr.sun_path, "/tmp/xyz"); - sendto(sock, buf, prefix_len + l, MSG_NOSIGNAL, &addr, sizeof(addr)); + sendto(sock, buf, prefix_len + l, MSG_NOSIGNAL, (struct sockaddr *)&addr, sizeof(addr)); close(sock); } diff --git a/ocaml/gencert/dune b/ocaml/gencert/dune index cbd5cd73ae..19ef8f1b33 100644 --- a/ocaml/gencert/dune +++ b/ocaml/gencert/dune @@ -6,7 +6,7 @@ (libraries angstrom astring - cstruct + digestif forkexec mirage-crypto mirage-crypto-pk @@ -16,6 +16,7 @@ ptime.clock.os result rresult + unix x509 xapi-backtrace xapi-consts @@ -32,6 +33,7 @@ (libraries astring gencertlib + unix x509 xapi-inventory xapi_aux @@ -52,7 +54,7 @@ (modules test_lib test_pem) (libraries alcotest - cstruct + digestif fmt gencertlib mirage-crypto @@ -64,6 +66,7 @@ rresult x509 xapi-consts + xapi-datamodel xapi-stdext-unix ) (deps diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index cd964276e6..b25f4db263 100644 --- a/ocaml/gencert/lib.ml +++ b/ocaml/gencert/lib.ml @@ -34,8 +34,7 @@ let validate_private_key pkcs8_private_key = let key_type = X509.(Key_type.to_string (Private_key.key_type key)) in Error (`Msg (server_certificate_key_algorithm_not_supported, [key_type])) in - let raw_pem = Cstruct.of_string pkcs8_private_key in - X509.Private_key.decode_pem raw_pem + X509.Private_key.decode_pem pkcs8_private_key |> R.reword_error (fun (`Msg err_msg) -> let unknown_algorithm = "Unknown algorithm " in if Astring.String.is_prefix ~affix:"multi-prime RSA" err_msg then @@ -56,9 +55,8 @@ let validate_private_key pkcs8_private_key = ) >>= ensure_rsa_key_length -let pem_of_string x ~error_invalid = - let raw_pem = Cstruct.of_string x in - X509.Certificate.decode_pem raw_pem +let decode_cert pem ~error_invalid = + X509.Certificate.decode_pem pem |> R.reword_error (fun (`Msg err_msg) -> D.info {|Failed to validate certificate because "%s"|} err_msg ; `Msg (error_invalid, []) @@ -76,7 +74,7 @@ let assert_not_expired ~now certificate ~error_not_yet ~error_expired = let _validate_not_expired ~now (blob : string) ~error_invalid ~error_not_yet ~error_expired = - pem_of_string blob ~error_invalid >>= fun cert -> + decode_cert blob ~error_invalid >>= fun cert -> assert_not_expired ~now cert ~error_not_yet ~error_expired let validate_not_expired x ~error_not_yet ~error_expired ~error_invalid = @@ -93,16 +91,15 @@ let validate_pem_chain ~pem_leaf ~pem_chain now private_key = | _ -> Error (`Msg (server_certificate_key_mismatch, [])) in - let ensure_sha256_signature_algorithm certificate = + let ensure_signature_algorithm certificate = match X509.Certificate.signature_algorithm certificate with - | Some (_, `SHA256) -> + | Some (_, (`SHA256 | `SHA512)) -> Ok certificate | _ -> Error (`Msg (server_certificate_signature_not_supported, [])) in let validate_chain pem_chain = - let raw_pem = Cstruct.of_string pem_chain in - X509.Certificate.decode_pem_multiple raw_pem |> function + X509.Certificate.decode_pem_multiple pem_chain |> function | Ok (_ :: _ as certs) -> Ok certs | Ok [] -> @@ -116,7 +113,7 @@ let validate_pem_chain ~pem_leaf ~pem_chain now private_key = ~error_not_yet:server_certificate_not_valid_yet ~error_expired:server_certificate_expired >>= ensure_keys_match private_key - >>= ensure_sha256_signature_algorithm + >>= ensure_signature_algorithm >>= fun cert -> match Option.map validate_chain pem_chain with | None -> @@ -135,17 +132,13 @@ let install_server_certificate ~pem_chain ~pem_leaf ~pkcs8_private_key ~server_cert_path ~cert_gid = let now = Ptime_clock.now () in validate_private_key pkcs8_private_key >>= fun priv -> - let pkcs8_private_key = - X509.Private_key.encode_pem priv |> Cstruct.to_string - in + let pkcs8_private_key = X509.Private_key.encode_pem priv in validate_pem_chain ~pem_leaf ~pem_chain now priv >>= fun (cert, chain) -> - let pem_leaf = X509.Certificate.encode_pem cert |> Cstruct.to_string in + let pem_leaf = X509.Certificate.encode_pem cert in Option.fold ~none:(Ok [pkcs8_private_key; pem_leaf]) ~some:(fun chain -> - let pem_chain = - X509.Certificate.encode_pem_multiple chain |> Cstruct.to_string - in + let pem_chain = X509.Certificate.encode_pem_multiple chain in Ok [pkcs8_private_key; pem_leaf; pem_chain] ) chain diff --git a/ocaml/gencert/selfcert.ml b/ocaml/gencert/selfcert.ml index 3d840d34c2..68ff2125de 100644 --- a/ocaml/gencert/selfcert.ml +++ b/ocaml/gencert/selfcert.ml @@ -43,7 +43,7 @@ let valid_from' date = (* Needed to initialize the rng to create random serial codes when signing certificates *) -let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) +let () = Mirage_crypto_rng_unix.use_default () (** [write_cert] writes a PKCS12 file to [path]. The typical file extension would be ".pem". It attempts to do that atomically by @@ -117,7 +117,6 @@ let generate_pub_priv_key length = in let* privkey = rsa_string - |> Cstruct.of_string |> X509.Private_key.decode_pem |> R.reword_error (fun _ -> R.msg "decoding private key failed") in @@ -132,9 +131,7 @@ let selfsign' issuer extensions key_length expiration = let* cert = sign expiration privkey pubkey issuer req extensions in let key_pem = X509.Private_key.encode_pem privkey in let cert_pem = X509.Certificate.encode_pem cert in - let pkcs12 = - String.concat "\n\n" [Cstruct.to_string key_pem; Cstruct.to_string cert_pem] - in + let pkcs12 = String.concat "\n\n" [key_pem; cert_pem] in Ok (cert, pkcs12) let selfsign issuer extensions key_length expiration certfile cert_gid = diff --git a/ocaml/gencert/selfcert.mli b/ocaml/gencert/selfcert.mli index 2e073725e0..d8ce652f8a 100644 --- a/ocaml/gencert/selfcert.mli +++ b/ocaml/gencert/selfcert.mli @@ -23,7 +23,7 @@ val write_certs : string -> int -> string -> (unit, [> Rresult.R.msg]) result val host : name:string -> dns_names:string list - -> ips:Cstruct.t list + -> ips:string list -> ?valid_from:Ptime.t (* default: now *) -> valid_for_days:int -> string diff --git a/ocaml/gencert/test_lib.ml b/ocaml/gencert/test_lib.ml index 379eb35f2e..e2a71225d9 100644 --- a/ocaml/gencert/test_lib.ml +++ b/ocaml/gencert/test_lib.ml @@ -8,7 +8,7 @@ open Rresult.R.Infix let ( let* ) = Rresult.R.bind (* Initialize RNG for testing certificates *) -let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) +let () = Mirage_crypto_rng_unix.use_default () let time_of_rfc3339 date = match Ptime.of_rfc3339 date with @@ -50,6 +50,11 @@ let valid_leaf_certificates = , "2020-02-01T00:00:00Z" , `SHA256 ) + ; ( "Valid, SHA512, matches key" + , "pkey_rsa_2048" + , "2020-02-01T00:00:00Z" + , `SHA512 + ) ] (* ( description, leaf_private_key, expected_private_key, time_of_validation, @@ -80,6 +85,14 @@ let invalid_leaf_certificates = , server_certificate_key_mismatch , [] ) + ; ( "Valid, SHA512, keys do not match" + , "pkey_rsa_2048" + , "pkey_rsa_4096" + , "2020-02-01T00:00:00Z" + , `SHA512 + , server_certificate_key_mismatch + , [] + ) ; ( "Valid, SHA1, matching keys" , "pkey_rsa_2048" , "pkey_rsa_2048" @@ -166,11 +179,20 @@ let test_valid_leaf_cert pem_leaf time pkey () = match validate_pem_chain ~pem_leaf ~pem_chain:None time pkey with | Ok _ -> () - | Error (`Msg (_, msg)) -> + | Error (`Msg err) -> + let err_to_str (name, params) = + let Datamodel_types.{err_doc; err_params; _} = + Hashtbl.find Datamodel_errors.errors name + in + let args = List.combine err_params params in + Format.asprintf "%s %a" err_doc + Fmt.(Dump.list (pair ~sep:(Fmt.any ":@ ") string string)) + args + in Alcotest.fail (Format.asprintf "Valid certificate could not be validated: %a" - Fmt.(Dump.list string) - msg + (Fmt.of_to_string err_to_str) + err ) let test_invalid_cert pem_leaf time pkey error reason = @@ -182,7 +204,7 @@ let test_invalid_cert pem_leaf time pkey error reason = "Error must match" (error, reason) msg let load_pkcs8 name = - X509.Private_key.decode_pem (Cstruct.of_string (load_test_data name)) + X509.Private_key.decode_pem (load_test_data name) |> Rresult.R.reword_error (fun (`Msg msg) -> `Msg (Printf.sprintf "Could not load private key with name '%s': %s" name @@ -200,7 +222,6 @@ let sign_leaf_cert host_name digest pkey_leaf = load_pkcs8 "pkey_rsa_4096" >>= fun pkey_sign -> sign_cert host_name ~pkey_sign digest pkey_leaf >>| X509.Certificate.encode_pem - >>| Cstruct.to_string let valid_leaf_cert_tests = List.map @@ -278,8 +299,7 @@ let valid_chain_cert_tests = (pkey_root, Ok []) key_chain in sign_leaf_cert host_name `SHA256 pkey_leaf >>= fun pem_leaf -> - chain >>| X509.Certificate.encode_pem_multiple >>| Cstruct.to_string - >>| fun pem_chain -> + chain >>| X509.Certificate.encode_pem_multiple >>| fun pem_chain -> test_valid_cert_chain ~pem_leaf ~pem_chain time pkey_leaf in [("Validation of a supported certificate chain", `Quick, test_cert)] diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index a2bfaf4d4f..bfe326e435 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -3866,7 +3866,9 @@ module VIF = struct , "order in which VIF backends are created by xapi" ) ] - "device" "order in which VIF backends are created by xapi" + "device" + "order in which VIF backends are created by xapi. Guaranteed to \ + be an unsigned decimal integer." ; field ~qualifier:StaticRO ~ty:(Ref _network) ~lifecycle: [ @@ -10702,6 +10704,7 @@ let emergency_calls = ; (Datamodel_host.t, Datamodel_host.emergency_disable_tls_verification) ; (Datamodel_host.t, Datamodel_host.emergency_reenable_tls_verification) ; (Datamodel_host.t, Datamodel_host.emergency_clear_mandatory_guidance) + ; (Datamodel_host.t, Datamodel_host.update_firewalld_service_status) ] (** Whitelist of calls that will not get forwarded from the slave to master via the unix domain socket *) @@ -11002,6 +11005,16 @@ let http_actions = , [] ) ) + (* For XC < 8460 compatibility, remove when out of support *) + ; ( "get_vm_rrds" + , ( Get + , "/vm_rrds" + , true + , [String_query_arg "uuid"; Bool_query_arg "json"] + , _R_READ_ONLY + , [] + ) + ) ; ( Constants.get_host_rrd , ( Get , Constants.get_host_rrd_uri @@ -11011,6 +11024,10 @@ let http_actions = , [] ) ) + (* For XC < 8460 compatibility, remove when out of support *) + ; ( "get_host_rrds" + , (Get, "/host_rrds", true, [Bool_query_arg "json"], _R_READ_ONLY, []) + ) ; ( Constants.get_sr_rrd , ( Get , Constants.get_sr_rrd_uri @@ -11078,6 +11095,7 @@ let http_actions = ) ; (* XMLRPC callback *) ("post_root", (Post, "/", false, [], _R_READ_ONLY, [])) + ; ("post_RPC2", (Post, "/RPC2", false, [], _R_READ_ONLY, [])) ; (* JSON callback *) ("post_json", (Post, Constants.json_uri, false, [], _R_READ_ONLY, [])) ; ("post_root_options", (Options, "/", false, [], _R_READ_ONLY, [])) @@ -11130,6 +11148,7 @@ let http_actions = let public_http_actions_with_no_rbac_check = [ "post_root" + ; "post_RPC2" ; (* XMLRPC (API) calls -> checks RBAC internally *) "post_cli" ; (* CLI commands -> calls XMLRPC *) diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 819b7c6114..12c548580b 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 = 789 +let schema_minor_vsn = 791 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 @@ -578,8 +578,8 @@ let get_deprecated lifecycle = with Not_found -> None let call ~name ?(doc = "") ?(in_oss_since = Some "3.0.3") ?result - ?(flags = [`Session; `Async]) ?(effect = true) ?(tag = Custom) ?(errs = []) - ?(custom_marshaller = false) ?(db_only = false) + ?(flags = [`Session; `Async]) ?(has_effect = true) ?(tag = Custom) + ?(errs = []) ?(custom_marshaller = false) ?(db_only = false) ?(no_current_operations = false) ?(secret = false) ?(hide_from_docs = false) ?(pool_internal = false) ~allowed_roles ?(map_keys_roles = []) ?(params = []) ?versioned_params ?lifecycle ?(doc_tags = []) ?forward_to () @@ -633,7 +633,7 @@ let call ~name ?(doc = "") ?(in_oss_since = Some "3.0.3") ?result ; msg_db_only= db_only ; msg_release= call_release ; msg_lifecycle= Lifecycle.from lifecycle - ; msg_has_effect= effect + ; msg_has_effect= has_effect ; msg_tag= tag ; msg_obj_name= "" ; msg_force_custom= None @@ -659,8 +659,8 @@ let operation_enum x = (** Make an object field record *) let field ?(in_oss_since = Some "3.0.3") ?(internal_only = false) ?(ignore_foreign_key = false) ?(writer_roles = None) ?(reader_roles = None) - ?(qualifier = RW) ?(ty = String) ?(effect = false) ?(default_value = None) - ?(persist = true) ?(map_keys_roles = []) + ?(qualifier = RW) ?(ty = String) ?(has_effect = false) + ?(default_value = None) ?(persist = true) ?(map_keys_roles = []) ?(* list of (key_name,(writer_roles)) for a map field *) lifecycle ?(doc_tags = []) name desc = let lifecycle = @@ -695,7 +695,7 @@ let field ?(in_oss_since = Some "3.0.3") ?(internal_only = false) ; full_name= [name] ; field_description= desc ; field_persist= persist - ; field_has_effect= effect + ; field_has_effect= has_effect ; field_ignore_foreign_key= ignore_foreign_key ; field_setter_roles= writer_roles ; field_getter_roles= reader_roles diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 27bb8a7bf9..62cf8d8452 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -68,7 +68,7 @@ let _ = "The license-server connection details (address or port) were missing or \ incomplete." () ; - error Api_errors.license_checkout_error ["reason"] + error Api_errors.license_checkout_error ["code"; "message"] ~doc:"The license for the edition you requested is not available." () ; error Api_errors.license_file_deprecated [] ~doc: @@ -532,31 +532,14 @@ let _ = "You attempted an operation on a VM which requires a more recent version \ of the PV drivers. Please upgrade your PV drivers." () ; - error Api_errors.vm_lacks_feature_shutdown ["vm"] - ~doc: - "You attempted an operation which needs the cooperative shutdown feature \ - on a VM which lacks it." - () ; - error Api_errors.vm_lacks_feature_vcpu_hotplug ["vm"] - ~doc: - "You attempted an operation which needs the VM hotplug-vcpu feature on a \ - VM which lacks it." - () ; - error Api_errors.vm_lacks_feature_suspend ["vm"] - ~doc: - "You attempted an operation which needs the VM cooperative suspend \ - feature on a VM which lacks it." - () ; - error Api_errors.vm_lacks_feature_static_ip_setting ["vm"] - ~doc: - "You attempted an operation which needs the VM static-ip-setting feature \ - on a VM which lacks it." - () ; error Api_errors.vm_lacks_feature ["vm"] ~doc:"You attempted an operation on a VM which lacks the feature." () ; + error Api_errors.vm_non_suspendable ["vm"; "reason"] + ~doc:"You attempted an operation on a VM which is not suspendable." () ; error Api_errors.vm_is_template ["vm"] ~doc:"The operation attempted is not valid for a template VM" () ; - error Api_errors.other_operation_in_progress ["class"; "object"] + error Api_errors.other_operation_in_progress + ["class"; "object"; "operation_type"; "operation_ref"] ~doc:"Another operation involving the object is currently in progress" () ; error Api_errors.vbd_not_removable_media ["vbd"] ~doc:"Media could not be ejected because it is not removable" () ; @@ -665,6 +648,11 @@ let _ = "The specified server is disabled and cannot be re-enabled until after \ it has rebooted." () ; + error Api_errors.host_disabled_indefinitely ["host"] + ~doc: + "The specified server is disabled and can only be re-enabled manually \ + with Host.enable." + () ; error Api_errors.no_hosts_available [] ~doc:"There were no servers available to complete the specified operation." () ; @@ -897,6 +885,14 @@ let _ = the pool coordinator. Make sure the sm are of the same versions and try \ again." () ; + error Api_errors.pool_joining_pool_cannot_enable_clustering_on_vlan_network + ["vlan"] ~doc:"The remote pool cannot enable clustering on vlan network" () ; + error Api_errors.pool_joining_host_must_have_only_one_IP_on_clustering_network + [] + ~doc: + "The host joining the pool must have one and only one IP on the \ + clustering network" + () ; (* External directory service *) error Api_errors.subject_cannot_be_resolved [] @@ -1700,8 +1696,8 @@ let _ = ~doc:"The provided certificate has expired." () ; error Api_errors.server_certificate_signature_not_supported [] ~doc: - "The provided certificate is not using the SHA256 (SHA2) signature \ - algorithm." + "The provided certificate is not using one of the following SHA2 \ + signature algorithms: SHA256, SHA512." () ; error Api_errors.server_certificate_chain_invalid [] @@ -1913,6 +1909,11 @@ let _ = () ; error Api_errors.invalid_base_url ["url"] ~doc:"The base url in the repository is invalid." () ; + error Api_errors.blocked_repo_url ["url"] + ~doc: + "Cannot create the repository as the url is blocked, please check your \ + settings." + () ; error Api_errors.invalid_gpgkey_path ["gpgkey_path"] ~doc:"The GPG public key file name in the repository is invalid." () ; error Api_errors.repository_already_exists ["ref"] @@ -2040,6 +2041,15 @@ let _ = error Api_errors.disable_ssh_partially_failed ["hosts"] ~doc:"Some of hosts failed to disable SSH access." () ; + error Api_errors.set_ssh_timeout_partially_failed ["hosts"] + ~doc:"Some hosts failed to set SSH timeout." () ; + + error Api_errors.set_console_timeout_partially_failed ["hosts"] + ~doc:"Some hosts failed to set console timeout." () ; + + error Api_errors.set_ssh_auto_mode_partially_failed ["hosts"] + ~doc:"Some hosts failed to set SSH auto mode." () ; + error Api_errors.host_driver_no_hardware ["driver variant"] ~doc:"No hardware present for this host driver variant" () ; @@ -2049,6 +2059,9 @@ let _ = enable it in XC or run xe pool-enable-tls-verification instead." () ; + error Api_errors.sysprep ["vm"; "message"] + ~doc:"VM.sysprep error with details in the message" () ; + message (fst Api_messages.ha_pool_overcommitted) ~doc: diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 99f4ebcf31..29b5610b22 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -625,12 +625,37 @@ let disable = , "Puts the host into a state in which no new VMs can be started. \ Currently active VMs on the host continue to execute." ) + ; ( Changed + , "25.31.0" + , "Added auto_enable option to allow persisting the state across \ + toolstack restarts and host reboots." + ) ] ~name:"disable" ~doc: "Puts the host into a state in which no new VMs can be started. \ Currently active VMs on the host continue to execute." - ~params:[(Ref _host, "host", "The Host to disable")] + ~versioned_params: + [ + { + param_type= Ref _host + ; param_name= "host" + ; param_doc= "The Host to disable" + ; param_release= rio_release + ; param_default= None + } + ; { + param_type= Bool + ; param_name= "auto_enable" + ; param_doc= + "If true (default), the host will be re-enabled after a toolstack \ + restart automatically. If false, the host will be disabled \ + indefinitely, across toolstack restarts and host reboots, until \ + re-enabled explicitly with Host.enable." + ; param_release= numbered_release "25.31.0" + ; param_default= Some (VBool true) + } + ] ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) () @@ -915,9 +940,26 @@ let get_diagnostic_timing_stats = ] ~name:"get_diagnostic_timing_stats" ~doc:"Return timing statistics for diagnostic purposes" - ~params:[(Ref _host, "host", "The host to interrogate")] ~result:(Map (String, String), "population name to summary map") - ~hide_from_docs:true ~allowed_roles:_R_READ_ONLY () + ~hide_from_docs:true ~allowed_roles:_R_READ_ONLY + ~versioned_params: + [ + { + param_type= Ref _host + ; param_name= "host" + ; param_doc= "The host" + ; param_release= miami_release + ; param_default= None + } + ; { + param_type= Bool + ; param_name= "counts" + ; param_doc= "Include counts in the result" + ; param_release= numbered_release "25.33.0" + ; param_default= Some (VBool false) + } + ] + () let create_new_blob = call ~name:"create_new_blob" @@ -1297,14 +1339,84 @@ let create_params = ; param_doc= "The SHA256 checksum of updateinfo of the most recently applied update \ on the host" - ; param_release= numbered_release "24.39.0-next" + ; param_release= numbered_release "24.40.0" ; param_default= Some (VString "") } + ; { + param_type= Bool + ; param_name= "ssh_enabled" + ; param_doc= "True if SSH access is enabled for the host" + ; param_release= numbered_release "25.21.0" + ; param_default= Some (VBool Constants.default_ssh_enabled) + } + ; { + param_type= Int + ; param_name= "ssh_enabled_timeout" + ; param_doc= + "The timeout in seconds after which SSH access will be automatically \ + disabled (0 means never), this setting will be applied every time the \ + SSH is enabled by XAPI" + ; param_release= numbered_release "25.21.0" + ; param_default= Some (VInt Constants.default_ssh_enabled_timeout) + } + ; { + param_type= DateTime + ; param_name= "ssh_expiry" + ; param_doc= + "The time in UTC after which the SSH access will be automatically \ + disabled" + ; param_release= numbered_release "25.21.0" + ; param_default= Some (VDateTime Date.epoch) + } + ; { + param_type= Int + ; param_name= "console_idle_timeout" + ; param_doc= + "The timeout in seconds after which idle console will be automatically \ + terminated (0 means never)" + ; param_release= numbered_release "25.21.0" + ; param_default= Some (VInt Constants.default_console_idle_timeout) + } + ; { + param_type= Bool + ; param_name= "ssh_auto_mode" + ; param_doc= "True if SSH auto mode is enabled for the host" + ; param_release= numbered_release "25.27.0" + ; param_default= Some (VBool Constants.default_ssh_auto_mode) + } + ; { + param_type= Bool + ; param_name= "secure_boot" + ; param_doc= "True if the host is in secure boot mode" + ; param_release= numbered_release "25.32.0" + ; param_default= Some (VBool false) + } + ; { + param_type= Map (String, String) + ; param_name= "software_version" + ; param_doc= "Information about the software versions on the host" + ; param_release= numbered_release "25.32.0-next" + ; param_default= Some (VMap []) + } ] let create = call ~name:"create" ~in_oss_since:None - ~lifecycle:[(Published, rel_rio, "Create a new host record")] + ~lifecycle: + [ + (Published, rel_rio, "Create a new host record") + ; ( Changed + , "24.40.0" + , "Added --last_update_hash option to allow last_update_hash to be \ + kept for host joined a pool" + ) + ; ( Changed + , "25.21.0" + , "Added --ssh_enabled --ssh_enabled_timeout --ssh_expiry \ + --console_idle_timeout --ssh_auto_mode options to allow them to be \ + configured for new host" + ) + ] ~versioned_params:create_params ~doc:"Create a new host record" ~result:(Ref _host, "Reference to the newly created host object.") ~hide_from_docs:true ~allowed_roles:_R_POOL_OP () @@ -2368,6 +2480,52 @@ let disable_ssh = ~params:[(Ref _host, "self", "The host")] ~allowed_roles:_R_POOL_ADMIN () +let set_ssh_enabled_timeout = + call ~name:"set_ssh_enabled_timeout" ~lifecycle:[] + ~doc:"Set the SSH service enabled timeout for the host" + ~params: + [ + (Ref _host, "self", "The host") + ; ( Int + , "value" + , "The SSH enabled timeout in seconds (0 means no timeout, max 2 days)" + ) + ] + ~allowed_roles:_R_POOL_ADMIN () + +let set_console_idle_timeout = + call ~name:"set_console_idle_timeout" ~lifecycle:[] + ~doc:"Set the console idle timeout for the host" + ~params: + [ + (Ref _host, "self", "The host") + ; (Int, "value", "The console idle timeout in seconds") + ] + ~allowed_roles:_R_POOL_ADMIN () + +let set_ssh_auto_mode = + call ~name:"set_ssh_auto_mode" ~lifecycle:[] + ~doc:"Set the SSH auto mode for the host" + ~params: + [ + (Ref _host, "self", "The host") + ; ( Bool + , "value" + , "The SSH auto mode for the host，when set to true, SSH to normally be \ + disabled and SSH to be enabled only in case of emergency e.g., xapi \ + is down" + ) + ] + ~allowed_roles:_R_POOL_ADMIN () + +let update_firewalld_service_status = + call ~name:"update_firewalld_service_status" ~flags:[`Session] ~lifecycle:[] + ~pool_internal:true ~hide_from_docs:true + ~doc: + "Update firewalld services based on the corresponding xapi services \ + status." + ~allowed_roles:_R_POOL_OP () + let latest_synced_updates_applied_state = Enum ( "latest_synced_updates_applied_state" @@ -2386,6 +2544,22 @@ let latest_synced_updates_applied_state = ] ) +let get_tracked_user_agents = + call ~name:"get_tracked_user_agents" ~lifecycle:[] + ~doc: + "Get the (name, version) list of tracked user agents on this host. If \ + different versions of the same name are seen, keep the last-seen \ + version. The oldest entry will be removed if reach the max num. Note \ + that the list is cleared after host/XAPI restart" + ~params:[(Ref _host, "self", "The host")] + ~allowed_roles:_R_READ_ONLY + ~result: + ( Map (String, String) + , "The (name, version) list of user agents that have been tracked on \ + this host" + ) + () + (** Hosts *) let t = create_obj ~in_db:true @@ -2527,6 +2701,11 @@ let t = ; emergency_clear_mandatory_guidance ; enable_ssh ; disable_ssh + ; set_ssh_enabled_timeout + ; set_console_idle_timeout + ; set_ssh_auto_mode + ; get_tracked_user_agents + ; update_firewalld_service_status ] ~contents: ([ @@ -2964,6 +3143,31 @@ let t = ~default_value:(Some (VString "")) "last_update_hash" "The SHA256 checksum of updateinfo of the most recently applied \ update on the host" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:Bool + ~default_value:(Some (VBool Constants.default_ssh_enabled)) + "ssh_enabled" "True if SSH access is enabled for the host" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:Int + ~default_value:(Some (VInt Constants.default_ssh_enabled_timeout)) + "ssh_enabled_timeout" + "The timeout in seconds after which SSH access will be \ + automatically disabled (0 means never), this setting will be \ + applied every time the SSH is enabled by XAPI" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:DateTime + ~default_value:(Some (VDateTime Date.epoch)) "ssh_expiry" + "The time in UTC after which the SSH access will be automatically \ + disabled" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:Int + ~default_value:(Some (VInt Constants.default_console_idle_timeout)) + "console_idle_timeout" + "The timeout in seconds after which idle console will be \ + automatically terminated (0 means never)" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:Bool + ~default_value:(Some (VBool Constants.default_ssh_auto_mode)) + "ssh_auto_mode" + "Reflects whether SSH auto mode is enabled for the host" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:Bool + ~default_value:(Some (VBool false)) "secure_boot" + "Whether the host has booted in secure boot mode" ] ) () diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 9aaa87e5fe..a98e52d1dd 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -97,6 +97,18 @@ let prototyped_of_field = function Some "22.26.0" | "SM", "host_pending_features" -> Some "24.37.0" + | "host", "secure_boot" -> + Some "25.31.0" + | "host", "ssh_auto_mode" -> + Some "25.27.0" + | "host", "console_idle_timeout" -> + Some "25.21.0" + | "host", "ssh_expiry" -> + Some "25.21.0" + | "host", "ssh_enabled_timeout" -> + Some "25.21.0" + | "host", "ssh_enabled" -> + Some "25.21.0" | "host", "last_update_hash" -> Some "24.10.0" | "host", "pending_guidances_full" -> @@ -213,6 +225,16 @@ let prototyped_of_message = function Some "22.26.0" | "VTPM", "create" -> Some "22.26.0" + | "host", "update_firewalld_service_status" -> + Some "25.34.0" + | "host", "get_tracked_user_agents" -> + Some "25.34.0" + | "host", "set_ssh_auto_mode" -> + Some "25.27.0" + | "host", "set_console_idle_timeout" -> + Some "25.21.0" + | "host", "set_ssh_enabled_timeout" -> + Some "25.21.0" | "host", "disable_ssh" -> Some "25.13.0" | "host", "enable_ssh" -> @@ -227,14 +249,24 @@ let prototyped_of_message = function Some "25.2.0" | "host", "set_numa_affinity_policy" -> Some "24.0.0" + | "VM", "sysprep" -> + Some "25.24.0" | "VM", "get_secureboot_readiness" -> Some "24.17.0" | "VM", "set_uefi_mode" -> Some "24.17.0" | "VM", "restart_device_models" -> Some "23.30.0" + | "VM", "call_host_plugin" -> + Some "25.22.0" | "VM", "set_groups" -> Some "24.19.1" + | "pool", "set_ssh_auto_mode" -> + Some "25.27.0" + | "pool", "set_console_idle_timeout" -> + Some "25.21.0" + | "pool", "set_ssh_enabled_timeout" -> + Some "25.21.0" | "pool", "disable_ssh" -> Some "25.13.0" | "pool", "enable_ssh" -> diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index cce63a58e1..8bf78a54d7 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -5,8 +5,7 @@ open Datamodel_types let operations = Enum ( "pool_allowed_operations" - , (* FIXME: This should really be called `pool_operations`, to avoid confusion with the Pool.allowed_operations field *) - [ + , [ ("ha_enable", "Indicates this pool is in the process of enabling HA") ; ("ha_disable", "Indicates this pool is in the process of disabling HA") ; ( "cluster_create" @@ -1249,7 +1248,15 @@ let remove_repository = let sync_updates = call ~name:"sync_updates" - ~lifecycle:[(Published, "1.329.0", "")] + ~lifecycle: + [ + (Published, "1.329.0", "") + ; ( Changed + , "25.7.0" + , "Added --username --password options to allow syncing updates from a \ + remote_pool type repository" + ) + ] ~doc:"Sync with the enabled repository" ~versioned_params: [ @@ -1286,14 +1293,14 @@ let sync_updates = param_type= String ; param_name= "username" ; param_doc= "The username of the remote pool" - ; param_release= numbered_release "25.6.0-next" + ; param_release= numbered_release "25.7.0" ; param_default= Some (VString "") } ; { param_type= String ; param_name= "password" ; param_doc= "The password of the remote pool" - ; param_release= numbered_release "25.6.0-next" + ; param_release= numbered_release "25.7.0" ; param_default= Some (VString "") } ] @@ -1571,6 +1578,48 @@ let disable_ssh = ~params:[(Ref _pool, "self", "The pool")] ~allowed_roles:_R_POOL_ADMIN () +let set_ssh_enabled_timeout = + call ~name:"set_ssh_enabled_timeout" ~lifecycle:[] + ~doc:"Set the SSH enabled timeout for all hosts in the pool" + ~params: + [ + (Ref _pool, "self", "The pool") + ; ( Int + , "value" + , "The SSH enabled timeout in seconds. (0 means no timeout, max 2 days)" + ) + ] + ~allowed_roles:_R_POOL_ADMIN () + +let set_console_idle_timeout = + call ~name:"set_console_idle_timeout" ~lifecycle:[] + ~doc:"Set the console idle timeout for all hosts in the pool" + ~params: + [ + (Ref _pool, "self", "The pool") + ; ( Int + , "value" + , "The idle SSH/VNC session timeout in seconds. A value of 0 means no \ + timeout." + ) + ] + ~allowed_roles:_R_POOL_ADMIN () + +let set_ssh_auto_mode = + call ~name:"set_ssh_auto_mode" ~lifecycle:[] + ~doc:"Set the SSH auto mode for all hosts in the pool" + ~params: + [ + (Ref _pool, "self", "The pool") + ; ( Bool + , "value" + , "The SSH auto mode for all hosts in the pool，when set to true, SSH \ + to normally be disabled and SSH to be enabled only in case of \ + emergency e.g., xapi is down" + ) + ] + ~allowed_roles:_R_POOL_ADMIN () + (** A pool class *) let t = create_obj ~in_db:true @@ -1667,6 +1716,9 @@ let t = ; get_guest_secureboot_readiness ; enable_ssh ; disable_ssh + ; set_ssh_enabled_timeout + ; set_console_idle_timeout + ; set_ssh_auto_mode ] ~contents: ([ diff --git a/ocaml/idl/datamodel_schema.ml b/ocaml/idl/datamodel_schema.ml index 10f2066249..6c295ef00f 100644 --- a/ocaml/idl/datamodel_schema.ml +++ b/ocaml/idl/datamodel_schema.ml @@ -77,7 +77,7 @@ let of_datamodel () = { Column.name= Db_names.ref ; persistent= true - ; empty= Value.String "" + ; empty= Value.string "" ; default= None ; ty= Type.String ; issetref= false diff --git a/ocaml/idl/datamodel_values.ml b/ocaml/idl/datamodel_values.ml index e270899b50..522ab4e530 100644 --- a/ocaml/idl/datamodel_values.ml +++ b/ocaml/idl/datamodel_values.ml @@ -84,42 +84,42 @@ let to_db v = let open Schema.Value in match v with | VString s -> - String s + string s | VInt i -> - String (Int64.to_string i) + string (Int64.to_string i) | VFloat f -> - String (string_of_float f) + string (string_of_float f) | VBool true -> - String "true" + string "true" | VBool false -> - String "false" + string "false" | VDateTime d -> - String (Date.to_rfc3339 d) + string (Date.to_rfc3339 d) | VEnum e -> - String e + string e | VMap vvl -> Pairs (List.map (fun (k, v) -> (to_string k, to_string v)) vvl) | VSet vl -> Set (List.map to_string vl) | VRef r -> - String r + string r (* Generate suitable "empty" database value of specified type *) let gen_empty_db_val t = let open Schema in match t with | SecretString | String -> - Value.String "" + Value.string "" | Int -> - Value.String "0" + Value.string "0" | Float -> - Value.String (string_of_float 0.0) + Value.string (string_of_float 0.0) | Bool -> - Value.String "false" + Value.string "false" | DateTime -> - Value.String Date.(to_rfc3339 epoch) + Value.string Date.(to_rfc3339 epoch) | Enum (_, (enum_value, _) :: _) -> - Value.String enum_value + Value.string enum_value | Enum (_, []) -> assert false | Set _ -> @@ -127,8 +127,8 @@ let gen_empty_db_val t = | Map _ -> Value.Pairs [] | Ref _ -> - Value.String null_ref + Value.string null_ref | Record _ -> - Value.String "" + Value.string "" | Option _ -> Value.Set [] diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index 44ca1466d7..17178314ac 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -1742,7 +1742,7 @@ let assert_can_migrate = ; { param_type= Map (String, String) ; param_name= "dest" - ; param_doc= "The result of a VM.migrate_receive call." + ; param_doc= "The result of a Host.migrate_receive call." ; param_release= tampa_release ; param_default= None } @@ -1797,7 +1797,7 @@ let assert_can_migrate_sender = (Ref _vm, "vm", "The VM") ; ( Map (String, String) , "dest" - , "The result of a VM.migrate_receive call." + , "The result of a Host.migrate_receive call." ) ; (Bool, "live", "Live migration") ; ( Map (Ref _vdi, Ref _sr) @@ -2098,6 +2098,19 @@ let call_plugin = ~result:(String, "Result from the plugin") ~allowed_roles:_R_VM_OP () +let call_host_plugin = + call ~name:"call_host_plugin" + ~doc:"Call an API plugin on the host where this vm resides" ~lifecycle:[] + ~params: + [ + (Ref _vm, "vm", "The vm") + ; (String, "plugin", "The name of the plugin") + ; (String, "fn", "The name of the function within the plugin") + ; (Map (String, String), "args", "Arguments for the function") + ] + ~result:(String, "Result from the plugin") + ~allowed_roles:_R_VM_OP () + let set_has_vendor_device = call ~name:"set_has_vendor_device" ~lifecycle: @@ -2198,6 +2211,7 @@ let operations = ; ("reverting", "Reverting the VM to a previous snapshotted state") ; ("destroy", "refers to the act of uninstalling the VM") ; ("create_vtpm", "Creating and adding a VTPM to this VM") + ; ("sysprep", "Performing a Windows sysprep on this VM") ] ) @@ -2356,6 +2370,19 @@ let restart_device_models = ~allowed_roles:(_R_VM_POWER_ADMIN ++ _R_CLIENT_CERT) () +let sysprep = + call ~name:"sysprep" ~lifecycle:[] + ~params: + [ + (Ref _vm, "self", "The VM") + ; (SecretString, "unattend", "XML content passed to sysprep") + ; (Float, "timeout", "timeout in seconds for expected reboot") + ] + ~doc: + "Pass unattend.xml to Windows sysprep and wait for the VM to shut down \ + as part of a reboot." + ~allowed_roles:_R_VM_ADMIN () + let vm_uefi_mode = Enum ( "vm_uefi_mode" @@ -2545,6 +2572,7 @@ let t = ; set_groups ; query_services ; call_plugin + ; call_host_plugin ; set_has_vendor_device ; import ; set_actions_after_crash @@ -2557,6 +2585,7 @@ let t = ; set_blocked_operations ; add_to_blocked_operations ; remove_from_blocked_operations + ; sysprep ] ~contents: ([ @@ -2591,7 +2620,7 @@ let t = ) ] "Creators of VMs and templates may store version information here." - ; field ~effect:true ~ty:Bool "is_a_template" + ; field ~has_effect:true ~ty:Bool "is_a_template" ~lifecycle: [ ( Published @@ -2786,7 +2815,7 @@ let t = ~ty:String "recommendations" "An XML specification of recommended values and ranges for \ properties of this VM" - ; field ~effect:true ~in_oss_since:None + ; field ~has_effect:true ~in_oss_since:None ~ty:(Map (String, String)) ~lifecycle: [ diff --git a/ocaml/idl/dune b/ocaml/idl/dune index c49fb097ce..bc22a311cd 100644 --- a/ocaml/idl/dune +++ b/ocaml/idl/dune @@ -33,6 +33,7 @@ xapi-stdext-std xapi-stdext-pervasives xapi-stdext-unix + unix ) ) diff --git a/ocaml/idl/json_backend/dune b/ocaml/idl/json_backend/dune index c03bead0cd..6a16181c45 100644 --- a/ocaml/idl/json_backend/dune +++ b/ocaml/idl/json_backend/dune @@ -3,6 +3,7 @@ (name gen_json) (libraries fmt + unix xapi-datamodel xapi-consts xapi-stdext-unix diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 44d8bf9298..863ae6b2b5 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -484,7 +484,9 @@ let gen_db_actions _config highapi = (toposort_types highapi only_records) ; (* NB record types are ignored by dm_to_string and string_to_dm *) O.Module.strings_of (dm_to_string all_types_in_db) + ; O.Module.strings_of (dm_to_field all_types_in_db) ; O.Module.strings_of (string_to_dm all_types_in_db) + ; O.Module.strings_of (field_to_dm all_types_in_db) ; O.Module.strings_of (db_action highapi_in_db) ] @ List.map O.Module.strings_of (Gen_db_check.all highapi_in_db) diff --git a/ocaml/idl/ocaml_backend/gen_client.ml b/ocaml/idl/ocaml_backend/gen_client.ml index ee61a09496..55de939525 100644 --- a/ocaml/idl/ocaml_backend/gen_client.ml +++ b/ocaml/idl/ocaml_backend/gen_client.ml @@ -92,27 +92,34 @@ let ctor_fields (obj : obj) = (function {DT.qualifier= DT.StaticRO | DT.RW; _} -> true | _ -> false) (DU.fields_of_obj obj) -(* Compute a message parameter list from a message suitable for the client (only!) *) -let args_of_message ?(expand_record = true) (obj : obj) +(* Compute a list of message parameters and their default values from a + message suitable for the client (only!) *) +let args_of_message_with_default ?(expand_record = true) (obj : obj) ({msg_tag= tag; _} as msg) = let arg_of_param = function - | {param_type= Record x; _} -> ( + | {param_type= Record x; param_default= default; _} -> ( match tag with | FromObject Make -> if x <> obj.DT.name then failwith "args_of_message" ; if expand_record then - List.map param_of_field (ctor_fields obj) + List.map + (fun x -> (x, None)) + (List.map param_of_field (ctor_fields obj)) else - [custom _value (Record x)] + [(custom _value (Record x), default)] | _ -> failwith "arg_of_param: encountered a Record in an unexpected place" ) | p -> - [of_param p] + [(of_param p, p.param_default)] in - let session = if msg.msg_session then [session] else [] in + let session = if msg.msg_session then [(session, None)] else [] in List.concat (session :: List.map arg_of_param msg.msg_params) +(* Compute a message parameter list from a message suitable for the client (only!) *) +let args_of_message ?(expand_record = true) obj x = + List.map fst (args_of_message_with_default ~expand_record obj x) + let gen_module api : O.Module.t = (* Generate any additional helper functions for an operation here *) let helper_record_constructor ~sync (obj : obj) (x : message) = @@ -148,7 +155,8 @@ let gen_module api : O.Module.t = in (* Convert an operation into a Let-binding *) let operation ~sync (obj : obj) (x : message) = - let args = args_of_message obj x in + let args_with_default = args_of_message_with_default obj x in + let args = List.map fst args_with_default in let to_rpc (arg : O.param) = let binding = O.string_of_param arg in let converter = O.type_of_param arg in @@ -172,6 +180,31 @@ let gen_module api : O.Module.t = else List.map O.string_of_param args in + let defaults = + List.map + (fun (_, default_value) -> + match default_value with + | Some x -> + Printf.sprintf "Some (%s)" (Datamodel_values.to_ocaml_string x) + | None -> + "None" + ) + args_with_default + in + let rightmost_arg_default = + Some true + = List.fold_right + (fun (_, x) rightmost_arg_default -> + match rightmost_arg_default with + | None when Option.is_some x -> + Some true + | Some true -> + Some true + | _ -> + Some false + ) + args_with_default None + in let task = DT.Ref Datamodel_common._task in let from_xmlrpc t = match (x.msg_custom_marshaller, t, sync) with @@ -203,15 +236,41 @@ let gen_module api : O.Module.t = (List.map to_rpc args @ [ (if is_ctor then ctor_record else "") + ; ( if (not is_ctor) && rightmost_arg_default then + (* Skip specifying arguments which are equal to their default + values. This way, when a newer client talks to an older + server that does not know about a new parameter, it can + silently skip sending it, avoiding an error *) + Printf.sprintf + {| + let needed_args, _ = List.fold_right2 + (fun param default (acc, skipped)-> + (* Since arguments are positional, we can only skip specifying an + argument that's equal to its default value if all the arguments to + its right were also not specified *) + if skipped then + (match default with + | Some default_value when param = default_value -> (acc, true) + | _ -> (param::acc, false)) + else + (param :: acc, false) + ) [ %s ] [ %s ] ([], true) + in + |} + (String.concat "; " rpc_args) + (String.concat "; " defaults) + else + Printf.sprintf "let needed_args = [ %s ] in" + (String.concat "; " rpc_args) + ) ; Printf.sprintf - "rpc_wrapper rpc %s [ %s ] >>= fun x -> return (%s x)" + "rpc_wrapper rpc %s needed_args >>= fun x -> return (%s x)" ( if sync then Printf.sprintf "\"%s\"" wire_name else Printf.sprintf {|(Printf.sprintf "%%s%s" AQ.async_qualifier)|} wire_name ) - (String.concat "; " rpc_args) (from_xmlrpc x.msg_result) ] ) @@ -227,9 +286,6 @@ let gen_module api : O.Module.t = obj.messages in let fields = fields_of (operations @ helpers) in - (* - let fields = List.map (fun x -> O.Module.Let (operation ~sync obj x)) obj.messages in -*) O.Module.make ~name:(OU.ocaml_of_obj_name obj.DT.name) ~elements:fields () in let preamble = diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index e467624ab1..f4633fd1ba 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/ocaml/idl/ocaml_backend/gen_db_actions.ml @@ -25,8 +25,12 @@ open DT (* Names of the modules we're going to generate (use these to prevent typos) *) let _dm_to_string = "DM_to_String" +let _dm_to_field = "DM_to_Field" + let _string_to_dm = "String_to_DM" +let _field_to_dm = "Field_to_DM" + let _db_action = "DB_Action" let _db_defaults = "DB_DEFAULTS" @@ -109,6 +113,44 @@ let dm_to_string tys : O.Module.t = ~elements:(List.map (fun ty -> O.Module.Let (ty_fun ty)) tys) () +let dm_to_field tys : O.Module.t = + let tys = List.filter type_marshalled_in_db tys in + (* For every type, we create a single function *) + let ty_fun ty = + let body = + match ty with + | DT.Map (String, String) -> + "Schema.Value.pairs" + | DT.Map (key, value) -> + Printf.sprintf + "fun s -> s |> List.map (fun (k, v) -> %s.%s k, %s.%s v) |> \ + Schema.Value.pairs" + _dm_to_string (OU.alias_of_ty key) _dm_to_string + (OU.alias_of_ty value) + | DT.Set String -> + "Schema.Value.set" + | DT.Set ty -> + Printf.sprintf "fun s -> s |> List.map %s.%s |> Schema.Value.set" + _dm_to_string (OU.alias_of_ty ty) + | DT.String -> + "Schema.Value.string" + | _ -> + Printf.sprintf "fun s -> s |> %s.%s |> Schema.Value.string" + _dm_to_string (OU.alias_of_ty ty) + in + O.Let.make ~name:(OU.alias_of_ty ty) ~params:[] ~ty:"Db_interface.field_in" + ~body:[body] () + in + O.Module.make ~name:_dm_to_field + ~preamble: + [ + "exception StringEnumTypeError of string" + ; "exception DateTimeError of string" + ] + ~letrec:true + ~elements:(List.map (fun ty -> O.Module.Let (ty_fun ty)) tys) + () + (** Generate a module of string to datamodel type unmarshalling functions *) let string_to_dm tys : O.Module.t = let tys = List.filter type_marshalled_in_db tys in @@ -171,6 +213,53 @@ let string_to_dm tys : O.Module.t = ~elements:(List.map (fun ty -> O.Module.Let (ty_fun ty)) tys) () +let field_to_dm tys : O.Module.t = + let tys = List.filter type_marshalled_in_db tys in + (* For every type, we create a single function *) + let ty_fun ty = + let name = OU.alias_of_ty ty in + let body = + match ty with + | DT.Map (key, value) -> + let conv = + match (key, value) with + | DT.String, DT.String -> + "" + | _ -> + Printf.sprintf " |> List.map (fun (k, v) -> %s.%s k, %s.%s v)" + _string_to_dm (OU.alias_of_ty key) _string_to_dm + (OU.alias_of_ty value) + in + "fun s -> s |> Schema.CachedValue.maybe_unmarshal Schema.Type.Pairs \ + |> Schema.CachedValue.value_of |> Schema.Value.Unsafe_cast.pairs" + ^ conv + | DT.Set ty -> + let conv = + match ty with + | DT.String -> + "" + | _ -> + Printf.sprintf " |> List.map %s.%s" _string_to_dm + (OU.alias_of_ty ty) + in + "fun s -> s |> Schema.CachedValue.maybe_unmarshal Schema.Type.Set |> \ + Schema.CachedValue.value_of |> Schema.Value.Unsafe_cast.set" + ^ conv + | DT.String -> + "fun s -> s |> Schema.CachedValue.maybe_unmarshal Schema.Type.String \ + |> Schema.CachedValue.value_of |> Schema.Value.Unsafe_cast.string" + | _ -> + Printf.sprintf "fun f -> f |> Schema.CachedValue.string_of |> %s.%s" + _string_to_dm name + in + O.Let.make ~name ~params:[] ~ty:(OU.alias_of_ty ty) ~body:[body] () + in + O.Module.make ~name:_field_to_dm + ~preamble:["exception StringEnumTypeError of string"] + ~letrec:true + ~elements:(List.map (fun ty -> O.Module.Let (ty_fun ty)) tys) + () + (** True if a field is actually in this table, false if stored elsewhere (ie Set(Ref _) are stored in foreign tables *) let field_in_this_table = function @@ -283,7 +372,7 @@ let open_db_module = [ "let __t = Context.database_of __context in" ; "let module DB = (val (Xapi_database.Db_cache.get __t) : \ - Xapi_database.Db_interface.DB_ACCESS) in" + Xapi_database.Db_interface.DB_ACCESS2) in" ] let db_action api : O.Module.t = @@ -331,7 +420,7 @@ let db_action api : O.Module.t = let ty_alias = OU.alias_of_ty f.DT.ty in let accessor = "find_regular" in let field_name = Escaping.escape_id f.full_name in - Printf.sprintf {|%s.%s (%s "%s")|} _string_to_dm ty_alias accessor + Printf.sprintf {|%s.%s (%s "%s")|} _field_to_dm ty_alias accessor field_name in let make_field f = @@ -433,8 +522,13 @@ let db_action api : O.Module.t = let to_string arg = let binding = O.string_of_param arg in let converter = O.type_of_param arg in - Printf.sprintf "let %s = %s.%s %s in" binding _dm_to_string converter - binding + Printf.sprintf "let %s = %s.%s %s in" binding + ( if binding = Client._self || binding = "ref" then + _dm_to_string + else + _dm_to_field + ) + converter binding in let body = match tag with @@ -445,37 +539,38 @@ let db_action api : O.Module.t = (Escaping.escape_id fld.DT.full_name) | FromField (Getter, {DT.ty; full_name; _}) -> Printf.sprintf "%s.%s (DB.read_field __t \"%s\" \"%s\" %s)" - _string_to_dm (OU.alias_of_ty ty) + _field_to_dm (OU.alias_of_ty ty) (Escaping.escape_obj obj.DT.name) (Escaping.escape_id full_name) Client._self | FromField (Add, {DT.ty= DT.Map (_, _); full_name; _}) -> Printf.sprintf - "DB.process_structured_field __t (%s,%s) \"%s\" \"%s\" %s \ - AddMapLegacy" + "DB.process_structured_field __t (Schema.Value.marshal %s, \ + Schema.Value.marshal %s) \"%s\" \"%s\" %s AddMapLegacy" Client._key Client._value (Escaping.escape_obj obj.DT.name) (Escaping.escape_id full_name) Client._self | FromField (Add, {DT.ty= DT.Set _; full_name; _}) -> Printf.sprintf - "DB.process_structured_field __t (%s,\"\") \"%s\" \"%s\" %s AddSet" + "DB.process_structured_field __t (Schema.Value.marshal %s,\"\") \ + \"%s\" \"%s\" %s AddSet" Client._value (Escaping.escape_obj obj.DT.name) (Escaping.escape_id full_name) Client._self | FromField (Remove, {DT.ty= DT.Map (_, _); full_name; _}) -> Printf.sprintf - "DB.process_structured_field __t (%s,\"\") \"%s\" \"%s\" %s \ - RemoveMap" + "DB.process_structured_field __t (Schema.Value.marshal %s,\"\") \ + \"%s\" \"%s\" %s RemoveMap" Client._key (Escaping.escape_obj obj.DT.name) (Escaping.escape_id full_name) Client._self | FromField (Remove, {DT.ty= DT.Set _; full_name; _}) -> Printf.sprintf - "DB.process_structured_field __t (%s,\"\") \"%s\" \"%s\" %s \ - RemoveSet" + "DB.process_structured_field __t (Schema.Value.marshal %s,\"\") \ + \"%s\" \"%s\" %s RemoveSet" Client._value (Escaping.escape_obj obj.DT.name) (Escaping.escape_id full_name) @@ -517,7 +612,9 @@ let db_action api : O.Module.t = match (x.msg_params, x.msg_result) with | [{param_name= name; _}], Some (result_ty, _) -> let query = - Printf.sprintf "DB.db_get_by_uuid __t \"%s\" %s" + Printf.sprintf + "DB.db_get_by_uuid __t \"%s\" (Schema.Value.Unsafe_cast.string \ + %s)" (Escaping.escape_obj obj.DT.name) (OU.escape name) in @@ -530,7 +627,7 @@ let db_action api : O.Module.t = ^ ")" in let query_opt = - Printf.sprintf "DB.db_get_by_uuid_opt __t \"%s\" %s" + Printf.sprintf "DB.db_get_by_uuid_opt __t \"%s\" (%s)" (Escaping.escape_obj obj.DT.name) (OU.escape name) in @@ -555,7 +652,9 @@ let db_action api : O.Module.t = match (x.msg_params, x.msg_result) with | [{param_name= name; _}], Some (Set result_ty, _) -> let query = - Printf.sprintf "DB.db_get_by_name_label __t \"%s\" %s" + Printf.sprintf + "DB.db_get_by_name_label __t \"%s\" \ + (Schema.Value.Unsafe_cast.string %s)" (Escaping.escape_obj obj.DT.name) (OU.escape name) in @@ -606,13 +705,15 @@ let db_action api : O.Module.t = | FromObject GetAllRecordsWhere -> String.concat "\n" [ - "let expr' = Xapi_database.Db_filter.expr_of_string expr in" + "let expr' = Xapi_database.Db_filter.expr_of_string \ + (Schema.Value.Unsafe_cast.string expr) in" ; "get_records_where ~" ^ Gen_common.context ^ " ~expr:expr'" ] | FromObject GetAllWhere -> String.concat "\n" [ - "let expr' = Xapi_database.Db_filter.expr_of_string expr in" + "let expr' = Xapi_database.Db_filter.expr_of_string \ + (Schema.Value.Unsafe_cast.string expr) in" ; "get_refs_where ~" ^ Gen_common.context ^ " ~expr:expr'" ] | _ -> diff --git a/ocaml/idl/ocaml_backend/gen_server.ml b/ocaml/idl/ocaml_backend/gen_server.ml index 1914502126..f95f5f6d96 100644 --- a/ocaml/idl/ocaml_backend/gen_server.ml +++ b/ocaml/idl/ocaml_backend/gen_server.ml @@ -457,7 +457,7 @@ let gen_module api : O.Module.t = ([ "let __call, __params = call.Rpc.name, call.Rpc.params in" ; "List.iter (fun p -> let s = Rpc.to_string p in if not \ - (Xapi_stdext_encodings.Encodings.UTF8_XML.is_valid s) then" + (Xapi_stdext_encodings.Utf8.is_valid s) then" ; "raise (Api_errors.Server_error(Api_errors.invalid_value, \ [\"Invalid UTF-8 string in parameter\"; s]))) __params;" ; "let __label = __call in" diff --git a/ocaml/idl/ocaml_backend/gen_test.ml b/ocaml/idl/ocaml_backend/gen_test.ml deleted file mode 100644 index 70dc19a0fa..0000000000 --- a/ocaml/idl/ocaml_backend/gen_test.ml +++ /dev/null @@ -1,102 +0,0 @@ -(* - * Copyright (C) 2006-2009 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. - *) - -open Printf -module DT = Datamodel_types -module DU = Datamodel_utils -module OU = Ocaml_utils -module O = Ocaml_syntax -module Listext = Xapi_stdext_std.Listext.List - -let print s = output_string stdout (s ^ "\n") - -let rec gen_test_type highapi ty = - let rec aux = function - | DT.String -> - "\"teststring\"" - | DT.Int -> - "123456789123456789L" - | DT.Float -> - "0.123456789" - | DT.Bool -> - "true" - | DT.DateTime -> - "(Date.of_iso8601 \"20120101T00:00:00Z\")" - | DT.Enum (_, (x, _) :: _) -> - Printf.sprintf "(%s)" (OU.constructor_of x) - | DT.Set (DT.Enum (_, y)) -> - Printf.sprintf "[ %s ]" - (String.concat ";" (List.map (fun (x, _) -> OU.constructor_of x) y)) - | DT.Set x -> - Printf.sprintf "[ %s ]" (aux x) - | DT.Map (x, y) -> - Printf.sprintf "[ (%s,%s) ]" (aux x) (aux y) - | DT.Ref _ -> - Printf.sprintf "(Ref.of_string \"OpaqueRef:foo\")" - | DT.Record x -> - gen_record_type highapi x - | _ -> - failwith "Invalid type" - in - aux ty - -(** Generate a list of modules for each record kind *) -and gen_record_type highapi record = - let obj_name = OU.ocaml_of_record_name record in - let all_fields = - DU.fields_of_obj (Dm_api.get_obj_by_name highapi ~objname:record) - in - let field fld = OU.ocaml_of_record_field (obj_name :: fld.DT.full_name) in - let map_fields fn = - String.concat "; " (List.map (fun field -> fn field) all_fields) - in - let regular_def fld = - sprintf "%s=%s" (field fld) (gen_test_type highapi fld.DT.ty) - in - sprintf "{ %s }" (map_fields regular_def) - -let gen_test highapi = - let all_types = DU.Types.of_objects (Dm_api.objects_of_api highapi) in - let all_types = Gen_api.add_set_enums all_types in - ignore all_types ; - List.iter (List.iter print) - (Listext.between [""] - [ - ["open API"] - ; ["let _ ="] - ; List.concat_map - (fun ty -> - [ - sprintf "let oc = open_out \"rpc-light_%s.xml\" in" - (OU.alias_of_ty ty) - ; sprintf "let x = %s in" (gen_test_type highapi ty) - ; sprintf - "Printf.fprintf oc \"%%s\" (Xmlrpc.to_string (API.rpc_of_%s \ - x));" - (OU.alias_of_ty ty) - ; "close_out oc;" - ; sprintf "let oc = open_out \"xml-light2_%s.xml\" in" - (OU.alias_of_ty ty) - ; sprintf - "Printf.fprintf oc \"%%s\" (Xml.to_string (API.Legacy.To.%s \ - x));" - (OU.alias_of_ty ty) - ; "close_out oc;" - (* sprintf "let s = Xml.to_string (API.Legacy.To.%s x) in" (OU.alias_of_ty ty);*) - (* sprintf "let y =" *) - ] - ) - all_types - ] - ) diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 06feb36745..9411d1c3b4 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 = "2f80cd8fbfd0eedab4dfe345565bcb64" +let last_known_schema_hash = "3b20f4304cfaaa7b6213af91ae632e64" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/libs/clock/date.ml b/ocaml/libs/clock/date.ml index c668b0c1fb..2dab4a9544 100644 --- a/ocaml/libs/clock/date.ml +++ b/ocaml/libs/clock/date.ml @@ -64,12 +64,24 @@ let best_effort_iso8601_to_rfc3339 x = x let of_iso8601 x = - let rfc3339 = best_effort_iso8601_to_rfc3339 x in - match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with - | Error _ -> - invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) - | Ok (t, tz, _) -> - {t; tz} + if String.length x > 5 && x.[4] <> '-' && x.[String.length x - 1] = 'Z' then + (* dates in the DB look like "20250319T04:16:24Z", so decoding that should be the fastpath *) + Scanf.sscanf x "%04i%02i%02iT%02i:%02i:%02iZ" (fun y mon d hh mm ss -> + let tz = 0 in + let date = (y, mon, d) and time = ((hh, mm, ss), tz) in + match Ptime.of_date_time (date, time) with + | Some t -> + {t; tz= Some tz} + | None -> + invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) + ) + else + let rfc3339 = best_effort_iso8601_to_rfc3339 x in + match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with + | Error _ -> + invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) + | Ok (t, tz, _) -> + {t; tz} let print_tz tz_s = match tz_s with diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index a2afef3646..19a2e9bf0e 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -21,6 +21,7 @@ fmt mtime.clock.os qcheck-core + unix ) ) diff --git a/ocaml/libs/ezxenstore/core/dune b/ocaml/libs/ezxenstore/core/dune index c7f5f636bc..5575342a2b 100644 --- a/ocaml/libs/ezxenstore/core/dune +++ b/ocaml/libs/ezxenstore/core/dune @@ -5,6 +5,7 @@ cmdliner logs threads + unix uuidm (re_export xenstore) (re_export xenstore_transport) diff --git a/ocaml/libs/ezxenstore/lib_test/dune b/ocaml/libs/ezxenstore/lib_test/dune index da843bf3b1..83f42acdd8 100644 --- a/ocaml/libs/ezxenstore/lib_test/dune +++ b/ocaml/libs/ezxenstore/lib_test/dune @@ -2,5 +2,5 @@ (name main) (package ezxenstore) (deps main.exe) - (libraries cmdliner ezxenstore xenstore_transport xenstore xenstore.unix) + (libraries cmdliner ezxenstore xenstore_transport xenstore xenstore.unix unix) ) diff --git a/ocaml/libs/ezxenstore/watch/dune b/ocaml/libs/ezxenstore/watch/dune index dfd2f3020c..630eee3111 100644 --- a/ocaml/libs/ezxenstore/watch/dune +++ b/ocaml/libs/ezxenstore/watch/dune @@ -7,5 +7,6 @@ xenctrl uuidm threads.posix + unix ) ) diff --git a/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml b/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml index e552ecb1e5..b90f3e621c 100644 --- a/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml +++ b/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml @@ -115,6 +115,10 @@ module Make (Debug : DEBUG) = struct in List.map fst (IntMap.bindings c) + let need_refresh_domains = Atomic.make false + + let mark_refresh_domains () = Atomic.set need_refresh_domains true + let with_xc_and_xs f = Xenctrl.with_intf (fun xc -> with_xs (fun xs -> f xc xs)) @@ -196,9 +200,13 @@ module Make (Debug : DEBUG) = struct in let process_one_watch c (path, _token) = - if path = _introduceDomain || path = _releaseDomain then - look_for_different_domains () - else + if + Atomic.exchange need_refresh_domains false + || path = _introduceDomain + || path = _releaseDomain + then + look_for_different_domains () ; + if path <> _introduceDomain && path <> _releaseDomain then Client.immediate c (fun h -> let xs = Xs.ops h in Actions.watch_fired xc xs path !domains !watches diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index 184fd5b286..4e8d255b6b 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -31,6 +31,7 @@ sha stunnel threads.posix + unix uuid uri xapi-backtrace @@ -57,6 +58,7 @@ threads.posix tracing tracing_propagator + unix uri xapi-backtrace xapi-log @@ -70,7 +72,7 @@ (modes (best exe)) (modules http_test radix_tree_test) - (libraries alcotest fmt http_lib)) + (libraries alcotest fmt http_lib unix)) (executable (modes exe) @@ -81,6 +83,7 @@ safe-resources stunnel threads.posix + unix xapi-backtrace xapi-log xapi-stdext-pervasives @@ -95,6 +98,7 @@ httpsvr safe-resources threads.posix + unix xapi-stdext-threads xapi-stdext-unix)) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index c979e1f7d9..ec18aa461e 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -505,7 +505,7 @@ end module Request = struct type t = { m: method_t - ; uri: string + ; path: string ; query: (string * string) list ; version: string ; frame: bool @@ -528,7 +528,7 @@ module Request = struct let empty = { m= Unknown "" - ; uri= "" + ; path= "" ; query= [] ; version= "" ; frame= false @@ -563,7 +563,7 @@ module Request = struct ; host ; user_agent= Some user_agent ; m= meth - ; uri= path + ; path ; additional_headers= headers ; body ; accept @@ -577,10 +577,10 @@ module Request = struct String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) x) in Printf.sprintf - "{ frame = %b; method = %s; uri = %s; query = [ %s ]; content_length = [ \ - %s ]; transfer encoding = %s; version = %s; cookie = [ %s ]; task = %s; \ - subtask_of = %s; content-type = %s; host = %s; user_agent = %s; }" - x.frame (string_of_method_t x.m) x.uri (kvpairs x.query) + "{ frame = %b; method = %s; path = %s; query = [ %s ]; content_length = \ + [ %s ]; transfer encoding = %s; version = %s; cookie = [ %s ]; task = \ + %s; subtask_of = %s; content-type = %s; host = %s; user_agent = %s; }" + x.frame (string_of_method_t x.m) x.path (kvpairs x.query) (Option.fold ~none:"" ~some:Int64.to_string x.content_length) (Option.value ~default:"" x.transfer_encoding) x.version "(value filtered)" (* cookies *) @@ -642,7 +642,7 @@ module Request = struct [(Hdr.connection ^ ": " ^ if x.close then "close" else "keep-alive")] in [ - Printf.sprintf "%s %s%s HTTP/%s" (string_of_method_t x.m) x.uri query + Printf.sprintf "%s %s%s HTTP/%s" (string_of_method_t x.m) x.path query x.version ] @ cookie @@ -809,17 +809,17 @@ module Url = struct type scheme = Http of http | File of file - type data = {uri: string; query_params: (string * string) list} + type data = {path: string; query_params: (string * string) list} type t = scheme * data - let file_equal a b = String.equal a.path b.path + let file_equal (a : file) (b : file) = String.equal a.path b.path let query_params_equal (ak, av) (bk, bv) = String.equal ak bk && String.equal av bv let data_equal a b = - String.equal a.uri b.uri + String.equal a.path b.path && List.equal query_params_equal a.query_params b.query_params let http_equal a b = @@ -858,7 +858,7 @@ module Url = struct in let data = { - uri= (match Uri.path_unencoded uri with "" -> "/" | path -> path) + path= (match Uri.path_unencoded uri with "" -> "/" | path -> path) ; query_params= Uri.query uri |> List.map query } in @@ -872,19 +872,19 @@ module Url = struct (scheme ~ssl:true, data) | Some "file" -> let scheme = File {path= Uri.path_unencoded uri} in - (scheme, {data with uri= "/"}) + (scheme, {data with path= "/"}) | _ -> failwith "unsupported URI scheme" with e -> fail "%s: can't parse '%s': %s" __FUNCTION__ url (Printexc.to_string e) - let data_to_string {uri; query_params= params} = + let data_to_string {path; query_params= params} = let kvpairs x = String.concat "&" (List.map (fun (k, v) -> urlencode k ^ "=" ^ urlencode v) x) in let params = if params = [] then "" else "?" ^ kvpairs params in - uri ^ params + path ^ params let to_string scheme = let query (k, v) = (k, [v]) in @@ -893,7 +893,7 @@ module Url = struct | File {path}, {query_params= params; _} -> Uri.make ~scheme:"file" ~path ~query:(List.map query params) () |> Uri.to_string - | Http h, {uri; query_params= params} -> + | Http h, {path; query_params= params} -> let auth = match h.auth with | Some (Basic (username, password)) -> @@ -905,16 +905,16 @@ module Url = struct in Uri.make ~scheme:(if h.ssl then "https" else "http") - ~host:h.host ?port:h.port ?userinfo:auth ~path:uri + ~host:h.host ?port:h.port ?userinfo:auth ~path ~query:(List.map query params) () |> Uri.to_string in debug "%s: %s" __FUNCTION__ str ; str - let get_uri (_scheme, data) = data.uri + let get_path (_scheme, data) = data.path - let set_uri (scheme, data) u = (scheme, {data with uri= u}) + let set_path (scheme, data) u = (scheme, {data with path= u}) let get_query_params (_scheme, data) = data.query_params diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index e0c972586c..a5051d4061 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -72,7 +72,7 @@ end module Request : sig type t = { m: method_t - ; uri: string + ; path: string ; query: (string * string) list ; version: string ; frame: bool @@ -254,7 +254,7 @@ module Url : sig type scheme = Http of http | File of file - type data = {uri: string; query_params: (string * string) list} + type data = {path: string; query_params: (string * string) list} type t = scheme * data @@ -264,9 +264,9 @@ module Url : sig val to_string : t -> string - val get_uri : t -> string + val get_path : t -> string - val set_uri : t -> string -> t + val set_path : t -> string -> t val get_query_params : t -> (string * string) list diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 4db3df81d2..7c5ecc393d 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -103,7 +103,7 @@ module Helper = struct include Tracing.Propagator.Make (struct include Tracing_propagator.Propagator.Http - let name_span req = req.Http.Request.uri + let name_span req = req.Http.Request.path end) end @@ -233,7 +233,7 @@ let response_redirect ?req s dest = in Unixext.really_write_string s (Http.Response.to_wire_string res) -let response_file ?mime_content_type ~hsts_time s file = +let response_file ?mime_content_type ?download_name ~hsts_time s file = let size = (Unix.LargeFile.stat file).Unix.LargeFile.st_size in let keep_alive = [(Http.Hdr.connection, "keep-alive")] in let hsts_header = @@ -248,9 +248,17 @@ let response_file ?mime_content_type ~hsts_time s file = ~some:(fun ty -> [(Hdr.content_type, ty)]) mime_content_type in + let content_disposition = + let hdr = Hdr.content_disposition in + let typ = "attachment" in + Option.fold ~none:[] + ~some:(fun name -> [(hdr, Printf.sprintf {|%s; filename="%s"|} typ name)]) + download_name + in let res = Http.Response.make ~version:"1.1" - ~headers:(List.concat [keep_alive; hsts_header; mime_header]) + ~headers: + (List.concat [keep_alive; hsts_header; mime_header; content_disposition]) ~length:size "200" "OK" in Unixext.with_file file [Unix.O_RDONLY] 0 (fun f -> @@ -302,13 +310,13 @@ module Server = struct let empty default_context = {handlers= MethodMap.empty; default_context} - let add_handler x ty uri handler = + let add_handler x ty path handler = let existing = Option.value (MethodMap.find_opt ty x.handlers) ~default:Radix_tree.empty in x.handlers <- MethodMap.add ty - (Radix_tree.insert uri {(TE.empty ()) with TE.handler} existing) + (Radix_tree.insert path {(TE.empty ()) with TE.handler} existing) x.handlers let find_stats x m uri = @@ -378,7 +386,7 @@ let read_request_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length fd = (* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *) let uri_t = Uri.of_string uri in if uri_t = Uri.empty then raise Http_parse_failure ; - let uri = Uri.path_unencoded uri_t in + let path = Uri.path_unencoded uri_t in let query = Uri.query uri_t |> kvlist_flatten in let m = Http.method_t_of_string meth in let version = @@ -388,7 +396,7 @@ let read_request_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length fd = (String.length x - String.length prefix) in let close = version = "1.0" in - (true, {req with m; uri; query; version; close}) + (true, {req with m; path; query; version; close}) | _ -> raise Http_parse_failure else @@ -517,7 +525,7 @@ let handle_one (x : 'a Server.t) ss context req = let empty = TE.empty () in let te = Option.value ~default:empty - (Radix_tree.longest_prefix req.Request.uri method_map) + (Radix_tree.longest_prefix req.Request.path method_map) in let@ _ = Tracing.with_child_trace span ~name:"handler" in te.TE.handler req ss context ; diff --git a/ocaml/libs/http-lib/http_svr.mli b/ocaml/libs/http-lib/http_svr.mli index 101479d100..61b49e7b3f 100644 --- a/ocaml/libs/http-lib/http_svr.mli +++ b/ocaml/libs/http-lib/http_svr.mli @@ -109,6 +109,7 @@ val response_redirect : ?req:Http.Request.t -> Unix.file_descr -> string -> unit val response_file : ?mime_content_type:string + -> ?download_name:string -> hsts_time:int -> Unix.file_descr -> string diff --git a/ocaml/libs/http-lib/http_test.ml b/ocaml/libs/http-lib/http_test.ml index ebb7c50566..64910b9a38 100644 --- a/ocaml/libs/http-lib/http_test.ml +++ b/ocaml/libs/http-lib/http_test.ml @@ -170,7 +170,7 @@ module URL = struct let open Http.Url in [ ( "file:/var/xapi/storage" - , (File {path= "/var/xapi/storage"}, {uri= "/"; query_params= []}) + , (File {path= "/var/xapi/storage"}, {path= "/"; query_params= []}) ) ; ( "http://root:foo@localhost" , ( Http @@ -180,17 +180,17 @@ module URL = struct ; host= "localhost" ; port= None } - , {uri= "/"; query_params= []} + , {path= "/"; query_params= []} ) ) ; ( "https://google.com/gmail" , ( Http {auth= None; ssl= true; host= "google.com"; port= None} - , {uri= "/gmail"; query_params= []} + , {path= "/gmail"; query_params= []} ) ) ; ( "https://xapi.xen.org/services/SM" , ( Http {auth= None; ssl= true; host= "xapi.xen.org"; port= None} - , {uri= "/services/SM"; query_params= []} + , {path= "/services/SM"; query_params= []} ) ) ; ( "https://root:foo@xapi.xen.org:1234/services/SM" @@ -201,12 +201,12 @@ module URL = struct ; host= "xapi.xen.org" ; port= Some 1234 } - , {uri= "/services/SM"; query_params= []} + , {path= "/services/SM"; query_params= []} ) ) ; ( "https://xapi.xen.org/services/SM?foo=bar" , ( Http {auth= None; ssl= true; host= "xapi.xen.org"; port= None} - , {uri= "/services/SM"; query_params= [("foo", "bar")]} + , {path= "/services/SM"; query_params= [("foo", "bar")]} ) ) ] @@ -221,7 +221,7 @@ module URL = struct let data = "https://xapi.xen.org/services/SM?foo=bar" in let expected = "https://xapi.xen.org/services/SM/data?foo=bar" in let u = Http.Url.of_string data in - let u' = Http.Url.set_uri u (Http.Url.get_uri u ^ "/data") in + let u' = Http.Url.set_path u (Http.Url.get_path u ^ "/data") in let actual = Http.Url.to_string u' in Alcotest.(check string) data expected actual diff --git a/ocaml/libs/http-lib/mime.ml b/ocaml/libs/http-lib/mime.ml deleted file mode 100644 index e8dabaca13..0000000000 --- a/ocaml/libs/http-lib/mime.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* - * Copyright (C) 2006-2009 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. - *) -(* MIME handling for HTTP responses *) - -open Printf - -(** Map extension to MIME type *) -type t = (string, string) Hashtbl.t - -let lowercase = Astring.String.Ascii.lowercase - -(** Parse an Apache-format mime.types file and return mime_t *) -let mime_of_file file = - let h = Hashtbl.create 1024 in - Xapi_stdext_unix.Unixext.readfile_line - (fun line -> - if not (Astring.String.is_prefix ~affix:"#" line) then - match Astring.String.fields ~empty:false line with - | [] | [_] -> - () - | mime :: exts -> - List.iter (fun e -> Hashtbl.add h (lowercase e) mime) exts - ) - file ; - h - -let string_of_mime m = - String.concat "," (Hashtbl.fold (fun k v a -> sprintf "{%s:%s}" k v :: a) m []) - -let default_mime = "text/plain" - -(** Map a file extension to a MIME type *) -let mime_of_ext mime ext = - Option.value (Hashtbl.find_opt mime (lowercase ext)) ~default:default_mime - -(** Figure out a mime type from a full filename *) -let mime_of_file_name mime fname = - (* split filename into dot components *) - let ext = - match Astring.String.cuts ~sep:"." fname with - | [] | [_] -> - "" - | x -> - List.hd (List.rev x) - in - mime_of_ext mime ext diff --git a/ocaml/libs/http-lib/ws_helpers.ml b/ocaml/libs/http-lib/ws_helpers.ml index c8d470101d..5294255262 100644 --- a/ocaml/libs/http-lib/ws_helpers.ml +++ b/ocaml/libs/http-lib/ws_helpers.ml @@ -21,10 +21,10 @@ (* Websockets helper functions *) -(* A couple of short helper functions for upgrading an HTTP - * connection to a websockets connection +(* A couple of short helper functions for upgrading an HTTP + * connection to a websockets connection * See for reference: - * http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-17 + * http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-17 *) type protocol = Hixie76 | Hybi10 @@ -123,7 +123,7 @@ let hixie_v76_upgrade req s = try Some (find_header headers "sec-websocket-protocol") with _ -> None in let real_uri = - req.Http.Request.uri + req.Http.Request.path ^ "?" ^ String.concat "&" (List.map diff --git a/ocaml/libs/log/dune b/ocaml/libs/log/dune index 42e5f66411..8b4c2a1d51 100644 --- a/ocaml/libs/log/dune +++ b/ocaml/libs/log/dune @@ -11,6 +11,7 @@ logs threads.posix xapi-backtrace + unix ) (wrapped false) ) diff --git a/ocaml/libs/log/test/dune b/ocaml/libs/log/test/dune index 299a6155ea..75fbbad755 100644 --- a/ocaml/libs/log/test/dune +++ b/ocaml/libs/log/test/dune @@ -1,6 +1,6 @@ (executable (name log_test) - (libraries log xapi-stdext-threads threads.posix xapi-backtrace)) + (libraries log threads.posix xapi-backtrace)) (cram (package xapi-log) diff --git a/ocaml/libs/log/test/log_test.ml b/ocaml/libs/log/test/log_test.ml index 53d5cf0dde..b493b18d42 100644 --- a/ocaml/libs/log/test/log_test.ml +++ b/ocaml/libs/log/test/log_test.ml @@ -6,12 +6,16 @@ let a = [||] let buggy () = a.(1) <- 0 +let with_lock mutex f = + let finally () = Mutex.unlock mutex in + Mutex.lock mutex ; Fun.protect ~finally f + let () = Printexc.record_backtrace true ; Debug.log_to_stdout () ; () |> Debug.with_thread_associated "main" @@ fun () -> - try Xapi_stdext_threads.Threadext.Mutex.execute m buggy + try with_lock m buggy with e -> D.log_backtrace e ; D.warn "Got exception: %s" (Printexc.to_string e) diff --git a/ocaml/libs/log/test/log_test.t b/ocaml/libs/log/test/log_test.t index 2d7b5fa141..ae296392b8 100644 --- a/ocaml/libs/log/test/log_test.t +++ b/ocaml/libs/log/test/log_test.t @@ -1,9 +1,23 @@ - $ ./log_test.exe | sed -re 's/[0-9]+T[0-9:.]+Z//' - [|error||0 |main|backtrace] Raised Invalid_argument("index out of bounds") - [|error||0 |main|backtrace] 1/4 log_test.exe Raised at file ocaml/libs/log/test/log_test.ml, line 7 - [|error||0 |main|backtrace] 2/4 log_test.exe Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 24 - [|error||0 |main|backtrace] 3/4 log_test.exe Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 39 - [|error||0 |main|backtrace] 4/4 log_test.exe Called from file ocaml/libs/log/test/log_test.ml, line 14 - [|error||0 |main|backtrace] - [| warn||0 |main|log_test.ml] Got exception: Invalid_argument("index out of bounds") +The log_test executable produces a backtrace on purpose, on x86_64, and with +the datetimes removed, it looks like this: +$ ./log_test.exe | sed -re 's/[0-9]+T[0-9:.]+Z//' +[|error||0 |main|backtrace] Raised Invalid_argument("index out of bounds") +[|error||0 |main|backtrace] 1/4 log_test.exe Raised at file ocaml/libs/log/test/log_test.ml, line 7 +[|error||0 |main|backtrace] 2/4 log_test.exe Called from file fun.ml, line 33 +[|error||0 |main|backtrace] 3/4 log_test.exe Called from file fun.ml, line 38 +[|error||0 |main|backtrace] 4/4 log_test.exe Called from file ocaml/libs/log/test/log_test.ml, line 18 +[|error||0 |main|backtrace] +[| warn||0 |main|log_test.ml] Got exception: Invalid_argument("index out of bounds") +and on aarch64: +[|error||0 |main|backtrace] Raised Invalid_argument("index out of bounds") +[|error||0 |main|backtrace] 1/3 log_test.exe Raised at file ocaml/libs/log/test/log_test.ml, line 7 +[|error||0 |main|backtrace] 2/3 log_test.exe Called from file fun.ml, line 38 +[|error||0 |main|backtrace] 3/3 log_test.exe Called from file ocaml/libs/log/test/log_test.ml, line 18 +[|error||0 |main|backtrace] +[| warn||0 |main|log_test.ml] Got exception: Invalid_argument("index out of bounds") + + $ ./log_test.exe | grep "main|backtrace" -c | xargs -I _ sh -c "test 5 -eq _ || test 6 -eq _" + $ ./log_test.exe | grep "log_test.exe" -c | xargs -I _ sh -c "test 3 -eq _ || test 4 -eq _" + $ ./log_test.exe | grep "ocaml/libs/log/test/log_test.ml" -c + 2 diff --git a/ocaml/libs/open-uri/dune b/ocaml/libs/open-uri/dune index d5291c77fd..4bf141d3a5 100644 --- a/ocaml/libs/open-uri/dune +++ b/ocaml/libs/open-uri/dune @@ -5,6 +5,7 @@ cohttp safe-resources stunnel + unix uri xapi-backtrace xapi-consts diff --git a/ocaml/libs/pciutil/dune b/ocaml/libs/pciutil/dune index 23353d9bb8..44240eff3d 100644 --- a/ocaml/libs/pciutil/dune +++ b/ocaml/libs/pciutil/dune @@ -3,6 +3,7 @@ (public_name pciutil) (libraries threads + unix xapi-stdext-unix ) ) diff --git a/ocaml/libs/pciutil/pciutil.ml b/ocaml/libs/pciutil/pciutil.ml index ca63fb5aa1..757ea0ce0e 100644 --- a/ocaml/libs/pciutil/pciutil.ml +++ b/ocaml/libs/pciutil/pciutil.ml @@ -25,13 +25,14 @@ let parse_from file vendor device = let vendor_str = ref (unknown_vendor vendor) and device_str = ref (unknown_device device) in (* CA-26771: As we parse the file we keep track of the current vendor. - When we find a device match we only accept it if it's from the right vendor; it doesn't make - sense to pair vendor 2's device with vendor 1. *) + When we find a device match we only accept it if it's from the right + vendor; it doesn't make sense to pair vendor 2's device with vendor 1. *) let current_xvendor = ref "" in Unixext.readfile_line (fun line -> + (* ignore subvendors/subdevices, blank lines and comments *) if line = "" || line.[0] = '#' || (line.[0] = '\t' && line.[1] = '\t') - then (* ignore subvendors/subdevices, blank lines and comments *) + then () else if line.[0] = '\t' then ( if diff --git a/ocaml/libs/resources/dune b/ocaml/libs/resources/dune index 6fa2d3d2ec..358d7c799c 100644 --- a/ocaml/libs/resources/dune +++ b/ocaml/libs/resources/dune @@ -6,6 +6,7 @@ xapi-backtrace fmt threads.posix + unix xapi-stdext-pervasives xapi-stdext-threads ) diff --git a/ocaml/libs/resources/test/dune b/ocaml/libs/resources/test/dune index 15a20f0bfa..d094fb54fd 100644 --- a/ocaml/libs/resources/test/dune +++ b/ocaml/libs/resources/test/dune @@ -7,5 +7,6 @@ logs logs.fmt alcotest + unix ) ) diff --git a/ocaml/libs/sexpr/dune b/ocaml/libs/sexpr/dune index 77653c2abc..6490da85be 100644 --- a/ocaml/libs/sexpr/dune +++ b/ocaml/libs/sexpr/dune @@ -1,22 +1,10 @@ -(menhir (modules sExprParser)) +(menhir + (modules sExprParser)) (ocamllex sExprLexer) (library - (name sexpr) - (public_name sexpr) - (wrapped false) - (modules (:standard \ sexprpp)) - (libraries - astring - ) -) - -(executable - (modes exe) - (name sexprpp) - (modules sexprpp) - (libraries - sexpr - ) -) + (name sexpr) + (public_name sexpr) + (wrapped false) + (libraries astring)) diff --git a/ocaml/libs/sexpr/sExpr.ml b/ocaml/libs/sexpr/sExpr.ml index 488142898c..3637ac6abf 100644 --- a/ocaml/libs/sexpr/sExpr.ml +++ b/ocaml/libs/sexpr/sExpr.ml @@ -23,7 +23,7 @@ let unescape_buf buf s = if Astring.String.fold_left aux false s then Buffer.add_char buf '\\' -let is_escape_char = function '\\' | '"' | '\'' -> true | _ -> false +let is_escape_char = function '\\' | '\'' -> true | _ -> false (* XXX: This escapes "'c'" and "\'c\'" to "\\'c\\'". * They are both unescaped as "'c'". They have been ported @@ -32,26 +32,22 @@ let is_escape_char = function '\\' | '"' | '\'' -> true | _ -> false * - Astring.String.Ascii.escape_string * - Astring.String.Ascii.unescape * that have guaranteed invariants and optimised performances *) -let escape s = +let escape_buf escaped s = let open Astring in - if String.exists is_escape_char s then ( - let escaped = Buffer.create (String.length s + 10) in + if String.exists is_escape_char s then String.iter (fun c -> match c with | '\\' -> Buffer.add_string escaped "\\\\" - | '"' -> - Buffer.add_string escaped "\\\"" | '\'' -> Buffer.add_string escaped "\\\'" | _ -> Buffer.add_char escaped c ) - s ; - Buffer.contents escaped - ) else - s + s + else + Buffer.add_string escaped s let unescape s = if String.contains s '\\' then ( @@ -82,22 +78,7 @@ let string_of sexpr = Buffer.add_char buf ')' | Symbol s | String s -> Buffer.add_string buf "\'" ; - Buffer.add_string buf (escape s) ; + escape_buf buf s ; Buffer.add_string buf "\'" in __string_of_rec sexpr ; Buffer.contents buf - -let rec output_fmt ff = function - | Node list -> - let rec aux ?(first = true) = function - | [] -> - () - | h :: t when first -> - output_fmt ff h ; aux ~first:false t - | h :: t -> - Format.fprintf ff "@;<1 2>%a" output_fmt h ; - aux ~first t - in - Format.fprintf ff "@[(" ; aux list ; Format.fprintf ff ")@]" - | Symbol s | String s -> - Format.fprintf ff "\"%s\"" (escape s) diff --git a/ocaml/libs/sexpr/sExpr.mli b/ocaml/libs/sexpr/sExpr.mli index e7ab5c68a1..7bf1c61812 100644 --- a/ocaml/libs/sexpr/sExpr.mli +++ b/ocaml/libs/sexpr/sExpr.mli @@ -16,5 +16,3 @@ type t = Node of t list | Symbol of string | String of string val mkstring : string -> t val string_of : t -> string - -val output_fmt : Format.formatter -> t -> unit diff --git a/ocaml/libs/sexpr/sexprpp.ml b/ocaml/libs/sexpr/sexprpp.ml deleted file mode 100644 index 109ee57716..0000000000 --- a/ocaml/libs/sexpr/sexprpp.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* - * Copyright (C) 2006-2009 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. - *) -let lexer = Lexing.from_channel stdin - -let _ = - match Sys.argv with - | [|_; "-nofmt"|] -> - let start_time = Sys.time () in - let sexpr = SExprParser.expr SExprLexer.token lexer in - let parse_time = Sys.time () in - let s = SExpr.string_of sexpr in - let print_time = Sys.time () in - Printf.fprintf stderr "Parse time: %f\nPrint time: %f\n%!" - (parse_time -. start_time) (print_time -. parse_time) ; - print_endline s - | _ -> - let sexpr = SExprParser.expr SExprLexer.token lexer in - let ff = Format.formatter_of_out_channel stdout in - SExpr.output_fmt ff sexpr ; Format.fprintf ff "@." diff --git a/ocaml/libs/sexpr/test/dune b/ocaml/libs/sexpr/test/dune index 78aa0ac605..2e8cd323f2 100644 --- a/ocaml/libs/sexpr/test/dune +++ b/ocaml/libs/sexpr/test/dune @@ -2,4 +2,4 @@ (name test_sexpr) (package sexpr) (modules test_sexpr) - (libraries sexpr astring rresult qcheck-core alcotest threads.posix)) + (libraries sexpr astring rresult qcheck-core alcotest threads.posix unix)) diff --git a/ocaml/libs/stunnel/dune b/ocaml/libs/stunnel/dune index fedd5afc05..776f4a8c7e 100644 --- a/ocaml/libs/stunnel/dune +++ b/ocaml/libs/stunnel/dune @@ -7,11 +7,13 @@ forkexec safe-resources threads.posix + unix uuid xapi-consts xapi-inventory xapi-log xapi-stdext-pervasives + xapi-stdext-std xapi-stdext-threads xapi-stdext-unix ) diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index be865a216d..5a88f8c107 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -27,6 +27,8 @@ open Safe_resources let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute +let list_drop = Xapi_stdext_std.Listext.List.drop + (* Disable debug-level logging but leave higher-priority enabled. It would be * better to handle this sort of configuration in the Debug module itself. *) @@ -93,17 +95,6 @@ let unlocked_gc () = !index "" ) ) ; - (* Split a list at the given index to give a pair of lists. - * From Xapi_stdext_std.Listext *) - let rec chop i l = - match (i, l) with - | 0, l -> - ([], l) - | i, h :: t -> - (fun (fr, ba) -> (h :: fr, ba)) (chop (i - 1) t) - | _ -> - invalid_arg "chop" - in let all_ids = Tbl.fold !stunnels (fun k _ acc -> k :: acc) [] in let to_gc = ref [] in (* Find the ones which are too old *) @@ -134,8 +125,8 @@ let unlocked_gc () = List.filter (fun (idx, _) -> not (List.mem idx !to_gc)) times' in (* Sort into descending order of donation time, ie youngest first *) - let times' = List.sort (fun x y -> compare (fst y) (fst x)) times' in - let _youngest, oldest = chop max_stunnel times' in + let times' = List.sort (fun (_, x) (_, y) -> Float.compare y x) times' in + let oldest = list_drop max_stunnel times' in let oldest_ids = List.map fst oldest in List.iter (fun x -> diff --git a/ocaml/libs/tgroup/dune b/ocaml/libs/tgroup/dune index cff00ee115..6c152a5c2e 100644 --- a/ocaml/libs/tgroup/dune +++ b/ocaml/libs/tgroup/dune @@ -2,7 +2,7 @@ (name tgroup) (modules tgroup) (public_name tgroup) - (libraries xapi-log xapi-stdext-unix xapi-stdext-std)) + (libraries unix xapi-log xapi-stdext-unix xapi-stdext-std)) (test (name test_tgroup) diff --git a/ocaml/libs/timeslice/timeslice.ml b/ocaml/libs/timeslice/timeslice.ml index c414b321d6..55b888871d 100644 --- a/ocaml/libs/timeslice/timeslice.ml +++ b/ocaml/libs/timeslice/timeslice.ml @@ -65,7 +65,8 @@ let periodic = let set ?(sampling_rate = 1e-4) interval = Atomic.set yield_interval (Mtime.Span.of_float_ns @@ (interval *. 1e9) |> Option.get) ; - Gc.Memprof.start ~sampling_rate ~callstack_size:0 periodic + let _ = Gc.Memprof.start ~sampling_rate ~callstack_size:0 periodic in + () let clear () = Gc.Memprof.stop () ; diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index b941a765ce..ef48705283 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -1,7 +1,7 @@ (library (name tracing) (modules tracing) - (libraries astring re uri yojson xapi-log xapi-stdext-threads threads.posix) + (libraries astring re uri yojson xapi-log xapi-stdext-threads threads.posix unix) (preprocess (pps ppx_deriving_yojson)) (public_name xapi-tracing)) @@ -21,6 +21,7 @@ rresult tracing threads.posix + unix uri xapi-log xapi-open-uri diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index c1cdc33692..78ba3bc3ab 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -222,6 +222,8 @@ module TraceContext = struct let empty = {traceparent= None; baggage= None} + let depth_key = "span.depth" + let with_traceparent traceparent ctx = {ctx with traceparent} let with_baggage baggage ctx = {ctx with baggage} @@ -230,6 +232,20 @@ module TraceContext = struct let baggage_of ctx = ctx.baggage + let baggage_depth_of ctx = + Option.bind (baggage_of ctx) (List.assoc_opt depth_key) + |> Option.value ~default:"1" + |> int_of_string + + let update_with_baggage k v ctx = + let new_baggage = + baggage_of ctx + |> Option.value ~default:[] + |> List.remove_assoc k + |> List.cons (k, v) + in + with_baggage (Some new_baggage) ctx + let parse input = let open Astring.String in let trim_pair (key, value) = (trim key, trim value) in @@ -322,22 +338,36 @@ module Span = struct let start ?(attributes = Attributes.empty) ?(trace_context : TraceContext.t option) ~name ~parent ~span_kind () = - let trace_id, extra_context = + let trace_id, extra_context, depth = match parent with | None -> - (Trace_id.make (), TraceContext.empty) + (Trace_id.make (), TraceContext.empty, 1) | Some span_parent -> - (span_parent.context.trace_id, span_parent.context.trace_context) + ( span_parent.context.trace_id + , span_parent.context.trace_context + , TraceContext.baggage_depth_of span_parent.context.trace_context + 1 + ) in let span_id = Span_id.make () in + let extra_context_with_depth = + TraceContext.( + update_with_baggage depth_key (string_of_int depth) extra_context + ) + in let context : SpanContext.t = - {trace_id; span_id; trace_context= extra_context} + {trace_id; span_id; trace_context= extra_context_with_depth} in let context = - (* If trace_context is provided to the call, override any inherited trace context. *) - trace_context - |> Option.fold ~none:context - ~some:(Fun.flip SpanContext.with_trace_context context) + (* If trace_context is provided to the call, override any inherited trace + context except span.depth which should still be maintained. *) + match trace_context with + | Some tc -> + let tc_with_depth = + TraceContext.(update_with_baggage depth_key (string_of_int depth) tc) + in + SpanContext.with_trace_context tc_with_depth context + | None -> + context in (* Using gettimeofday over Mtime as it is better for sharing timestamps between the systems *) let begin_time = Unix.gettimeofday () in @@ -473,6 +503,11 @@ module Spans = struct let set_max_traces x = Atomic.set max_traces x + (* Default is much larger than the largest current traces, so effectively off *) + let max_depth = Atomic.make 100 + + let set_max_depth x = Atomic.set max_depth x + let finished_spans = Atomic.make ([], 0) let span_hashtbl_is_empty () = TraceMap.is_empty (Atomic.get spans) @@ -713,12 +748,18 @@ module Tracer = struct let get_tracer ~name:_ = TracerProvider.get_current () let span_of_span_context context name : Span.t = + let tc = SpanContext.context_of_span_context context in + let new_depth = TraceContext.baggage_depth_of tc in + let new_tc = + TraceContext.(update_with_baggage depth_key (string_of_int new_depth) tc) + in + let context = SpanContext.with_trace_context new_tc context in { context ; status= {status_code= Status.Unset; _description= None} ; name ; parent= None - ; span_kind= SpanKind.Client (* This will be the span of the client call*) + ; span_kind= SpanKind.Client (* This will be the span of the client call *) ; begin_time= Unix.gettimeofday () ; end_time= None ; links= [] @@ -730,10 +771,32 @@ module Tracer = struct ?(span_kind = SpanKind.Internal) ~name ~parent () : (Span.t option, exn) result = let open TracerProvider in - (* Do not start span if the TracerProvider is disabled*) + let parent_depth = + Option.fold ~none:1 + ~some:(fun parent -> + parent.Span.context + |> SpanContext.context_of_span_context + |> TraceContext.baggage_depth_of + ) + parent + in + (* Do not start span if the TracerProvider is disabled *) if not t.enabled then + ok_none (* Do not start span if the max depth has been reached *) + else if parent_depth >= Atomic.get Spans.max_depth then ( + let parent_trace_id = + Option.fold ~none:"None" + ~some:(fun p -> + p.Span.context + |> SpanContext.span_id_of_span_context + |> Span_id.to_string + ) + parent + in + debug "Max_span_depth limit reached, not creating span %s (parent %s)" + name parent_trace_id ; ok_none - else + ) else let attributes = Attributes.merge_into t.attributes attributes in let span = Span.start ~attributes ?trace_context ~name ~parent ~span_kind () @@ -750,8 +813,17 @@ module Tracer = struct |> Spans.remove_from_spans |> Option.map (fun existing_span -> let old_context = Span.get_context existing_span in + let parent_trace_context = Span.get_trace_context parent in + let new_depth = + TraceContext.baggage_depth_of parent_trace_context + 1 + in let new_context : SpanContext.t = - let trace_context = span.Span.context.trace_context in + let trace_context = + TraceContext.( + update_with_baggage depth_key (string_of_int new_depth) + span.Span.context.trace_context + ) + in SpanContext.context (SpanContext.trace_id_of_span_context parent.context) old_context.span_id @@ -759,7 +831,6 @@ module Tracer = struct in let updated_span = {existing_span with parent= Some parent} in let updated_span = {updated_span with context= new_context} in - let () = Spans.add_to_spans ~span:updated_span in updated_span ) @@ -792,10 +863,14 @@ end let enable_span_garbage_collector ?(timeout = 86400.) () = Spans.GC.initialise_thread ~timeout -let with_tracing ?(attributes = []) ?(parent = None) ?trace_context ~name f = +let with_tracing ?(attributes = []) ?(parent = None) ?span_kind ?trace_context + ~name f = let tracer = Tracer.get_tracer ~name in if tracer.enabled then ( - match Tracer.start ~tracer ?trace_context ~attributes ~name ~parent () with + match + Tracer.start ?span_kind ~tracer ?trace_context ~attributes ~name ~parent + () + with | Ok span -> ( try let result = f span in @@ -922,7 +997,15 @@ module Propagator = struct let trace_context' = TraceContext.with_traceparent (Some traceparent) trace_context in - let carrier' = P.inject_into trace_context' carrier in + let new_depth = + TraceContext.baggage_depth_of trace_context' + 1 |> string_of_int + in + let trace_context'' = + TraceContext.( + update_with_baggage depth_key new_depth trace_context' + ) + in + let carrier' = P.inject_into trace_context'' carrier in f carrier' | _ -> f carrier diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index 262acb52f2..ec33f4ac5f 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -165,6 +165,8 @@ module Spans : sig val set_max_traces : int -> unit + val set_max_depth : int -> unit + val span_count : unit -> int val since : unit -> Span.t list * int @@ -190,12 +192,12 @@ module Tracer : sig -> (Span.t option, exn) result val update_span_with_parent : Span.t -> Span.t option -> Span.t option - (**[update_span_with_parent s p] returns [Some span] where [span] is an + (**[update_span_with_parent s p] returns [Some span] where [span] is an updated verison of the span [s]. - If [p] is [Some parent], [span] is a child of [parent], otherwise it is the + If [p] is [Some parent], [span] is a child of [parent], otherwise it is the original [s]. - - If the span [s] is finished or is no longer considered an on-going span, + + If the span [s] is finished or is no longer considered an on-going span, returns [None]. *) @@ -209,7 +211,7 @@ module Tracer : sig val finished_span_hashtbl_is_empty : unit -> bool end -(** [TracerProvider] module provides ways to intereact with the tracer providers. +(** [TracerProvider] module provides ways to intereact with the tracer providers. *) module TracerProvider : sig (** Type that represents a tracer provider.*) @@ -222,7 +224,7 @@ module TracerProvider : sig -> name_label:string -> uuid:string -> unit - (** [create ~enabled ~attributes ~endpoints ~name_label ~uuid] initializes a + (** [create ~enabled ~attributes ~endpoints ~name_label ~uuid] initializes a tracer provider based on the following parameters: [enabled], [attributes], [endpoints], [name_label], and [uuid]. *) @@ -234,17 +236,17 @@ module TracerProvider : sig -> unit -> unit (** [set ?enabled ?attributes ?endpoints ~uuid ()] updates the tracer provider - identified by the given [uuid] with the new configuration paremeters: - [enabled], [attributes], and [endpoints]. - + identified by the given [uuid] with the new configuration paremeters: + [enabled], [attributes], and [endpoints]. + If any of the configuration parameters are missing, the old ones are kept. - + Raises [Failure] if there are no tracer provider with the given [uuid]. *) val destroy : uuid:string -> unit - (** [destroy ~uuid] destroys the tracer provider with the given [uuid]. + (** [destroy ~uuid] destroys the tracer provider with the given [uuid]. If there are no tracer provider with the given [uuid], it does nothing. *) @@ -269,6 +271,7 @@ val enable_span_garbage_collector : ?timeout:float -> unit -> unit val with_tracing : ?attributes:(string * string) list -> ?parent:Span.t option + -> ?span_kind:SpanKind.t -> ?trace_context:TraceContext.t -> name:string -> (Span.t option -> 'a) @@ -288,24 +291,24 @@ val get_observe : unit -> bool val validate_attribute : string * string -> bool -(** [EnvHelpers] module is a helper module for the tracing library to easily - transition back and forth between a string list of environment variables to - a traceparent. +(** [EnvHelpers] module is a helper module for the tracing library to easily + transition back and forth between a string list of environment variables to + a traceparent. *) module EnvHelpers : sig val traceparent_key : string (** [traceparent_key] is a constant the represents the key of the traceparent - environment variable. + environment variable. *) val of_traceparent : string option -> string list (** [of_traceparent traceparent_opt] returns a singleton list consisting of a - envirentment variable with the key [traceparent_key] and value [v] if + envirentment variable with the key [traceparent_key] and value [v] if [traceparent_opt] is [Some v]. Otherwise, returns an empty list. *) val to_traceparent : string list -> string option - (** [to_traceparent env_var_lst] returns [Some v] where v is the value of the - environmental variable coresponding to the key [traceparent_key] from a + (** [to_traceparent env_var_lst] returns [Some v] where v is the value of the + environmental variable coresponding to the key [traceparent_key] from a string list of environmental variables [env_var_lst]. If there is no such evironmental variable in the list, it returns [None]. *) @@ -314,7 +317,7 @@ module EnvHelpers : sig (** [of_span span] returns a singleton list consisting of a envirentment variable with the key [traceparent_key] and value [v], where [v] is traceparent representation of span [s] (if [span] is [Some s]). - + If [span] is [None], it returns an empty list. *) end diff --git a/ocaml/libs/tracing/tracing_export.ml b/ocaml/libs/tracing/tracing_export.ml index 5844d389e1..352d5d488e 100644 --- a/ocaml/libs/tracing/tracing_export.ml +++ b/ocaml/libs/tracing/tracing_export.ml @@ -24,6 +24,10 @@ let export_interval = ref 30. let set_export_interval t = export_interval := t +let export_chunk_size = Atomic.make 10000 + +let set_export_chunk_size x = Atomic.set export_chunk_size x + let host_id = ref "localhost" let set_host_id id = host_id := id @@ -278,8 +282,8 @@ module Destination = struct ] in let@ _ = - with_tracing ~trace_context:TraceContext.empty ~parent ~attributes - ~name + with_tracing ~span_kind:Server ~trace_context:TraceContext.empty + ~parent ~attributes ~name in all_spans |> Content.Json.ZipkinV2.content_of @@ -289,23 +293,48 @@ module Destination = struct with exn -> debug "Tracing: unable to export span : %s" (Printexc.to_string exn) + let rec span_info_chunks span_info batch_size = + let rec list_to_chunks_inner l n curr chunks = + if n = 0 then + if l <> [] then + list_to_chunks_inner l batch_size [] ((curr, batch_size) :: chunks) + else + (curr, batch_size) :: chunks + else + match l with + | [] -> + (curr, List.length curr) :: chunks + | h :: t -> + list_to_chunks_inner t (n - 1) (h :: curr) chunks + in + list_to_chunks_inner (fst span_info) batch_size [] [] + let flush_spans () = let ((_span_list, span_count) as span_info) = Spans.since () in let attributes = [("export.traces.count", string_of_int span_count)] in let@ parent = - with_tracing ~trace_context:TraceContext.empty ~parent:None ~attributes - ~name:"Tracing.flush_spans" + with_tracing ~span_kind:Server ~trace_context:TraceContext.empty + ~parent:None ~attributes ~name:"Tracing.flush_spans" in - TracerProvider.get_tracer_providers () - |> List.filter TracerProvider.get_enabled - |> List.concat_map TracerProvider.get_endpoints - |> List.iter (export_to_endpoint parent span_info) + let endpoints = + TracerProvider.get_tracer_providers () + |> List.filter TracerProvider.get_enabled + |> List.concat_map TracerProvider.get_endpoints + in + let span_info_chunks = + span_info_chunks span_info (Atomic.get export_chunk_size) + in + List.iter + (fun s_i -> List.iter (export_to_endpoint parent s_i) endpoints) + span_info_chunks let delay = Delay.make () (* Note this signal will flush the spans and terminate the exporter thread *) let signal () = Delay.signal delay + let wait_exit = Delay.make () + let create_exporter () = enable_span_garbage_collector () ; Thread.create @@ -319,7 +348,8 @@ module Destination = struct signaled := true ) ; flush_spans () - done + done ; + Delay.signal wait_exit ) () @@ -339,6 +369,12 @@ module Destination = struct ) end -let flush_and_exit = Destination.signal +let flush_and_exit ~max_wait () = + D.debug "flush_and_exit: signaling thread to export now" ; + Destination.signal () ; + if Delay.wait Destination.wait_exit max_wait then + D.info "flush_and_exit: timeout on span export" + else + D.debug "flush_and_exit: span export finished" let main = Destination.main diff --git a/ocaml/libs/tracing/tracing_export.mli b/ocaml/libs/tracing/tracing_export.mli index 3f8ca75002..0714b7107a 100644 --- a/ocaml/libs/tracing/tracing_export.mli +++ b/ocaml/libs/tracing/tracing_export.mli @@ -1,16 +1,16 @@ (* -* Copyright (C) 2024 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. -*) + * Copyright (C) 2024 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. + *) (** [Tracing_export] is a module dedicated for the creation and management of threads that export the tracing data. @@ -23,6 +23,13 @@ val set_export_interval : float -> unit Default is every [30.] seconds. *) +val set_export_chunk_size : int -> unit +(** [set_export_chunk_size size] sets the maximum number of finished spans that + can be exported in one chunk to [size]. + + Default is 10000 spans. + *) + val set_host_id : string -> unit (** [set_host_id id] sets the id of the host to [id]. @@ -85,9 +92,9 @@ module Destination : sig end end -val flush_and_exit : unit -> unit -(** [flush_and_exit ()] sends a signal to flush the finish spans and terminate - the exporter thread. +val flush_and_exit : max_wait:float -> unit -> unit +(** [flush_and_exit ~max_wait ()] sends a signal to flush the finish spans and terminate + the exporter thread. It waits at most [max_wait] seconds. *) val main : unit -> Thread.t diff --git a/ocaml/libs/vhd/disk/dune b/ocaml/libs/vhd/disk/dune index 83eabf18f6..f9447c3592 100644 --- a/ocaml/libs/vhd/disk/dune +++ b/ocaml/libs/vhd/disk/dune @@ -1,3 +1,3 @@ (library (name disk) - (libraries cstruct lwt lwt.unix)) + (libraries cstruct lwt lwt.unix unix)) diff --git a/ocaml/libs/vhd/vhd_format/dune b/ocaml/libs/vhd/vhd_format/dune index 5478cb41a4..bafac36518 100644 --- a/ocaml/libs/vhd/vhd_format/dune +++ b/ocaml/libs/vhd/vhd_format/dune @@ -2,5 +2,5 @@ (name vhd_format) (public_name vhd-format) (flags :standard -w -32-34-37) - (libraries stdlib-shims (re_export bigarray-compat) cstruct io-page rresult uuidm) + (libraries stdlib-shims (re_export bigarray-compat) cstruct io-page rresult unix uuidm) (preprocess (pps ppx_cstruct))) diff --git a/ocaml/libs/vhd/vhd_format/f.ml b/ocaml/libs/vhd/vhd_format/f.ml index ac29cf8e8a..79128d0035 100644 --- a/ocaml/libs/vhd/vhd_format/f.ml +++ b/ocaml/libs/vhd/vhd_format/f.ml @@ -3273,16 +3273,24 @@ functor open Raw let vhd t = - let include_block block_size index = + let include_block block_size index zero buffer = (* is the next data byte in the next block? *) let offset = Int64.(mul block_size (of_int index)) in F.lseek_data t.Raw.handle offset >>= fun data -> - return Int64.(add offset block_size > data) + if Int64.(add offset block_size > data) then + (* Check if the block is filled with zeros *) + really_read t.Raw.handle offset buffer >>= fun () -> + return (not (Cstruct.equal buffer zero)) + else + return false in let find_data_blocks ~blocks ~block_size = + (* Cstruct.create fills the buffer with 0 bytes *) + let zero = Cstruct.create (Int64.to_int block_size) in + let buffer = Memory.alloc (Int64.to_int block_size) in let rec loop index acc = if index < blocks then - include_block block_size index >>= function + include_block block_size index zero buffer >>= function | true -> loop (index + 1) (index :: acc) | false -> diff --git a/ocaml/libs/vhd/vhd_format_lwt/dune b/ocaml/libs/vhd/vhd_format_lwt/dune index 06f3707943..1d4b857a86 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/dune +++ b/ocaml/libs/vhd/vhd_format_lwt/dune @@ -1,7 +1,7 @@ (library (name vhd_format_lwt) (public_name vhd-format-lwt) - (libraries bigarray-compat cstruct-lwt cstruct lwt lwt.unix mirage-block vhd-format rresult) + (libraries bigarray-compat cstruct-lwt cstruct lwt lwt.unix mirage-block vhd-format rresult unix) (foreign_stubs (language c) (names blkgetsize64_stubs lseek64_stubs odirect_stubs))) diff --git a/ocaml/libs/vhd/vhd_format_lwt_test/dune b/ocaml/libs/vhd/vhd_format_lwt_test/dune index d8ece64012..390f816a45 100644 --- a/ocaml/libs/vhd/vhd_format_lwt_test/dune +++ b/ocaml/libs/vhd/vhd_format_lwt_test/dune @@ -2,4 +2,4 @@ (name parse_test) (package vhd-format-lwt) (libraries alcotest alcotest-lwt cstruct disk fmt io-page lwt lwt.unix vhd-format - vhd_format_lwt)) + vhd_format_lwt unix)) diff --git a/ocaml/libs/xapi-compression/dune b/ocaml/libs/xapi-compression/dune index e366bed171..c07999d967 100644 --- a/ocaml/libs/xapi-compression/dune +++ b/ocaml/libs/xapi-compression/dune @@ -6,6 +6,7 @@ forkexec threads safe-resources + unix xapi-log xapi-stdext-pervasives xapi-stdext-unix @@ -19,4 +20,4 @@ ; don't install this ; (public_name xapi-gzip) ; (package xapi-compression) - (libraries xapi_compression cmdliner)) + (libraries xapi_compression cmdliner unix)) diff --git a/ocaml/libs/xapi-inventory/lib/dune b/ocaml/libs/xapi-inventory/lib/dune index 905b47bfce..7f39303e6c 100644 --- a/ocaml/libs/xapi-inventory/lib/dune +++ b/ocaml/libs/xapi-inventory/lib/dune @@ -5,6 +5,7 @@ (libraries uuidm astring + unix xapi-stdext-unix xapi-stdext-threads threads.posix diff --git a/ocaml/libs/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml index b4c827705c..4f4c4d3cec 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -342,9 +342,9 @@ let rra_update rrd proc_pdp_st elapsed_pdp_st pdps = (* We assume that the data being given is of the form of a rate; that is, it's dependent on the time interval between updates. - Gauge and Absolute data sources are simply kept as is without any - time-based calculations, while Derive data sources will be changed according - to the time passed since the last measurement. (see CA-404597) *) + Gauge data sources are simply kept as is without any time-based + calculations, while Absolute and Derive data sources will be changed + according to the time passed since the last measurement. (see CA-404597) *) let process_ds_value ds value interval new_rrd = if interval > ds.ds_mrhb then nan @@ -361,8 +361,10 @@ let process_ds_value ds value interval new_rrd = let rate = match (ds.ds_ty, new_rrd) with - | Absolute, _ | Derive, true | Gauge, _ -> + | Derive, true | Gauge, _ -> value_raw + | Absolute, _ -> + value_raw /. interval | Derive, false -> ( match (ds.ds_last, value) with | VT_Int64 x, VT_Int64 y -> @@ -468,11 +470,23 @@ let ds_update rrd timestamp valuesandtransforms new_rrd = in (* Apply the transform after the raw value has been calculated *) let raw = apply_transform_function transform raw in + (* Make sure the values are not out of bounds after all the processing *) - if raw < ds.ds_min || raw > ds.ds_max then - (i, nan) - else - (i, raw) + match (ds.ds_ty, raw) with + | Derive, _ when raw > ds.ds_max && raw < ds.ds_max *. (1. +. 0.05) + -> + (* CA-411679: To handle deviations in CPU rates, Derive values + exceeding the maximum by up to 5% are capped at the maximum; + others are marked as unknown. This logic is specific to + Derive data sources because they represent rates derived + from differences over time, which can occasionally exceed + expected bounds due to measurement inaccuracies. *) + (i, ds.ds_max) + | (Derive | Gauge | Absolute), _ + when raw < ds.ds_min || raw > ds.ds_max -> + (i, nan) + | (Derive | Gauge | Absolute), _ -> + (i, raw) ) valuesandtransforms in diff --git a/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml b/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml index f016605848..5f84e76f19 100644 --- a/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml +++ b/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml @@ -147,46 +147,22 @@ let absolute_rrd = let absolute_rrd_CA_404597 () = let rra = rra_create CF_Average 100 1 0.5 in - let rra2 = rra_create CF_Average 100 10 0.5 in - let rra3 = rra_create CF_Average 100 100 0.5 in - let rra4 = rra_create CF_Average 100 1000 0.5 in - let ts = 1000000000.0 in + let ts = 0.0 in let ds = - ds_create "foo" Absolute ~mrhb:10.0 ~min:0. ~max:infinity (VT_Float 0.0) + ds_create "foo" Absolute ~mrhb:1000.0 ~min:0. ~max:infinity (VT_Float 0.0) in - let ds2 = - ds_create "bar" Absolute ~mrhb:10.0 ~min:0. ~max:infinity (VT_Float 0.0) - in - let ds3 = - ds_create "baz" Absolute ~mrhb:10.0 ~min:0. ~max:infinity (VT_Float 0.0) - in - let ds4 = - ds_create "boo" Absolute ~mrhb:10.0 ~min:0. ~max:infinity (VT_Float 0.0) - in - let rrd = rrd_create [|ds; ds2; ds3; ds4|] [|rra; rra2; rra3; rra4|] 1L ts in + let rrd = rrd_create [|ds|] [|rra|] 1L ts in let id = Identity in for i = 1 to 100000 do - let t = 1000000.0 +. (0.7 *. float_of_int i) in + let t = 300. *. float_of_int i in let ((_, val1) as v1) = - (0, {value= VT_Float (0.5 +. (0.5 *. sin (t /. 10.0))); transform= id}) + (0, {value= VT_Float (300. *. float_of_int i); transform= id}) in - let ((_, val2) as v2) = - (1, {value= VT_Float (1.5 +. (0.5 *. cos (t /. 80.0))); transform= id}) - in - let ((_, val3) as v3) = - (2, {value= VT_Float (3.5 +. (0.5 *. sin (t /. 700.0))); transform= id}) - in - let ((_, val4) as v4) = - (3, {value= VT_Float (6.5 +. (0.5 *. cos (t /. 5000.0))); transform= id}) - in - ds_update rrd t [|v1; v2; v3; v4|] false ; + ds_update rrd t [|v1|] false ; - Array.iter2 - (fun ds value -> - compare_float __LOC__ ds.ds_value - (float_of_string (ds_value_to_string value.value)) - ) - rrd.rrd_dss [|val1; val2; val3; val4|] + compare_float __LOC__ + (float_of_string (ds_value_to_string val1.value) /. 300.) + rrd.rrd_dss.(0).ds_value done (** Verify that Gauge data soruce values are correctly handled by the RRD lib diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune index 29ea531dca..55ffc4bfac 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune @@ -2,5 +2,5 @@ (test (package xapi-stdext-unix) (name test_xapi_fd_test) - (libraries xapi_fd_test alcotest fmt mtime.clock.os) + (libraries xapi_fd_test alcotest fmt mtime.clock.os unix) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune index a70e4820c9..b4edea2053 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune @@ -1,7 +1,7 @@ (tests (package xapi-stdext-unix) (names test_safefd test_properties test_operations) - (libraries xapi_fdcaps alcotest fmt) + (libraries xapi_fdcaps alcotest fmt unix) ) (cram diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t index fa6792fc01..6d80e54050 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t @@ -4,12 +4,14 @@ Check that we get compile errors when trying to use a read-only or write-only pr > open Xapi_fdcaps.Properties > let _ = as_readable (make `wronly `reg) > EOF - $ ocamlfind ocamlc -package xapi-stdext-unix.fdcaps -c t.ml 2>&1 | tail -n 1 - The second variant type does not allow tag(s) `wronly + $ ocamlfind ocamlc -package xapi-stdext-unix.fdcaps -c t.ml 2>&1 | + > grep -c "The second variant type does not allow tag(s)" + 1 $ cat >t.ml <<'EOF' > open Xapi_fdcaps.Properties > let _ = as_writable (make `rdonly `reg) > EOF - $ ocamlfind ocamlc -package xapi-stdext-unix.fdcaps -c t.ml 2>&1 | tail -n 1 - The second variant type does not allow tag(s) `rdonly + $ ocamlfind ocamlc -package xapi-stdext-unix.fdcaps -c t.ml 2>&1 | + > grep -c "The second variant type does not allow tag(s)" + 1 diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bench_encodings.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bench_encodings.ml index 7308c756d8..bb20eed4f4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bench_encodings.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bench_encodings.ml @@ -1,5 +1,5 @@ open Bechamel -open Xapi_stdext_encodings.Encodings +open Xapi_stdext_encodings let test name f = Test.make_indexed_with_resource ~name ~args:[10; 1000; 10000] @@ -10,6 +10,6 @@ let test name f = let benchmarks = Test.make_grouped ~name:"Encodings.validate" - [test "UTF8_XML" UTF8_XML.validate] + [test "UTF8.XML" Utf8.XML.is_valid] let () = Bechamel_simple_cli.cli benchmarks diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/dune index 9f12bcbf8c..b51703690d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/dune @@ -2,5 +2,5 @@ (name bench_encodings) (modes exe) (optional) - (libraries bechamel xapi_stdext_encodings bechamel-notty notty.unix fmt) + (libraries unix bechamel xapi_stdext_encodings bechamel-notty notty.unix fmt) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/dune index 742dd212f1..839346e35c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/dune @@ -1,12 +1,6 @@ (library (name xapi_stdext_encodings) (public_name xapi-stdext-encodings) - (modules :standard \ test) + (modules :standard) ) -(test - (name test) - (package xapi-stdext-encodings) - (modules test) - (libraries alcotest xapi-stdext-encodings) -) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.ml deleted file mode 100644 index 2dfd45a7d1..0000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.ml +++ /dev/null @@ -1,167 +0,0 @@ -(* - * Copyright (C) 2006-2009 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. - *) -exception UCS_value_out_of_range - -exception UCS_value_prohibited_in_UTF8 - -exception UCS_value_prohibited_in_XML - -exception UTF8_character_incomplete - -exception UTF8_header_byte_invalid - -exception UTF8_continuation_byte_invalid - -exception UTF8_encoding_not_canonical - -exception String_incomplete - -(* === Unicode Functions === *) - -module UCS = struct - let is_non_character value = - false - || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) - || Int.logand 0xfffe value = 0xfffe - (* case 2 *) - [@@inline] -end - -module XML = struct - let is_illegal_control_character value = - let value = Uchar.to_int value in - value < 0x20 && value <> 0x09 && value <> 0x0a && value <> 0x0d - [@@inline] -end - -(* === UCS Validators === *) - -module type UCS_VALIDATOR = sig - val validate : Uchar.t -> unit -end - -module UTF8_UCS_validator = struct - let validate value = - if (UCS.is_non_character [@inlined]) (Uchar.to_int value) then - raise UCS_value_prohibited_in_UTF8 - [@@inline] -end - -module XML_UTF8_UCS_validator = struct - let validate value = - (UTF8_UCS_validator.validate [@inlined]) value ; - if (XML.is_illegal_control_character [@inlined]) value then - raise UCS_value_prohibited_in_XML -end - -(* === String Validators === *) - -module type STRING_VALIDATOR = sig - val is_valid : string -> bool - - val validate : string -> unit - - val longest_valid_prefix : string -> string -end - -exception Validation_error of int * exn - -module UTF8_XML : STRING_VALIDATOR = struct - let decode_continuation_byte byte = - if byte land 0b11000000 = 0b10000000 then - byte land 0b00111111 - else - raise UTF8_continuation_byte_invalid - - let rec decode_continuation_bytes string last value index = - if index <= last then - let chunk = decode_continuation_byte (Char.code string.[index]) in - let value = (value lsl 6) lor chunk in - decode_continuation_bytes string last value (index + 1) - else - value - - let validate_character_utf8 string byte index = - let value, width = - if byte land 0b10000000 = 0b00000000 then - (byte, 1) - else if byte land 0b11100000 = 0b11000000 then - (byte land 0b0011111, 2) - else if byte land 0b11110000 = 0b11100000 then - (byte land 0b0001111, 3) - else if byte land 0b11111000 = 0b11110000 then - (byte land 0b0000111, 4) - else - raise UTF8_header_byte_invalid - in - let value = - if width = 1 then - value - else - decode_continuation_bytes string (index + width - 1) value (index + 1) - in - XML_UTF8_UCS_validator.validate (Uchar.unsafe_of_int value) ; - width - - let rec validate_aux string length index = - if index = length then - () - else - let width = - try - let byte = string.[index] |> Char.code in - validate_character_utf8 string byte index - with - | Invalid_argument _ -> - raise String_incomplete - | error -> - raise (Validation_error (index, error)) - in - validate_aux string length (index + width) - - let validate string = validate_aux string (String.length string) 0 - - let rec validate_with_fastpath string stop pos = - if pos < stop then - (* the compiler is smart enough to optimize the 'int32' away here, - and not allocate *) - let i32 = String.get_int32_ne string pos |> Int32.to_int in - (* test that for all bytes 0x20 <= byte < 0x80. - If any is <0x20 it would cause a negative value to appear in that byte, - which we can detect if we use 0x80 as a mask. - Byte >= 0x80 can be similarly detected with a mask of 0x80 on each byte. - We don't want to see a 0x80 from either of these, hence we bitwise or the 2 values together. - *) - if i32 lor (i32 - 0x20_20_20_20) land 0x80_80_80_80 = 0 then - validate_with_fastpath string stop (pos + 4) - else (* when the condition doesn't hold fall back to full UTF8 decoder *) - validate_aux string (String.length string) pos - else - validate_aux string (String.length string) pos - - let validate_with_fastpath string = - validate_with_fastpath string (String.length string - 3) 0 - - let validate = - if Sys.word_size = 64 then - validate_with_fastpath - else - validate - - let is_valid string = try validate string ; true with _ -> false - - let longest_valid_prefix string = - try validate string ; string - with Validation_error (index, _) -> String.sub string 0 index -end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.mli deleted file mode 100644 index 2a139ae378..0000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.mli +++ /dev/null @@ -1,84 +0,0 @@ -(* - * Copyright (C) 2006-2009 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. - *) - -(** Encoding helper modules *) - -(** {2 Exceptions} *) - -exception UCS_value_out_of_range - -exception UCS_value_prohibited_in_UTF8 - -exception UCS_value_prohibited_in_XML - -exception UTF8_character_incomplete - -exception UTF8_header_byte_invalid - -exception UTF8_continuation_byte_invalid - -exception UTF8_encoding_not_canonical - -exception String_incomplete - -(** {2 UCS Validators} *) - -(** Validates UCS character values. *) -module type UCS_VALIDATOR = sig - val validate : Uchar.t -> unit -end - -(** Accepts all values within the UCS character value range except - * those which are invalid for all UTF-8-encoded XML documents. *) -module XML_UTF8_UCS_validator : UCS_VALIDATOR - -module XML : sig - val is_illegal_control_character : Uchar.t -> bool - (** Returns true if and only if the given value corresponds to - * a illegal control character as defined in section 2.2 of - * the XML specification, version 1.0. *) -end - -(** {2 String Validators} *) - -(** Provides functionality for validating and processing - * strings according to a particular character encoding. *) -module type STRING_VALIDATOR = sig - val is_valid : string -> bool - (** Returns true if and only if the given string is validly-encoded. *) - - val validate : string -> unit - (** Raises an encoding error if the given string is not validly-encoded. *) - - val longest_valid_prefix : string -> string - (** Returns the longest validly-encoded prefix of the given string. *) -end - -(** Represents a validation error as a tuple [(i,e)], where: - * [i] = the index of the first non-compliant character; - * [e] = the reason for non-compliance. *) -exception Validation_error of int * exn - -(** Provides functions for validating and processing - * strings according to the UTF-8 character encoding, - * with certain additional restrictions on UCS values - * imposed by the XML specification. - * - * Validly-encoded strings must satisfy both RFC 3629 - * and section 2.2 of the XML specification. - * - * For further information, see: - * http://www.rfc.net/rfc3629.html - * http://www.w3.org/TR/REC-xml/#charsets *) -module UTF8_XML : STRING_VALIDATOR diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/test.ml deleted file mode 100644 index 9cc75b297d..0000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/test.ml +++ /dev/null @@ -1,533 +0,0 @@ -(* - * Copyright (C) 2006-2009 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 E = Xapi_stdext_encodings.Encodings - -(* Pull in the infix operators from Encodings used in this test *) -let ( --- ), ( +++ ), ( <<< ) = (Int.sub, Int.add, Int.shift_left) - -(* === Mock exceptions ==================================================== *) - -(** Simulates a decoding error. *) -exception Decode_error - -(* === Mock UCS validators ================================================= *) - -(** A validator that always succeeds. *) -module Lenient_UCS_validator : E.UCS_VALIDATOR = struct - let validate _ = () -end - -(* === Mock character validators ============================================= *) - -(** A validator that succeeds for all characters. *) -module Universal_character_validator = struct - let validate _ = () -end - -(** A validator that fails for all characters. *) -module Failing_character_validator = struct - let validate _ = raise Decode_error -end - -(** A validator that succeeds for all characters except the letter 'F'. *) -module Selective_character_validator = struct - let validate uchar = - if Uchar.equal uchar (Uchar.of_char 'F') then raise Decode_error -end - -(* === Test helpers ======================================================== *) - -let assert_true = Alcotest.(check bool) "true" true - -let assert_false = Alcotest.(check bool) "false" false - -let assert_raises_match exception_match fn = - try - fn () ; - Alcotest.fail "assert_raises_match: failure expected" - with failure -> - if not (exception_match failure) then - raise failure - else - () - -(* === Mock codecs ========================================================= *) - -module UCS = struct - (* === Unicode Functions === *) - let min_value = 0x000000 - - let max_value = 0x10ffff - (* used to be 0x1fffff, but this changed and Unicode won't allocate larger than 0x10ffff *) - - let is_non_character value = - false - || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) - || Int.logand 0xfffe value = 0xfffe - (* case 2 *) - - let is_out_of_range value = value < min_value || value > max_value - - let is_surrogate value = 0xd800 <= value && value <= 0xdfff - - (** A list of UCS non-characters values, including: - a. non-characters within the basic multilingual plane; - b. non-characters at the end of the basic multilingual plane; - c. non-characters at the end of the private use area. *) - let non_characters = - [ - 0x00fdd0 - ; 0x00fdef - ; (* case a. *) - 0x00fffe - ; 0x00ffff - ; (* case b. *) - 0x1ffffe - ; 0x1fffff (* case c. *) - ] - - (** A list of UCS character values located immediately before or - after UCS non-character values, including: - a. non-characters within the basic multilingual plane; - b. non-characters at the end of the basic multilingual plane; - c. non-characters at the end of the private use area. *) - let valid_characters_next_to_non_characters = - [ - 0x00fdcf - ; 0x00fdf0 - ; (* case a. *) - 0x00fffd - ; 0x010000 - ; (* case b. *) - 0x1ffffd - ; 0x200000 (* case c. *) - ] - - let test_is_non_character () = - List.iter (fun value -> assert_true (is_non_character value)) non_characters ; - List.iter - (fun value -> assert_false (is_non_character value)) - valid_characters_next_to_non_characters - - let test_is_out_of_range () = - assert_true (is_out_of_range (min_value --- 1)) ; - assert_false (is_out_of_range min_value) ; - assert_false (is_out_of_range max_value) ; - assert_true (is_out_of_range (max_value +++ 1)) - - let test_is_surrogate () = - assert_false (is_surrogate 0xd7ff) ; - assert_true (is_surrogate 0xd800) ; - assert_true (is_surrogate 0xdfff) ; - assert_false (is_surrogate 0xe000) - - let tests = - [ - ("test_is_non_character", `Quick, test_is_non_character) - ; ("test_is_out_of_range", `Quick, test_is_out_of_range) - ; ("test_is_surrogate", `Quick, test_is_surrogate) - ] -end - -module Lenient_UTF8_codec = struct - let decode_header_byte byte = - if byte land 0b10000000 = 0b00000000 then - (byte, 1) - else if byte land 0b11100000 = 0b11000000 then - (byte land 0b0011111, 2) - else if byte land 0b11110000 = 0b11100000 then - (byte land 0b0001111, 3) - else if byte land 0b11111000 = 0b11110000 then - (byte land 0b0000111, 4) - else - raise E.UTF8_header_byte_invalid - - let decode_continuation_byte byte = - if byte land 0b11000000 = 0b10000000 then - byte land 0b00111111 - else - raise E.UTF8_continuation_byte_invalid - - let width_required_for_ucs_value value = - if value < 0x000080 (* 1 lsl 7 *) then - 1 - else if value < 0x000800 (* 1 lsl 11 *) then - 2 - else if value < 0x010000 (* 1 lsl 16 *) then - 3 - else - 4 - - let decode_character string index = - let value, width = decode_header_byte (Char.code string.[index]) in - let value = - if width = 1 then - value - else - let value = ref value in - for index = index + 1 to index + width - 1 do - let chunk = decode_continuation_byte (Char.code string.[index]) in - value := (!value lsl 6) lor chunk - done ; - if width > width_required_for_ucs_value !value then - raise E.UTF8_encoding_not_canonical ; - !value - in - (value, width) -end - -(* === Mock string validators ============================================== *) -module Mock_String_validator (Validator : E.UCS_VALIDATOR) : - E.STRING_VALIDATOR = struct - (* no longer a functor in Encodings for performance reasons, - so modify the original string passed as argument instead replacing - characters that would be invalid with a known invalid XML char: 0x0B. - *) - - let transform str = - let b = Buffer.create (String.length str) in - let rec loop pos = - if pos < String.length str then - let value, width = Lenient_UTF8_codec.decode_character str pos in - let () = - try - let u = Uchar.of_int value in - Validator.validate u ; Buffer.add_utf_8_uchar b u - with _ -> Buffer.add_char b '\x0B' - in - loop (pos + width) - in - loop 0 ; Buffer.contents b - - let is_valid str = E.UTF8_XML.is_valid (transform str) - - let validate str = - try E.UTF8_XML.validate (transform str) - with E.Validation_error (pos, _) -> - raise (E.Validation_error (pos, Decode_error)) - - let longest_valid_prefix str = E.UTF8_XML.longest_valid_prefix (transform str) -end - -(** A validator that accepts all strings. *) -module Universal_string_validator = - Mock_String_validator (Universal_character_validator) - -(** A validator that rejects all strings. *) -module Failing_string_validator = - Mock_String_validator (Failing_character_validator) - -(** A validator that rejects strings containing the character 'F'. *) -module Selective_string_validator = - Mock_String_validator (Selective_character_validator) - -(* === Tests =============================================================== *) - -module String_validator = struct - let test_is_valid () = - assert_true (Universal_string_validator.is_valid "") ; - assert_true (Universal_string_validator.is_valid "123456789") ; - assert_true (Selective_string_validator.is_valid "") ; - assert_true (Selective_string_validator.is_valid "123456789") ; - assert_false (Selective_string_validator.is_valid "F23456789") ; - assert_false (Selective_string_validator.is_valid "1234F6789") ; - assert_false (Selective_string_validator.is_valid "12345678F") ; - assert_false (Selective_string_validator.is_valid "FFFFFFFFF") - - let test_longest_valid_prefix () = - Alcotest.(check string) - "prefix" - (Universal_string_validator.longest_valid_prefix "") - "" ; - Alcotest.(check string) - "prefix" - (Universal_string_validator.longest_valid_prefix "123456789") - "123456789" ; - Alcotest.(check string) - "prefix" - (Selective_string_validator.longest_valid_prefix "") - "" ; - Alcotest.(check string) - "prefix" - (Selective_string_validator.longest_valid_prefix "123456789") - "123456789" ; - Alcotest.(check string) - "prefix" - (Selective_string_validator.longest_valid_prefix "F23456789") - "" ; - Alcotest.(check string) - "prefix" - (Selective_string_validator.longest_valid_prefix "1234F6789") - "1234" ; - Alcotest.(check string) - "prefix" - (Selective_string_validator.longest_valid_prefix "12345678F") - "12345678" ; - Alcotest.(check string) - "prefix" - (Selective_string_validator.longest_valid_prefix "FFFFFFFFF") - "" - - (** Tests that validation does not fail for an empty string. *) - let test_validate_with_empty_string () = E.UTF8_XML.validate "" - - let test_validate_with_incomplete_string () = - Alcotest.check_raises "Validation fails correctly for an incomplete string" - E.String_incomplete (fun () -> E.UTF8_XML.validate "\xc2" - ) - - let test_validate_with_failing_decoders () = - Failing_string_validator.validate "" ; - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "F") ; - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "F12345678") ; - assert_raises_match - (function E.Validation_error (4, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "0123F5678") ; - assert_raises_match - (function E.Validation_error (8, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "01234567F") ; - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "FFFFFFFFF") - - let tests = - [ - ("test_is_valid", `Quick, test_is_valid) - ; ("test_longest_valid_prefix", `Quick, test_longest_valid_prefix) - ; ( "test_validate_with_empty_string" - , `Quick - , test_validate_with_empty_string - ) - ; ( "test_validate_with_incomplete_string" - , `Quick - , test_validate_with_incomplete_string - ) - ; ( "test_validate_with_failing_decoders" - , `Quick - , test_validate_with_failing_decoders - ) - ] -end - -module XML = struct - include E.XML - - let test_is_illegal_control_character () = - assert_true (is_illegal_control_character (Uchar.of_int 0x00)) ; - assert_true (is_illegal_control_character (Uchar.of_int 0x19)) ; - assert_false (is_illegal_control_character (Uchar.of_int 0x09)) ; - assert_false (is_illegal_control_character (Uchar.of_int 0x0a)) ; - assert_false (is_illegal_control_character (Uchar.of_int 0x0d)) ; - assert_false (is_illegal_control_character (Uchar.of_int 0x20)) - - let tests = - [ - ( "test_is_illegal_control_character" - , `Quick - , test_is_illegal_control_character - ) - ] -end - -(** Tests the XML-specific UTF-8 UCS validation function. *) -module XML_UTF8_UCS_validator = struct - include E.XML_UTF8_UCS_validator - - let validate uchar = - if Uchar.is_valid uchar then - validate @@ Uchar.of_int uchar - else if uchar < Uchar.to_int Uchar.min || uchar > Uchar.to_int Uchar.max - then - raise E.UCS_value_out_of_range - else - raise E.UCS_value_prohibited_in_UTF8 - - let test_validate () = - let value = ref (UCS.min_value --- 1) in - while !value <= UCS.max_value +++ 1 do - if UCS.is_out_of_range !value then - Alcotest.check_raises "should fail" E.UCS_value_out_of_range (fun () -> - validate !value - ) - else if UCS.is_non_character !value || UCS.is_surrogate !value then - Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_UTF8 - (fun () -> validate !value - ) - else if - Uchar.is_valid !value - && XML.is_illegal_control_character (Uchar.of_int !value) - then - Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_XML - (fun () -> validate !value - ) - else - validate !value ; - value := !value +++ 1 - done - - let tests = [("test_validate", `Quick, test_validate)] -end - -module UTF8_codec = struct - (** A list of canonical encoding widths of UCS values, - represented by tuples of the form (v, w), where: - v = the UCS character value to be encoded; and - w = the width of the encoded character, in bytes. *) - let valid_ucs_value_widths = - [ - (1, 1) - ; ((1 <<< 7) --- 1, 1) - ; (1 <<< 7, 2) - ; ((1 <<< 11) --- 1, 2) - ; (1 <<< 11, 3) - ; ((1 <<< 16) --- 1, 3) - ; (1 <<< 16, 4) - ; ((1 <<< 21) --- 1, 4) - ] - - let width_required_for_ucs_value value = - if value < 0x000080 (* 1 lsl 7 *) then - 1 - else if value < 0x000800 (* 1 lsl 11 *) then - 2 - else if value < 0x010000 (* 1 lsl 16 *) then - 3 - else - 4 - - let test_width_required_for_ucs_value () = - List.iter - (fun (value, width) -> - Alcotest.(check int) - "same ints" - (width_required_for_ucs_value value) - width - ) - valid_ucs_value_widths - - (** A list of valid character decodings represented by - tuples of the form (s, (v, w)), where: - - s = a validly-encoded UTF-8 string; - v = the UCS value represented by the string; - (which may or may not be valid in its own right) - w = the width of the encoded string, in bytes. - - For each byte length b in [1...4], the list contains - decodings for: - - v_min = the smallest UCS value encodable in b bytes. - v_max = the greatest UCS value encodable in b bytes. *) - let valid_character_decodings = - [ - (* 7654321 *) - (* 0b0xxxxxxx *) - (* 00000000000000xxxxxxx *) - ( "\x00" (* 0b00000000 *) - , (0b000000000000000000000, 1) - ) - ; ( "\x7f" (* 0b01111111 *) - , (0b000000000000001111111, 1) - ) - ; (* 10987654321 *) - (* 0b110xxxsx 0b10xxxxxx *) - (* 0000000000xxxsxxxxxxx *) - ( "\xc2\x80" (* 0b11000010 0b10000000 *) - , (0b000000000000010000000, 2) - ) - ; ( "\xdf\xbf" (* 0b11011111 0b10111111 *) - , (0b000000000011111111111, 2) - ) - ; (* 6543210987654321 *) - (* 0b1110xxxx 0b10sxxxxx 0b10xxxxxx *) - (* xxxxsxxxxxxxxxxx *) - ( "\xe0\xa0\x80" (* 0b11100000 0b10100000 0b10000000 *) - , (0b000000000100000000000, 3) - ) - ; ( "\xef\xbf\xbf" (* 0b11101111 0b10111111 0b10111111 *) - , (0b000001111111111111111, 3) - ) - ; (* 109876543210987654321 *) - (* 0b11110xxx 0b10xsxxxx 0b10xxxxxx 0b10xxxxxx *) - (* xxxxsxxxxxxxxxxxxxxxx *) - ( "\xf0\x90\x80\x80" (* 0b11110000 0b10010000 0b10000000 0b10000000 *) - , (0b000010000000000000000, 4) - ) - ; ( "\xf7\xbf\xbf\xbf" (* 0b11110111 0b10111111 0b10111111 0b10111111 *) - , (0b111111111111111111111, 4) - ) - ] - - let uchar = Alcotest.int - - let test_decode_character_when_valid () = - List.iter - (fun (string, (value, width)) -> - Alcotest.(check (pair uchar int)) - "same pair" - (Lenient_UTF8_codec.decode_character string 0) - (value, width) - ) - valid_character_decodings - - (** A list of strings containing overlong character encodings. - For each byte length b in [2...4], this list contains the - overlong encoding e (v), where v is the UCS value one less - than the smallest UCS value validly-encodable in b bytes. *) - let overlong_character_encodings = - [ - "\xc1\xbf" (* 0b11000001 0b10111111 *) - ; "\xe0\x9f\xbf" (* 0b11100000 0b10011111 0b10111111 *) - ; "\xf0\x8f\xbf\xbf" (* 0b11110000 0b10001111 0b10111111 0b10111111 *) - ] - - let test_decode_character_when_overlong () = - List.iter - (fun string -> - Alcotest.check_raises "should fail" E.UTF8_encoding_not_canonical - (fun () -> Lenient_UTF8_codec.decode_character string 0 |> ignore - ) - ) - overlong_character_encodings - - let tests = - [ - ( "test_width_required_for_ucs_value" - , `Quick - , test_width_required_for_ucs_value - ) - ; ( "test_decode_character_when_valid" - , `Quick - , test_decode_character_when_valid - ) - ; ( "test_decode_character_when_overlong" - , `Quick - , test_decode_character_when_overlong - ) - ] -end - -let () = - Alcotest.run "Encodings" - [ - ("UCS", UCS.tests) - ; ("XML", XML.tests) - ; ("String_validator", String_validator.tests) - ; ("XML_UTF8_UCS_validator", XML_UTF8_UCS_validator.tests) - ; ("UTF8_codec", UTF8_codec.tests) - ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/utf8.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/utf8.ml new file mode 100644 index 0000000000..d17d85b3b3 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/utf8.ml @@ -0,0 +1,74 @@ +(* + * 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. + *) + +let is_valid = String.is_valid_utf_8 + +(* deprecated - reject invalid UTF-8 *) +let longest_valid_prefix str = + let len = String.length str in + let rec loop = function + | i when i < len -> + let dec = String.get_utf_8_uchar str i in + if Uchar.utf_decode_is_valid dec then + loop (i + Uchar.utf_decode_length dec) + else + String.sub str 0 i + | i when i = len -> + str + | i -> + String.sub str 0 i (* never reached *) + in + loop 0 + +module XML = struct + (** some UTF-8 characters are not legal in XML. Assuming uchar is + legal UTF-8, further check that it is legal in XML *) + let is_legal uchar = + let uchar = Uchar.to_int uchar in + uchar >= 0x20 || uchar = 0x09 || uchar = 0x0a || uchar = 0x0d + [@@inline] + + let is_valid str = + let len = String.length str in + let rec loop = function + | i when i < len -> + let dec = String.get_utf_8_uchar str i in + Uchar.utf_decode_is_valid dec + && is_legal (Uchar.utf_decode_uchar dec) + && loop (i + Uchar.utf_decode_length dec) + | _ -> + true + in + loop 0 + + (* deprecated - reject invalid UTF-8 *) + let longest_valid_prefix str = + let len = String.length str in + let rec loop = function + | i when i < len -> + let dec = String.get_utf_8_uchar str i in + if + Uchar.utf_decode_is_valid dec + && is_legal (Uchar.utf_decode_uchar dec) + then + loop (i + Uchar.utf_decode_length dec) + else + String.sub str 0 i + | i when i = len -> + str (* avoid copy *) + | i -> + String.sub str 0 i (* never reached *) + in + loop 0 +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/utf8.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/utf8.mli new file mode 100644 index 0000000000..6d8949e2f8 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/utf8.mli @@ -0,0 +1,31 @@ +(* + * 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. + *) + +val is_valid : string -> bool +(** true, if a string is a proper UTF-8 string *) + +val longest_valid_prefix : string -> string +(** Deprecated. Longest prefix of a string that is proper UTF-8 *) + +(* strings in XML are more restricted than UTF-8 in general. The must be + valid UTF-8 and must not contain certain characters *) + +module XML : sig + val is_valid : string -> bool + (** true, if a string is a proper UTF-8 string in XML *) + + val longest_valid_prefix : string -> string + (** Deprecated. longest prefix of a string that is proper UTF-8. + Better reject invalid UTF-8. *) +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.ml new file mode 100644 index 0000000000..52897ee2a0 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.ml @@ -0,0 +1,130 @@ +open Bechamel +open Toolkit +module XString = Xapi_stdext_std.Xstringext.String + +(* Test data generators *) +let make_string len = String.init len (fun i -> Char.chr (33 + (i mod 94))) + +let escape_rules = + [('a', "[A]"); ('e', "[E]"); ('i', "[I]"); ('o', "[O]"); ('u', "[U]")] + +(* Reference implementation from xstringext_test.ml *) +let escaped_spec ?rules string = + match rules with + | None -> + String.escaped string + | Some rules -> + let apply_rules char = + match List.assoc_opt char rules with + | None -> + Seq.return char + | Some replacement -> + String.to_seq replacement + in + string |> String.to_seq |> Seq.concat_map apply_rules |> String.of_seq + +let escaped_benchmark n = + let s = make_string n in + Staged.stage @@ fun () -> ignore (XString.escaped ~rules:escape_rules s) + +let escaped_spec_benchmark n = + let s = make_string n in + Staged.stage @@ fun () -> ignore (escaped_spec ~rules:escape_rules s) + +let test_escaped = + Test.make_indexed ~name:"escaped" ~fmt:"%s %d" ~args:[100; 500; 1000] + escaped_benchmark + +let test_escaped_spec = + Test.make_indexed ~name:"escaped-spec" ~fmt:"%s %d" ~args:[100; 500; 1000] + escaped_spec_benchmark + +let benchmark () = + let ols = + Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[|run|] + in + let instances = + Instance.[minor_allocated; major_allocated; monotonic_clock] + in + let cfg = + Benchmark.cfg ~limit:2000 ~quota:(Time.second 0.5) ~kde:(Some 1000) () + in + let test = + Test.make_grouped ~name:"escaped-comparison" + [test_escaped; test_escaped_spec] + in + let raw_results = Benchmark.all cfg instances test in + let results = + List.map (fun instance -> Analyze.all ols instance raw_results) instances + in + let results = Analyze.merge ols instances results in + (results, raw_results) + +let () = + let all_results = benchmark () in + let results, _ = all_results in + + (* Extract timing data from the actual benchmark results *) + let result_groups = + Hashtbl.fold + (fun _ v a -> Hashtbl.fold (fun k v a -> (k, v) :: a) v [] :: a) + results [] + in + + (* Find the monotonic-clock result group (timing data) *) + let timing_group = + match result_groups with _ :: _ :: timing :: _ -> Some timing | _ -> None + in + + let get_timing test_name = + match timing_group with + | None -> + None + | Some group -> ( + match List.assoc_opt test_name group with + | Some estimator -> ( + let estimates = Analyze.OLS.estimates estimator in + match estimates with Some (x :: _) -> Some x | _ -> None + ) + | None -> + None + ) + in + + Printf.printf "\n=== Performance Comparison: Optimized vs Reference ===\n\n" ; + + let sizes = ["100"; "500"; "1000"] in + List.iter + (fun size -> + Printf.printf "String size %s:\n" size ; + let opt_test = Printf.sprintf "escaped-comparison/escaped %s" size in + let ref_test = Printf.sprintf "escaped-comparison/escaped-spec %s" size in + match (get_timing opt_test, get_timing ref_test) with + | Some opt_time, Some ref_time -> + let improvement = (ref_time -. opt_time) /. ref_time *. 100.0 in + Printf.printf " Optimized: %.3f μs\n" opt_time ; + Printf.printf " Reference: %.3f μs\n" ref_time ; + Printf.printf " Improvement: %.1f%% %s\n\n" improvement + (if improvement > 0.0 then "faster" else "slower") + | None, _ -> + Printf.printf " Optimized implementation data missing\n\n" + | _, None -> + Printf.printf " Reference implementation data missing\n\n" + ) + sizes ; + + Printf.printf "\n=== Detailed Results ===\n" ; + match result_groups with + | [results] -> + let print (k, ols) = Fmt.pr "%s: %a\n%!" k Analyze.OLS.pp ols in + List.iter print results + | results_list -> + Printf.printf "Results structure: %d result groups\n" + (List.length results_list) ; + List.iteri + (fun i results -> + Printf.printf "Result group %d:\n" i ; + let print (k, ols) = Fmt.pr " %s: %a\n%!" k Analyze.OLS.pp ols in + List.iter print results + ) + results_list diff --git a/ocaml/tests/test_host_driver_helpers.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.mli similarity index 100% rename from ocaml/tests/test_host_driver_helpers.mli rename to ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.mli diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/dune new file mode 100644 index 0000000000..27467a0902 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/dune @@ -0,0 +1,6 @@ +(executable + (name bench_xstringext) + (modes exe) + (optional) + (libraries bechamel xapi-stdext-std bechamel-notty notty.unix fmt) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune index dd8393a442..d869973d41 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune @@ -7,5 +7,5 @@ (names xstringext_test listext_test) (package xapi-stdext-std) (modules xstringext_test listext_test) - (libraries xapi_stdext_std alcotest) + (libraries xapi_stdext_std fmt alcotest qcheck-core qcheck-alcotest) ) 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 c290ab8e56..9336429ee3 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -22,8 +22,7 @@ module List = struct | x :: xs -> if mem x xs then setify xs else x :: setify xs - let subset s1 s2 = - List.fold_left ( && ) true (List.map (fun s -> List.mem s s2) s1) + let subset s1 s2 = List.for_all (fun s -> List.mem s s2) s1 let set_equiv s1 s2 = subset s1 s2 && subset s2 s1 @@ -84,61 +83,14 @@ module List = struct | _ :: xs -> last xs - let sub i j l = drop i l |> take (j - max i 0) - - let rec chop i l = - match (i, l) with - | j, _ when j < 0 -> - invalid_arg "chop: index cannot be negative" - | 0, l -> - ([], l) - | _, h :: t -> - (fun (fr, ba) -> (h :: fr, ba)) (chop (i - 1) t) - | _, [] -> - invalid_arg "chop: index not in list" - - let rev_chop i l = - let rec aux i fr ba = - match (i, fr, ba) with - | i, _, _ when i < 0 -> - invalid_arg "rev_chop: index cannot be negative" - | 0, fr, ba -> - (fr, ba) - | i, fr, h :: t -> - aux (i - 1) (h :: fr) t - | _ -> - invalid_arg "rev_chop" + let split_at n list = + let rec loop i acc = function + | x :: xs when i < n -> + loop (i + 1) (x :: acc) xs + | xs -> + (List.rev acc, xs) in - aux i [] l - - let chop_tr i l = (fun (fr, ba) -> (rev fr, ba)) (rev_chop i l) - - let rec dice m l = - match chop m l with l, [] -> [l] | l1, l2 -> l1 :: dice m l2 - - let remove i l = - match rev_chop i l with - | rfr, _ :: t -> - rev_append rfr t - | _ -> - invalid_arg "remove" - - let insert i e l = - match rev_chop i l with rfr, ba -> rev_append rfr (e :: ba) - - let replace i e l = - match rev_chop i l with - | rfr, _ :: t -> - rev_append rfr (e :: t) - | _ -> - invalid_arg "replace" - - let morph i f l = - match rev_chop i l with - | rfr, h :: t -> - rev_append rfr (f h :: t) - | _ -> - invalid_arg "morph" + loop 0 [] list let rec between e = function | [] -> 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 231c389106..3de05254e7 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -27,6 +27,12 @@ module List : sig (** [drop n list] returns the list without the first [n] elements of [list] (or [] if list is shorter). *) + val split_at : int -> 'a list -> 'a list * 'a list + (** [split_at n list] returns a tuple with the first element being the first + [n] elements of [list] (or less if the list is shorter); and the second + element being the rest of elements of the list (or [] if the list is + shorter). The results with negative values of [n] are the same as using 0. *) + val last : 'a list -> 'a (** [last l] returns the last element of a list or raise Invalid_argument if the list is empty *) @@ -67,42 +73,6 @@ module List : sig When using OCaml compilers 5.1 or later, please use the standard library instead. *) - (** {1 Using indices to manipulate lists} *) - - val chop : int -> 'a list -> 'a list * 'a list - (** [chop k l] splits [l] at index [k] to return a pair of lists. Raises - invalid_arg when [i] is negative or greater than the length of [l]. *) - - val rev_chop : int -> 'a list -> 'a list * 'a list - (** [rev_chop k l] splits [l] at index [k] to return a pair of lists, the - first in reverse order. Raises invalid_arg when [i] is negative or - greater than the length of [l]. *) - - val chop_tr : int -> 'a list -> 'a list * 'a list - (** Tail-recursive {!chop}. *) - - val dice : int -> 'a list -> 'a list list - (** [dice k l] splits [l] into lists with [k] elements each. Raises - {!Invalid_arg} if [List.length l] is not divisible by [k]. *) - - val sub : int -> int -> 'a list -> 'a list - (** [sub from to l] returns the sub-list of [l] that starts at index [from] - and ends at [to] or an empty list if [to] is equal or less than [from]. - Negative indices are treated as 0 and indeces higher than [List.length l - - 1] are treated as [List.length l - 1]. *) - - val remove : int -> 'a list -> 'a list - (** Remove the element at the given index. *) - - val insert : int -> 'a -> 'a list -> 'a list - (** Insert the given element at the given index. *) - - val replace : int -> 'a -> 'a list -> 'a list - (** Replace the element at the given index with the given value. *) - - val morph : int -> ('a -> 'a) -> 'a list -> 'a list - (** Apply the given function to the element at the given index. *) - (** {1 Association Lists} *) val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml index 852b0d7a83..39224f40be 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml @@ -25,7 +25,7 @@ let test_option typ tested_f (name, case, expected) = let check () = Alcotest.(check @@ option typ) name expected (tested_f case) in (name, `Quick, check) -let test_chopped_list tested_f (name, case, expected) = +let test_split_at_list tested_f (name, case, expected) = let check () = Alcotest.(check @@ pair (list int) (list int)) name expected (tested_f case) in @@ -135,7 +135,7 @@ let test_last = let error_tests = List.map error_test error_specs in ("last", tests @ error_tests) -let test_chop = +let test_split_at = let specs = [ ([], 0, ([], [])) @@ -144,67 +144,21 @@ let test_chop = ; ([0; 1], 0, ([], [0; 1])) ; ([0; 1], 1, ([0], [1])) ; ([0; 1], 2, ([0; 1], [])) - ] - in - let error_specs = - [ - ([0], -1, Invalid_argument "chop: index cannot be negative") - ; ([0], 2, Invalid_argument "chop: index not in list") + (* test invalid arguments *) [@ocamlformat "disable"] + ; ([0], -1, ([], [0])) + ; ([0], 2, ([0], [])) ] in let test (whole, number, expected) = let name = - Printf.sprintf "chop [%s] with %i" - (String.concat "; " (List.map string_of_int whole)) - number - in - test_chopped_list (Listext.chop number) (name, whole, expected) - in - let tests = List.map test specs in - let error_test (whole, number, error) = - let name = - Printf.sprintf "chop [%s] with %i fails" + Printf.sprintf "split_at [%s] with %i" (String.concat "; " (List.map string_of_int whole)) number in - test_error - (fun ls () -> ignore (Listext.chop number ls)) - (name, whole, error) - in - let error_tests = List.map error_test error_specs in - ("chop", tests @ error_tests) - -let test_sub = - let specs = - [ - ([], 0, 0, []) - ; ([], 0, 1, []) - ; ([0], 0, 0, []) - ; ([0], 0, 1, [0]) - ; ([0], 1, 1, []) - ; ([0], 0, 2, [0]) - ; ([0; 1], 0, 0, []) - ; ([0; 1], 0, 1, [0]) - ; ([0; 1], 0, 2, [0; 1]) - ; ([0; 1], 1, 1, []) - ; ([0; 1], 1, 2, [1]) - ; ([0; 1], 2, 2, []) - (* test_cases below used to fail *) [@ocamlformat "disable"] - ; ([0], -1, 0, []) - ; ([0], 0, -1, []) - ; ([0; 1], 1, 0, []) - ] - in - let test (whole, from, until, expected) = - let name = - Printf.sprintf "sub [%s] from %i to %i" - (String.concat "; " (List.map string_of_int whole)) - from until - in - test_list (Listext.sub from until) (name, whole, expected) + test_split_at_list (Listext.split_at number) (name, whole, expected) in let tests = List.map test specs in - ("sub", tests) + ("split_at", tests) let test_find_minimum (name, pp, typ, specs) = let test ((cmp, cmp_name), input, expected) = @@ -260,8 +214,7 @@ let () = ; test_take ; test_drop ; test_last - ; test_chop - ; test_sub + ; test_split_at ; test_find_minimum_int ; test_find_minimum_tuple ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml index 16f60dedba..4e5379d7b3 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml @@ -42,21 +42,6 @@ module String = struct (** Returns true for whitespace characters, false otherwise *) let isspace = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false - let escaped ?rules string = - match rules with - | None -> - String.escaped string - | Some rules -> - let aux h t = - ( if List.mem_assoc h rules then - List.assoc h rules - else - of_char h - ) - :: t - in - concat "" (fold_right aux string []) - let split_f p str = let split_one seq = let not_p c = not (p c) in @@ -193,6 +178,13 @@ module String = struct ) else s + let escaped ?rules s = + match rules with + | None -> + String.escaped s + | Some rules -> + map_unlikely s (fun c -> List.assoc_opt c rules) + let sub_to_end s start = let length = String.length s in String.sub s start (length - start) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml index 145ce632bb..9b7eb2674a 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml @@ -147,6 +147,49 @@ let test_rtrim = in ("rtrim", List.map test spec) +(** Simple implementation of escaped for testing against *) +let escaped_spec ?rules string = + match rules with + | None -> + String.escaped string + | Some rules -> + let apply_rules char = + match List.assoc_opt char rules with + | None -> + Seq.return char + | Some replacement -> + String.to_seq replacement + in + string |> String.to_seq |> Seq.concat_map apply_rules |> String.of_seq + +let test_escaped = + let open QCheck2 in + (* Generator for escape rules: list of (char, string) mappings *) + let gen_rules = + let open Gen in + let gen_rule = pair char (string_size (int_range 0 5) ~gen:char) in + list gen_rule + in + (* Generator for test input: string and optional rules *) + let gen_input = Gen.pair Gen.string (Gen.opt gen_rules) in + let property (s, rules) = + let expected = escaped_spec ?rules s in + let actual = XString.escaped ?rules s in + String.equal expected actual + in + let test = + Test.make ~name:"escaped matches reference implementation" ~count:1000 + gen_input property + in + ("escaped", [QCheck_alcotest.to_alcotest test]) + let () = Alcotest.run "Xstringext" - [test_rev_map; test_split; test_split_f; test_has_substr; test_rtrim] + [ + test_rev_map + ; test_split + ; test_split_f + ; test_has_substr + ; test_rtrim + ; test_escaped + ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index 0dc52b78cd..6915eaee07 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -43,5 +43,6 @@ fmt tgroup threads.posix + unix xapi_stdext_threads_scheduler) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml index 0a4a847403..259a24ee26 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml @@ -14,90 +14,106 @@ module Scheduler = Xapi_stdext_threads_scheduler.Scheduler +let calibrated_ratio () = + let expected = Mtime.Span.(100 * ms |> to_float_ns) in + let elapsed = Mtime_clock.counter () in + (* Add a 10% leeway to the ratio calculated *) + Thread.delay 0.11 ; + let actual = Mtime_clock.count elapsed |> Mtime.Span.to_float_ns in + let ratio = actual /. expected in + Alcotest.(check bool) (Printf.sprintf "ratio is %f" ratio) true true ; + ratio + let started = Atomic.make false let start_schedule () = if not (Atomic.exchange started true) then Thread.create Scheduler.loop () |> ignore -let send event data = Event.(send event data |> sync) +let send event data () = Event.(send event data |> sync) let receive event = Event.(receive event |> sync) -let elapsed_ms cnt = - let elapsed_ns = Mtime_clock.count cnt |> Mtime.Span.to_uint64_ns in - Int64.(div elapsed_ns 1000000L |> to_int) +let is_less ratio a b = + let a = + Mtime.Span.to_float_ns a + |> Float.mul ratio + |> Int64.of_float + |> Mtime.Span.of_uint64_ns + in + Mtime.Span.is_shorter ~than:a b -let is_less = Alcotest.(testable (pp int)) Stdlib.( > ) +let mtime_span () = + let cmp = is_less (calibrated_ratio ()) in + Alcotest.(testable Mtime.Span.pp) cmp let test_single () = let finished = Event.new_channel () in - Scheduler.add_to_queue "one" Scheduler.OneShot 0.001 (fun () -> - send finished true - ) ; + Scheduler.add_to_queue "one" Scheduler.OneShot 0.001 (send finished true) ; start_schedule () ; Alcotest.(check bool) "result" true (receive finished) -let test_remove_self () = +let test_remove_self mtime_span () = let which = Event.new_channel () in Scheduler.add_to_queue "self" (Scheduler.Periodic 0.001) 0.001 (fun () -> (* this should remove the periodic scheduling *) Scheduler.remove_from_queue "self" ; (* add an operation to stop the test *) - Scheduler.add_to_queue "stop" Scheduler.OneShot 0.1 (fun () -> - send which "stop" - ) ; - send which "self" + Scheduler.add_to_queue "stop" Scheduler.OneShot 0.1 (send which "stop") ; + send which "self" () ) ; start_schedule () ; - let cnt = Mtime_clock.counter () in + + let from_wait_to_receive = Mtime_clock.counter () in Alcotest.(check string) "same event name" "self" (receive which) ; Alcotest.(check string) "same event name" "stop" (receive which) ; - let elapsed_ms = elapsed_ms cnt in - Alcotest.check is_less "small time" 300 elapsed_ms -let test_empty () = + let elapsed = Mtime_clock.count from_wait_to_receive in + let expected = Mtime.Span.(300 * ms) in + Alcotest.check mtime_span "small time" expected elapsed + +let test_empty mtime_span () = let finished = Event.new_channel () in - Scheduler.add_to_queue "one" Scheduler.OneShot 0.001 (fun () -> - send finished true - ) ; + Scheduler.add_to_queue "one" Scheduler.OneShot 0.001 (send finished true) ; start_schedule () ; Alcotest.(check bool) "finished" true (receive finished) ; (* wait loop to go to wait with no work to do *) Thread.delay 0.1 ; - Scheduler.add_to_queue "two" Scheduler.OneShot 0.001 (fun () -> - send finished true - ) ; - let cnt = Mtime_clock.counter () in + Scheduler.add_to_queue "two" Scheduler.OneShot 0.001 (send finished true) ; + + let from_wait_to_receive = Mtime_clock.counter () in Alcotest.(check bool) "finished" true (receive finished) ; - let elapsed_ms = elapsed_ms cnt in - Alcotest.check is_less "small time" 100 elapsed_ms -let test_wakeup () = + let elapsed = Mtime_clock.count from_wait_to_receive in + let expected = Mtime.Span.(100 * ms) in + Alcotest.check mtime_span "small time" expected elapsed + +let test_wakeup mtime_span () = let which = Event.new_channel () in (* schedule a long event *) - Scheduler.add_to_queue "long" Scheduler.OneShot 2.0 (fun () -> - send which "long" - ) ; + Scheduler.add_to_queue "long" Scheduler.OneShot 2.0 (send which "long") ; start_schedule () ; (* wait loop to go to wait with no work to do *) Thread.delay 0.1 ; - let cnt = Mtime_clock.counter () in + (* schedule a quick event, should wake up the loop *) - Scheduler.add_to_queue "quick" Scheduler.OneShot 0.1 (fun () -> - send which "quick" - ) ; + Scheduler.add_to_queue "quick" Scheduler.OneShot 0.1 (send which "quick") ; + + let from_wait_to_receive_quick = Mtime_clock.counter () in Alcotest.(check string) "same event name" "quick" (receive which) ; + Scheduler.remove_from_queue "long" ; - let elapsed_ms = elapsed_ms cnt in - Alcotest.check is_less "small time" 150 elapsed_ms + let elapsed = Mtime_clock.count from_wait_to_receive_quick in + let expected = Mtime.Span.(100 * ms) in + Alcotest.check mtime_span "small time" expected elapsed let tests = + let mtime_span = mtime_span () in [ ("test_single", `Quick, test_single) - ; ("test_remove_self", `Quick, test_remove_self) - ; ("test_empty", `Quick, test_empty) - ; ("test_wakeup", `Quick, test_wakeup) + ; ("test_remove_self", `Quick, test_remove_self mtime_span) + ; ("test_empty", `Quick, test_empty mtime_span) + ; ("test_wakeup", `Quick, test_wakeup mtime_span) ] let () = Alcotest.run "Scheduler" [("generic", tests)] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml index c8d85d8b6c..251b35473a 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -19,8 +19,8 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally module Mutex = struct (** execute the function f with the mutex hold *) let execute lock f = - Mutex.lock lock ; - finally f (fun () -> Mutex.unlock lock) + let finally () = Mutex.unlock lock in + Mutex.lock lock ; Fun.protect ~finally f end module Semaphore = struct diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune index 3b116a0798..71e902d50d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,7 +1,7 @@ (library (name unixext_test) (modules unixext_test) - (libraries clock xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult) + (libraries clock xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult unix) ) (test @@ -25,7 +25,7 @@ (name test_systemd) (package xapi-stdext-unix) (modules test_systemd) - (libraries xapi-stdext-unix)) + (libraries xapi-stdext-unix unix)) (cram (package xapi-stdext-unix) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index 32a9f5119a..893a7e4d9b 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -17,6 +17,11 @@ exception Unix_error of int let _exit = Unix._exit +let raise_with_preserved_backtrace exn f = + let bt = Printexc.get_raw_backtrace () in + f () ; + Printexc.raise_with_backtrace exn bt + (** remove a file, but doesn't raise an exception if the file is already removed *) let unlink_safe file = try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli index 047935b475..3db652bd2a 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -15,6 +15,10 @@ val _exit : int -> unit +val raise_with_preserved_backtrace : exn -> (unit -> unit) -> 'b +(** A wrapper that preserves the backtrace (otherwise erased by calling + formatting functions, for example) *) + val unlink_safe : string -> unit val mkdir_safe : string -> Unix.file_perm -> unit diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_stubs.c index 28fd7f9af8..27b2f632d0 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_stubs.c +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_stubs.c @@ -39,11 +39,11 @@ #include "blkgetsize.h" /* Set the TCP_NODELAY flag on a Unix.file_descr */ -CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool) +CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value nodelay) { - CAMLparam2 (fd, bool); + CAMLparam2 (fd, nodelay); int c_fd = Int_val(fd); - int opt = (Bool_val(bool)) ? 1 : 0; + int opt = (Bool_val(nodelay)) ? 1 : 0; if (setsockopt(c_fd, IPPROTO_TCP, TCP_NODELAY, (void *)&opt, sizeof(opt)) != 0){ uerror("setsockopt", Nothing); } diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/dune index ec7532c6a9..1f75b68297 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/dune @@ -1,5 +1,13 @@ (library (public_name xapi-stdext-zerocheck) (name xapi_stdext_zerocheck) + (modules :standard \ zerocheck_test) (foreign_stubs (language c) (names zerocheck_stub)) ) + +(test + (name zerocheck_test) + (package xapi-stdext-zerocheck) + (modules zerocheck_test) + (libraries alcotest xapi-stdext-zerocheck) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.ml index e128431c58..6a588d9744 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.ml @@ -11,4 +11,7 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -external is_all_zeros : string -> int -> bool = "is_all_zeros" + +external is_all_zeros_in_length : string -> int -> bool = "is_all_zeros" + +let is_all_zeros str = is_all_zeros_in_length str (String.length str) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.mli index 08eb9b73d4..41caab70f0 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.mli @@ -12,5 +12,5 @@ * GNU Lesser General Public License for more details. *) -external is_all_zeros : string -> int -> bool = "is_all_zeros" -(** [is_all_zeroes x len] returns true if the substring is all zeroes *) +val is_all_zeros : string -> bool +(** [is_all_zeroes x] returns whether [x] contains only zeroes *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_stub.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_stub.c index 4606cf95a4..c88511ce77 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_stub.c +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_stub.c @@ -23,9 +23,9 @@ value is_all_zeros(value string, value length) { CAMLparam2(string, length); const char *s = String_val(string); - unsigned int *p; - int len = Int_val(length); - int i; + unsigned const int *p; + long len = Long_val(length); + long i; p = (unsigned int *) s; for (i = len / 4; i > 0; i--) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_test.ml new file mode 100644 index 0000000000..ae3f8cf9de --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_test.ml @@ -0,0 +1,43 @@ +(* Copyright (C) 2025 Vates + + 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 Zerocheck = Xapi_stdext_zerocheck.Zerocheck + +module Str = struct + let big_non_zero = + let spec = [("2 GiBs", 2_147_483_647); ("2 GiBs + 1", 2147483647 + 1)] in + let test size () = + let non_zeroes = Bytes.make size '\x00' in + Bytes.set non_zeroes (size - 1) '\x01' ; + let non_zeroes = Bytes.unsafe_to_string non_zeroes in + let expected = true in + let actual = not (Zerocheck.is_all_zeros non_zeroes) in + Alcotest.(check bool) "The last byte is not zero" expected actual + in + List.map (fun (name, size) -> (name, `Quick, test size)) spec + + let big_zero = + let test () = + let size = 2147483647 + 1 in + let zeroes = String.make size '\x00' in + let expected = true in + let actual = Zerocheck.is_all_zeros zeroes in + Alcotest.(check bool) "All bytes are zero" expected actual + in + [("2 GiBs + 1", `Quick, test)] + + let tests = + [("String: Not all zeroes", big_non_zero); ("String: all zeroes", big_zero)] +end + +let () = Alcotest.run "Zerocheck" Str.tests diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_test.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/ocaml/libs/xenctrl-ext/Makefile b/ocaml/libs/xenctrl-ext/Makefile new file mode 100644 index 0000000000..363bd218ce --- /dev/null +++ b/ocaml/libs/xenctrl-ext/Makefile @@ -0,0 +1,10 @@ +# +# + +# K&R style indentation +INDENT += -nbad -bap -nbc -br -brs -c33 -cd33 -ncdb -ce -ci4 -cli0 +INDENT += -d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs +INDENT += -npsl -nsc -nsob + +format: + find . -name '*.[ch]' | xargs -n1 indent -nut $(INDENT) diff --git a/ocaml/libs/xenctrl-ext/dune b/ocaml/libs/xenctrl-ext/dune new file mode 100644 index 0000000000..b9f77e7e4b --- /dev/null +++ b/ocaml/libs/xenctrl-ext/dune @@ -0,0 +1,11 @@ +(library + (name xenctrl_ext) + (wrapped false) + (libraries unix xenctrl) + (foreign_stubs + (language c) + (names xenctrlext_stubs) + ) + (c_library_flags (-L/lib64 -lxenforeignmemory)) +) + diff --git a/ocaml/xenopsd/xc/xenctrlext.ml b/ocaml/libs/xenctrl-ext/xenctrlext.ml similarity index 92% rename from ocaml/xenopsd/xc/xenctrlext.ml rename to ocaml/libs/xenctrl-ext/xenctrlext.ml index a0e0c0ed31..8922e49046 100644 --- a/ocaml/xenopsd/xc/xenctrlext.ml +++ b/ocaml/libs/xenctrl-ext/xenctrlext.ml @@ -34,10 +34,6 @@ let get_handle () = handle := Some h ; h -external get_boot_cpufeatures : - handle -> int32 * int32 * int32 * int32 * int32 * int32 * int32 * int32 - = "stub_xenctrlext_get_boot_cpufeatures" - external domain_set_timer_mode : handle -> domid -> int -> unit = "stub_xenctrlext_domain_set_timer_mode" @@ -90,6 +86,9 @@ external domain_soft_reset : handle -> domid -> unit external domain_update_channels : handle -> domid -> int -> int -> unit = "stub_xenctrlext_domain_update_channels" +external vcpu_setaffinity_hard : handle -> domid -> int -> bool array -> unit + = "stub_xenctrlext_vcpu_setaffinity_hard" + external vcpu_setaffinity_soft : handle -> domid -> int -> bool array -> unit = "stub_xenctrlext_vcpu_setaffinity_soft" @@ -122,5 +121,13 @@ module NumaNode = struct let from = Fun.id end +exception Not_available + let domain_claim_pages handle domid ?(numa_node = NumaNode.none) nr_pages = + if numa_node <> NumaNode.none then + raise Not_available ; stub_domain_claim_pages handle domid numa_node nr_pages + +let get_nr_nodes handle = + let info = numainfo handle in + Array.length info.memory diff --git a/ocaml/xenopsd/xc/xenctrlext.mli b/ocaml/libs/xenctrl-ext/xenctrlext.mli similarity index 88% rename from ocaml/xenopsd/xc/xenctrlext.mli rename to ocaml/libs/xenctrl-ext/xenctrlext.mli index 559842fac7..f9b8b49bb8 100644 --- a/ocaml/xenopsd/xc/xenctrlext.mli +++ b/ocaml/libs/xenctrl-ext/xenctrlext.mli @@ -20,10 +20,6 @@ external interface_open : unit -> handle = "stub_xenctrlext_interface_open" val get_handle : unit -> handle -external get_boot_cpufeatures : - handle -> int32 * int32 * int32 * int32 * int32 * int32 * int32 * int32 - = "stub_xenctrlext_get_boot_cpufeatures" - external domain_set_timer_mode : handle -> domid -> int -> unit = "stub_xenctrlext_domain_set_timer_mode" @@ -78,6 +74,9 @@ type numainfo = {memory: meminfo array; distances: int array array} type cputopo = {core: int; socket: int; node: int} +external vcpu_setaffinity_hard : handle -> domid -> int -> bool array -> unit + = "stub_xenctrlext_vcpu_setaffinity_hard" + external vcpu_setaffinity_soft : handle -> domid -> int -> bool array -> unit = "stub_xenctrlext_vcpu_setaffinity_soft" @@ -99,5 +98,12 @@ module NumaNode : sig val from : int -> t end +exception Not_available + val domain_claim_pages : handle -> domid -> ?numa_node:NumaNode.t -> int -> unit -(** Raises {Unix_error} if there's not enough memory to claim in the system *) +(** Raises {Unix_error} if there's not enough memory to claim in the system. + Raises {Not_available} if a single numa node is requested and xen does not + provide page claiming for single numa nodes. *) + +val get_nr_nodes : handle -> int +(** Returns the count of NUMA nodes available in the system. *) diff --git a/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c b/ocaml/libs/xenctrl-ext/xenctrlext_stubs.c similarity index 91% rename from ocaml/xenopsd/c_stubs/xenctrlext_stubs.c rename to ocaml/libs/xenctrl-ext/xenctrlext_stubs.c index d7f3fee8f5..a9d8f3f97b 100644 --- a/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c +++ b/ocaml/libs/xenctrl-ext/xenctrlext_stubs.c @@ -144,35 +144,6 @@ CAMLprim value stub_xenctrlext_get_runstate_info(value xch_val, value domid) #endif } -CAMLprim value stub_xenctrlext_get_boot_cpufeatures(value xch_val) -{ - CAMLparam1(xch_val); -#if defined(XENCTRL_HAS_GET_CPUFEATURES) - CAMLlocal1(v); - uint32_t a, b, c, d, e, f, g, h; - int ret; - xc_interface *xch = xch_of_val(xch_val); - - ret = xc_get_boot_cpufeatures(xch, &a, &b, &c, &d, &e, &f, &g, &h); - if (ret < 0) - failwith_xc(xch); - - v = caml_alloc_tuple(8); - Store_field(v, 0, caml_copy_int32(a)); - Store_field(v, 1, caml_copy_int32(b)); - Store_field(v, 2, caml_copy_int32(c)); - Store_field(v, 3, caml_copy_int32(d)); - Store_field(v, 4, caml_copy_int32(e)); - Store_field(v, 5, caml_copy_int32(f)); - Store_field(v, 6, caml_copy_int32(g)); - Store_field(v, 7, caml_copy_int32(h)); - - CAMLreturn(v); -#else - caml_failwith("XENCTRL_HAS_GET_CPUFEATURES not defined"); -#endif -} - static int xcext_domain_send_s3resume(xc_interface *xch, unsigned int domid) { return xc_set_hvm_param(xch, domid, HVM_PARAM_ACPI_S_STATE, 0); @@ -323,40 +294,72 @@ CAMLprim value stub_xenctrlext_domain_update_channels(value xch_val, value domid } /* based on xenctrl_stubs.c */ -static int get_cpumap_len(value xch_val, value cpumap) +static int get_cpumap_len(xc_interface *xch, value cpumap_val) { - xc_interface* xch = xch_of_val(xch_val); - int ml_len = Wosize_val(cpumap); + int ml_len = Wosize_val(cpumap_val); int xc_len = xc_get_max_cpus(xch); return (ml_len < xc_len ? ml_len : xc_len); } -CAMLprim value stub_xenctrlext_vcpu_setaffinity_soft(value xch_val, value domid, - value vcpu, value cpumap) +static void populate_cpumap(xc_interface *xch, xc_cpumap_t cpumap, + value cpumap_val) { - CAMLparam4(xch_val, domid, vcpu, cpumap); - int i, len = get_cpumap_len(xch_val, cpumap); - xc_cpumap_t c_cpumap; - int retval; + int i, len = get_cpumap_len(xch, cpumap_val); + for (i=0; i t:t -> queue:string -> ?timeout:int -> body:string diff --git a/ocaml/message-switch/core_test/dune b/ocaml/message-switch/core_test/dune index 92317ba71c..e3c14b1d58 100644 --- a/ocaml/message-switch/core_test/dune +++ b/ocaml/message-switch/core_test/dune @@ -15,6 +15,7 @@ message-switch-core message-switch-lwt threads.posix + unix ) ) diff --git a/ocaml/message-switch/core_test/lwt/dune b/ocaml/message-switch/core_test/lwt/dune index d08db56b3a..250cfc3ccf 100644 --- a/ocaml/message-switch/core_test/lwt/dune +++ b/ocaml/message-switch/core_test/lwt/dune @@ -13,6 +13,7 @@ message-switch-core message-switch-lwt uri + unix ) ) diff --git a/ocaml/message-switch/lwt/dune b/ocaml/message-switch/lwt/dune index 12f0330129..197c4813f6 100644 --- a/ocaml/message-switch/lwt/dune +++ b/ocaml/message-switch/lwt/dune @@ -4,6 +4,7 @@ (libraries cohttp-lwt-unix message-switch-core + unix (re_export lwt) (re_export lwt.unix) ) diff --git a/ocaml/message-switch/switch/dune b/ocaml/message-switch/switch/dune index e543584a89..284dd32186 100644 --- a/ocaml/message-switch/switch/dune +++ b/ocaml/message-switch/switch/dune @@ -26,6 +26,7 @@ shared-block-ring sexplib sexplib0 + unix uri ) (preprocess (per_module ((pps ppx_sexp_conv) Logging Q Switch_main))) diff --git a/ocaml/message-switch/unix/dune b/ocaml/message-switch/unix/dune index 92bddfd66f..4a1c65a946 100644 --- a/ocaml/message-switch/unix/dune +++ b/ocaml/message-switch/unix/dune @@ -11,6 +11,8 @@ rpclib.core rpclib.json threads.posix + tracing + unix xapi-stdext-threads xapi-stdext-unix ) diff --git a/ocaml/message-switch/unix/protocol_unix.ml b/ocaml/message-switch/unix/protocol_unix.ml index f7aa0802c0..29b95f7ef1 100644 --- a/ocaml/message-switch/unix/protocol_unix.ml +++ b/ocaml/message-switch/unix/protocol_unix.ml @@ -347,7 +347,7 @@ module Client = struct Ok c' ) - let rpc ~t:c ~queue:dest_queue_name ?timeout ~body:x () = + let rpc ?_span_parent ~t:c ~queue:dest_queue_name ?timeout ~body:x () = let t = Ivar.create () in let timer = Option.map @@ -364,9 +364,23 @@ module Client = struct do_rpc c.requests_conn (In.CreatePersistent dest_queue_name) >>|= fun (_ : string) -> let msg = - In.Send - ( dest_queue_name - , {Message.payload= x; kind= Message.Request c.reply_queue_name} + Tracing.with_tracing + ~attributes: + [ + ("messaging.operation.name", "send") + ; ("messaging.system", "message-switch") + ; ("messaging.destination.name", dest_queue_name) + ] + ~span_kind:Producer ~parent:_span_parent + ~name:("send" ^ " " ^ dest_queue_name) + (fun _ -> + In.Send + ( dest_queue_name + , { + Message.payload= x + ; kind= Message.Request c.reply_queue_name + } + ) ) in do_rpc c.requests_conn msg >>|= fun (id : string) -> diff --git a/ocaml/mpathalert/dune b/ocaml/mpathalert/dune index 2a46ae7e52..bdfab00c4b 100644 --- a/ocaml/mpathalert/dune +++ b/ocaml/mpathalert/dune @@ -6,6 +6,7 @@ (libraries http_lib threads.posix + unix uuid xapi-client xapi-consts diff --git a/ocaml/nbd/lib/consts.ml b/ocaml/nbd/lib/consts.ml index e70fdc5910..a16703f570 100644 --- a/ocaml/nbd/lib/consts.ml +++ b/ocaml/nbd/lib/consts.ml @@ -1,5 +1,6 @@ (** Xapi's local Unix domain socket *) -let xapi_unix_domain_socket_uri = "file:///var/xapi/xapi" +let xapi_unix_domain_socket_uri = + Uri.make ~scheme:"file" ~path:"/var/xapi/xapi" () (** Location of the xensource-inventory file on XenServer *) let xensource_inventory_filename = "/etc/xensource-inventory" diff --git a/ocaml/nbd/lib/dune b/ocaml/nbd/lib/dune index 8bcbdc6dd7..8feb56e1eb 100644 --- a/ocaml/nbd/lib/dune +++ b/ocaml/nbd/lib/dune @@ -1,6 +1,7 @@ (library (name consts) (modes best) + (libraries uri) (modules consts) ) @@ -14,6 +15,7 @@ lwt_log lwt.unix rpclib.core + unix xapi-types xen-api-client-lwt ) @@ -26,6 +28,7 @@ lwt lwt_log lwt.unix + unix ) (modules vbd_store) ) diff --git a/ocaml/nbd/lib_test/dune b/ocaml/nbd/lib_test/dune index 7da1f7d8e1..0c00b1f6ef 100644 --- a/ocaml/nbd/lib_test/dune +++ b/ocaml/nbd/lib_test/dune @@ -5,6 +5,7 @@ alcotest alcotest-lwt lwt + unix uuid vbd_store) ) diff --git a/ocaml/nbd/src/dune b/ocaml/nbd/src/dune index 02c9dc6a0e..61bb892e2e 100644 --- a/ocaml/nbd/src/dune +++ b/ocaml/nbd/src/dune @@ -15,6 +15,7 @@ nbd-unix rpclib.core uri + unix uuid vbd_store xapi-consts diff --git a/ocaml/networkd/bin/dune b/ocaml/networkd/bin/dune index be140076b5..a9d446007c 100644 --- a/ocaml/networkd/bin/dune +++ b/ocaml/networkd/bin/dune @@ -26,6 +26,7 @@ result rresult threads.posix + unix xapi-client xapi-consts xapi-consts.xapi_version diff --git a/ocaml/networkd/bin/network_monitor_thread.ml b/ocaml/networkd/bin/network_monitor_thread.ml index 1b15dbe2a4..0f886a94cd 100644 --- a/ocaml/networkd/bin/network_monitor_thread.ml +++ b/ocaml/networkd/bin/network_monitor_thread.ml @@ -26,10 +26,7 @@ let bonds_status : (string, int * int) Hashtbl.t = Hashtbl.create 10 let monitor_whitelist = ref - [ - "eth" - ; "vif" (* This includes "tap" owing to the use of standardise_name below *) - ] + ["vif" (* This includes "tap" owing to the use of standardise_name below *)] let rpc xml = let open Xmlrpc_client in @@ -108,7 +105,10 @@ let standardise_name name = newname with _ -> name -let get_link_stats () = +let get_link_stats dbg () = + let managed_host_net_devs = + Network_server.Interface.get_interface_positions dbg () |> List.map fst + in let open Netlink in let s = Socket.alloc () in Socket.connect s Socket.NETLINK_ROUTE ; @@ -119,13 +119,14 @@ let get_link_stats () = List.exists (fun s -> Astring.String.is_prefix ~affix:s name) !monitor_whitelist + || List.mem name managed_host_net_devs in let is_vlan name = - Astring.String.is_prefix ~affix:"eth" name && String.contains name '.' + List.mem name managed_host_net_devs && String.contains name '.' in List.map (fun link -> standardise_name (Link.get_name link)) links |> (* Only keep interfaces with prefixes on the whitelist, and exclude VLAN - devices (ethx.y). *) + devices (ethx.y). *) List.filter (fun name -> is_whitelisted name && not (is_vlan name)) in Cache.free cache ; Socket.close s ; Socket.free s ; links @@ -226,7 +227,7 @@ let rec monitor dbg () = Network_server.Bridge.get_all_bonds dbg from_cache in let add_bonds bonds devs = List.map fst bonds @ devs in - let devs = get_link_stats () |> add_bonds bonds |> get_stats bonds in + let devs = get_link_stats dbg () |> add_bonds bonds |> get_stats bonds in ( if List.length bonds <> Hashtbl.length bonds_status then let dead_bonds = Hashtbl.fold diff --git a/ocaml/networkd/bin/network_server.ml b/ocaml/networkd/bin/network_server.ml index 59c76e319f..65fa98d62d 100644 --- a/ocaml/networkd/bin/network_server.ml +++ b/ocaml/networkd/bin/network_server.ml @@ -35,18 +35,144 @@ let write_config () = try Network_config.write_config !config with Network_config.Write_error -> () +let get_index_from_ethx = Network_config.get_index_from_ethx + +let sort_based_on_ethx () = + Sysfs.list () + |> List.filter_map (fun name -> + if Sysfs.is_physical name then + get_index_from_ethx name |> Option.map (fun i -> (name, i)) + else + None + ) + +let read_previous_inventory previous_inventory = + try + Xapi_stdext_unix.Unixext.file_lines_fold + (fun acc line -> + match Inventory.parse_inventory_entry line with + | Some ("MANAGEMENT_INTERFACE", iface) -> + info "get management interface from previous inventory: %s" iface ; + (Some iface, snd acc) + | Some ("MANAGEMENT_ADDRESS_TYPE", addr_type) -> + info "get management address type from previous inventory: %s" + addr_type ; + (fst acc, Some addr_type) + | _ -> + acc + ) + (None, None) previous_inventory + with e -> + error "Failed to read previous inventory %s: %s" previous_inventory + (Printexc.to_string e) ; + (None, None) + +let update_inventory () = + let previous_inventory = "/var/tmp/.previousInventory" in + match read_previous_inventory previous_inventory with + | Some iface, Some addr_type -> + Network_config.write_manage_iface_to_inventory iface addr_type + | _ -> + error "Failed to find management interface or address type from %s" + previous_inventory + +let changed_interfaces_after_upgrade interface_order = + let previous_eth_devs = + List.filter_map + (fun (iface, _) -> + iface |> get_index_from_ethx |> Option.map (fun idx -> (iface, idx)) + ) + !config.interface_config + in + List.filter_map + (fun (name, pos) -> + List.find_opt (fun dev -> dev.position = pos) interface_order |> function + | Some dev -> + if dev.name <> name then Some (name, dev.name) else None + | None -> + error "Can't find previous interface %s in sorted interfaces" name ; + None + ) + previous_eth_devs + +let sort last_order = + let do_sort last_order = + match Network_device_order.sort last_order with + | Ok r -> + r + | Error err -> + error "Failed to sort interface order [%s]" + (Network_device_order.string_of_error err) ; + (last_order, []) + in + match (Network_config.device_already_renamed, last_order) with + | true, None -> + (* The net dev renamed version, skip sort *) + (None, []) + | true, Some _ -> + (* Impossible *) + error "%s: device renamed but order is not None" __FUNCTION__ ; + raise + (Network_error (Internal_error "device renamed but order is not None")) + | false, None -> + (* Upgrade from net dev renamed version. The previous order is converted + and passed to initial rules. Just use [] here to sort. *) + let interface_order, _ = do_sort [] in + let changed_interfaces = + changed_interfaces_after_upgrade interface_order + in + update_inventory () ; + (Some interface_order, changed_interfaces) + | false, Some last_order -> + let interface_order, changed_interfaces = do_sort last_order in + (Some interface_order, changed_interfaces) + +let update_changes last_config changed_interfaces = + let update_name name = + let new_name = + List.assoc_opt name changed_interfaces |> Option.value ~default:name + in + if name <> new_name then + debug "Renaming %s to %s" name new_name ; + new_name + in + let update_port (port, port_conf) = + ( update_name port + , {port_conf with interfaces= List.map update_name port_conf.interfaces} + ) + in + let bridge_config = + List.map + (fun (bridge, bridge_conf) -> + ( bridge + , {bridge_conf with ports= List.map update_port bridge_conf.ports} + ) + ) + last_config.bridge_config + in + let interface_config = + List.map + (fun (name, conf) -> (update_name name, conf)) + last_config.interface_config + in + (bridge_config, interface_config) + let read_config () = try config := Network_config.read_config () ; - debug "Read configuration from networkd.db file." + debug "Read configuration from networkd.db file." ; + let interface_order, changes = sort !config.interface_order in + let bridge_config, interface_config = update_changes !config changes in + config := {!config with bridge_config; interface_config; interface_order} with Network_config.Read_error -> ( try (* No configuration file found. Try to get the initial network setup from * the first-boot data written by the host installer. *) - config := Network_config.read_management_conf () ; + let interface_order, _ = sort Network_config.initial_interface_order in + config := Network_config.read_management_conf interface_order ; debug "Read configuration from management.conf file." with Network_config.Read_error -> - debug "Could not interpret the configuration in management.conf" + error "Could not interpret the configuration in management.conf" ) let on_shutdown signal = @@ -63,13 +189,30 @@ let on_timer () = write_config () let clear_state () = write_lock := true ; - config := Network_config.empty_config + (* Do not clear interface_order, it is only maintained by networkd *) + config := + {Network_config.empty_config with interface_order= !config.interface_order} let sync_state () = write_lock := false ; write_config () -let reset_state () = config := Network_config.read_management_conf () +let reset_state () = + let reset_order = + match !config.interface_order with + | Some _ -> + (* Use empty config interface_order to sort to generate fresh-install + state for currently-installed hardware *) + sort Network_config.empty_config.interface_order |> fst + | None -> + ignore + (Forkhelpers.execute_command_get_output + "/etc/sysconfig/network-scripts/interface-rename.py" + ["--reset-to-install"] + ) ; + None + in + config := Network_config.read_management_conf reset_order let set_gateway_interface _dbg name = (* Remove dhclient conf (if any) for the old and new gateway interfaces. @@ -269,6 +412,24 @@ module Interface = struct let get_all dbg () = Debug.with_thread_associated dbg (fun () -> Sysfs.list ()) () + let get_interface_positions dbg () = + Debug.with_thread_associated dbg + (fun () -> + match !config.interface_order with + | Some order -> + List.filter_map + (fun dev -> + if dev.present then + Some (dev.name, dev.position) + else + None + ) + order + | None -> + sort_based_on_ethx () + ) + () + let exists dbg name = Debug.with_thread_associated dbg (fun () -> List.mem name (Sysfs.list ())) @@ -554,7 +715,8 @@ module Interface = struct let set_dns _ dbg ~name ~nameservers ~domains = Debug.with_thread_associated dbg (fun () -> - update_config name {(get_config name) with dns= (nameservers, domains)} ; + update_config name + {(get_config name) with dns= Some (nameservers, domains)} ; debug "Configuring DNS for %s: nameservers: [%s]; domains: [%s]" name (String.concat ", " (List.map Unix.string_of_inet_addr nameservers)) (String.concat ", " domains) ; @@ -727,7 +889,7 @@ module Interface = struct ; ipv6_conf ; ipv6_gateway ; ipv4_routes - ; dns= nameservers, domains + ; dns ; mtu ; ethtool_settings ; ethtool_offload @@ -736,16 +898,23 @@ module Interface = struct ) ) -> update_config name c ; exec (fun () -> - (* We only apply the DNS settings when not in a DHCP mode - to avoid conflicts. The `dns` field - should really be an option type so that we don't have to - derive the intention of the caller by looking at other - fields. *) - match (ipv4_conf, ipv6_conf) with - | Static4 _, _ | _, Static6 _ | _, Autoconf6 -> - set_dns () dbg ~name ~nameservers ~domains - | _ -> + match dns with + | None -> () + | Some ([], []) -> ( + match (ipv4_conf, ipv6_conf) with + | Static4 _, _ | _, Static6 _ | _, Autoconf6 -> + (* clear DNS for Static mode *) + set_dns () dbg ~name ~nameservers:[] ~domains:[] + | _ -> + (* networkd.db in v25.28.0 and before stores empty + dns lists for DHCP mode, this case is to keep + resolv.conf intact when Toolstack update from + version earlier than v25.28.0 *) + () + ) + | Some (nameservers, domains) -> + set_dns () dbg ~name ~nameservers ~domains ) ; exec (fun () -> set_ipv4_conf dbg name ipv4_conf) ; exec (fun () -> @@ -935,12 +1104,6 @@ module Bridge = struct "standalone" ) in - let vlan_bug_workaround = - if List.mem_assoc "vlan-bug-workaround" other_config then - Some (List.assoc "vlan-bug-workaround" other_config = "true") - else - None - in let external_id = if List.mem_assoc "network-uuids" other_config then Some @@ -968,7 +1131,7 @@ module Bridge = struct Option.iter (destroy_existing_vlan_ovs_bridge dbg name) vlan ; ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band - ?igmp_snooping vlan vlan_bug_workaround name + ?igmp_snooping vlan name ) ; if igmp_snooping = Some true && not old_igmp_snooping then Ovs.inject_igmp_query ~name diff --git a/ocaml/networkd/bin/networkd.ml b/ocaml/networkd/bin/networkd.ml index bd4b813f6c..cfb712e092 100644 --- a/ocaml/networkd/bin/networkd.ml +++ b/ocaml/networkd/bin/networkd.ml @@ -183,6 +183,7 @@ let bind () = S.set_gateway_interface set_gateway_interface ; S.set_dns_interface set_dns_interface ; S.Interface.get_all Interface.get_all ; + S.Interface.get_interface_positions Interface.get_interface_positions ; S.Interface.exists Interface.exists ; S.Interface.get_mac Interface.get_mac ; S.Interface.get_pci_bus_path Interface.get_pci_bus_path ; diff --git a/ocaml/networkd/bin_db/dune b/ocaml/networkd/bin_db/dune index 6997bd74d0..16a1ca8db1 100644 --- a/ocaml/networkd/bin_db/dune +++ b/ocaml/networkd/bin_db/dune @@ -4,7 +4,7 @@ (package xapi-tools) (modes exe) (libraries - networklibs + unix xapi-idl.network) ) diff --git a/ocaml/networkd/bin_db/networkd_db.ml b/ocaml/networkd/bin_db/networkd_db.ml index f62021828f..7a44efb440 100644 --- a/ocaml/networkd/bin_db/networkd_db.ml +++ b/ocaml/networkd/bin_db/networkd_db.ml @@ -16,6 +16,10 @@ open Network_interface let name = "networkd_db" +type error = Skip | Msg of string + +let ( let* ) = Result.bind + let _ = let bridge = ref "" in let iface = ref "" in @@ -31,22 +35,59 @@ let _ = (Printf.sprintf "Usage: %s [-bridge | -iface ]" name) ; try let config = Network_config.read_config () in - if !bridge <> "" then - if List.mem_assoc !bridge config.bridge_config then ( - let bridge_config = List.assoc !bridge config.bridge_config in - let ifaces = - List.concat_map (fun (_, port) -> port.interfaces) bridge_config.ports + let r = + let* bridge = if !bridge = "" then Error Skip else Ok !bridge in + let* bridge_config = + let error = Msg (Printf.sprintf "Could not find bridge %s\n" bridge) in + List.assoc_opt bridge config.bridge_config + |> Option.to_result ~none:error + in + let ifaces = + List.concat_map (fun (_, port) -> port.interfaces) bridge_config.ports + in + let* macs = + let to_mac ~order name = + match List.find_opt (fun dev -> dev.name = name) order with + | Some dev -> + Either.Left (Macaddr.to_string dev.mac) + | None -> + Either.Right name in - Printf.printf "interfaces=%s\n" (String.concat "," ifaces) ; - match bridge_config.vlan with - | None -> - () - | Some (parent, id) -> - Printf.printf "vlan=%d\nparent=%s\n" id parent - ) else ( + match (config.interface_order, ifaces) with + | Some order, _ :: _ -> + let oks, errs = List.partition_map (to_mac ~order) ifaces in + if errs = [] then + Ok oks + else + Error + (Msg + (Printf.sprintf "Could not find MAC address(es) for %s" + (String.concat ", " errs) + ) + ) + | _, [] -> + (* No ifaces, no hwaddrs. *) + Ok [] + | None, _ :: _ -> + (* Fallback to use the bridge MAC address when the interface_order + is not available. This can work only because the host installer + requires only one network interface to setup its own networking so far. *) + Ok (Option.to_list bridge_config.bridge_mac) + in + Printf.printf "interfaces=%s\n" (String.concat "," ifaces) ; + Printf.printf "hwaddrs=%s\n" (String.concat "," macs) ; + Option.iter + (fun (parent, id) -> Printf.printf "vlan=%d\nparent=%s\n" id parent) + bridge_config.vlan ; + Ok () + in + ( match r with + | Ok () | Error Skip -> + () + | Error (Msg msg) -> rc := 1 ; - Printf.fprintf stderr "Could not find bridge %s\n" !bridge - ) ; + Printf.fprintf stderr "%s" msg + ) ; if !iface <> "" then if List.mem_assoc !iface config.interface_config then let interface_config = List.assoc !iface config.interface_config in @@ -74,20 +115,25 @@ let _ = [("gateway", Unix.string_of_inet_addr addr)] in let dns = - let dns' = - List.map Unix.string_of_inet_addr (fst interface_config.dns) - in - if dns' = [] then - [] - else - [("dns", String.concat "," dns')] + interface_config.dns + |> Option.map fst + |> Option.map (List.map Unix.string_of_inet_addr) + |> Option.fold ~none:[] ~some:(function + | [] -> + [] + | dns' -> + [("dns", String.concat "," dns')] + ) in let domains = - let domains' = snd interface_config.dns in - if domains' = [] then - [] - else - [("domain", String.concat "," domains')] + interface_config.dns + |> Option.map snd + |> Option.fold ~none:[] ~some:(function + | [] -> + [] + | domains' -> + [("domain", String.concat "," domains')] + ) in mode @ addrs @ gateway @ dns @ domains | None4 -> diff --git a/ocaml/networkd/lib/dune b/ocaml/networkd/lib/dune index 548d326a4b..0e9685a046 100644 --- a/ocaml/networkd/lib/dune +++ b/ocaml/networkd/lib/dune @@ -4,6 +4,7 @@ (libraries astring forkexec + macaddr mtime mtime.clock.os re @@ -13,12 +14,14 @@ rpclib.json rresult threads.posix + unix uri xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-inventory + xapi-idl xapi-idl.network xapi-log xapi-open-uri diff --git a/ocaml/networkd/lib/network_config.ml b/ocaml/networkd/lib/network_config.ml index 56eef61ce3..c00546d5d2 100644 --- a/ocaml/networkd/lib/network_config.ml +++ b/ocaml/networkd/lib/network_config.ml @@ -22,22 +22,36 @@ exception Read_error exception Write_error -let empty_config = default_config +(* If the interface-rename script dir exists, the devices are already renamed + to eth, the indicates device order *) +let device_already_renamed = + let dir = "/etc/sysconfig/network-scripts/interface-rename-data" in + Sys.file_exists dir && Sys.is_directory dir + +(* If devices have already been renamed, then interface_order is None, + since the order is now reflected in their names. *) +let initial_interface_order = if device_already_renamed then None else Some [] + +let empty_config = + {default_config with interface_order= initial_interface_order} let config_file_path = "/var/lib/xcp/networkd.db" let temp_vlan = "xentemp" -let bridge_naming_convention (device : string) = - if Astring.String.is_prefix ~affix:"eth" device then - "xenbr" ^ String.sub device 3 (String.length device - 3) - else - "br" ^ device +let get_index_from_ethx name = + try Scanf.sscanf name "eth%d%!" Option.some with _ -> None + +let bridge_naming_convention (device : string) pos_opt = + match pos_opt with + | Some index -> + "xenbr" ^ string_of_int index + | None -> + "br" ^ device let get_list_from ~sep ~key args = List.assoc_opt key args |> Option.map (fun v -> Astring.String.cuts ~empty:false ~sep v) - |> Option.value ~default:[] let parse_ipv4_config args = function | Some "static" -> @@ -73,13 +87,22 @@ let parse_ipv6_config args = function (None6, None) let parse_dns_config args = - let nameservers = - get_list_from ~sep:"," ~key:"DNS" args |> List.map Unix.inet_addr_of_string + let ( let* ) = Option.bind in + let* nameservers = + get_list_from ~sep:"," ~key:"DNS" args + |> Option.map (List.map Unix.inet_addr_of_string) in - let domains = get_list_from ~sep:" " ~key:"DOMAIN" args in - (nameservers, domains) + let* domains = get_list_from ~sep:" " ~key:"DOMAIN" args in + Some (nameservers, domains) + +let write_manage_iface_to_inventory bridge_name management_address_type = + info "Writing management interface to inventory: %s" bridge_name ; + Inventory.update Inventory._management_interface bridge_name ; + info "Writing management address type to inventory: %s" + management_address_type ; + Inventory.update Inventory._management_address_type management_address_type -let read_management_conf () = +let read_management_conf interface_order = try let management_conf = Xapi_stdext_unix.Unixext.string_of_file @@ -103,7 +126,7 @@ let read_management_conf () = let device = (* Take 1st member of bond *) match (bond_mode, bond_members) with - | None, _ | _, [] -> ( + | None, _ | _, (None | Some []) -> ( match List.assoc_opt "LABEL" args with | Some x -> x @@ -111,10 +134,34 @@ let read_management_conf () = error "%s: missing LABEL in %s" __FUNCTION__ management_conf ; raise Read_error ) - | _, hd :: _ -> + | _, Some (hd :: _) -> hd in - Inventory.reread_inventory () ; + let pos_opt = + match interface_order with + | Some order -> + List.find_map + (fun x -> if x.name = device then Some x.position else None) + order + | None -> + get_index_from_ethx device + in + let (ipv4_conf, ipv4_gateway), (ipv6_conf, ipv6_gateway) = + match (List.assoc_opt "MODE" args, List.assoc_opt "MODEV6" args) with + | None, None -> + error "%s: at least one of 'MODE', 'MODEV6' needs to be specified" + __FUNCTION__ ; + raise Read_error + | v4, v6 -> + (parse_ipv4_config args v4, parse_ipv6_config args v6) + in + let management_address_type = + (* Default to IPv4 unless we have only got an IPv6 admin interface *) + if ipv4_conf = None4 && ipv6_conf <> None6 then + "IPv6" + else + "IPv4" + in let bridge_name = let inventory_bridge = try Some (Inventory.lookup Inventory._management_interface) @@ -124,7 +171,7 @@ let read_management_conf () = | Some "" | None -> let bridge = if vlan = None then - bridge_naming_convention device + bridge_naming_convention device pos_opt else (* At this point, we don't know what the VLAN bridge name will be, * so use a temporary name. Xapi will replace the bridge once the name @@ -132,6 +179,8 @@ let read_management_conf () = temp_vlan in debug "No management bridge in inventory file... using %s" bridge ; + if not device_already_renamed then + write_manage_iface_to_inventory bridge management_address_type ; bridge | Some bridge -> debug "Management bridge in inventory file: %s" bridge ; @@ -139,15 +188,6 @@ let read_management_conf () = in let mac = Network_utils.Ip.get_mac device in let dns = parse_dns_config args in - let (ipv4_conf, ipv4_gateway), (ipv6_conf, ipv6_gateway) = - match (List.assoc_opt "MODE" args, List.assoc_opt "MODEV6" args) with - | None, None -> - error "%s: at least one of 'MODE', 'MODEV6' needs to be specified" - __FUNCTION__ ; - raise Read_error - | v4, v6 -> - (parse_ipv4_config args v4, parse_ipv6_config args v6) - in let phy_interface = {default_interface with persistent_i= true} in let bridge_interface = @@ -176,7 +216,7 @@ let read_management_conf () = , [(bridge_name, primary_bridge_conf)] ) | Some vlan -> - let parent = bridge_naming_convention device in + let parent = bridge_naming_convention device pos_opt in let secondary_bridge_conf = { default_bridge with @@ -203,6 +243,7 @@ let read_management_conf () = ; bridge_config ; gateway_interface= Some bridge_name ; dns_interface= Some bridge_name + ; interface_order } with e -> error "Error while trying to read firstboot data: %s\n%s" diff --git a/ocaml/networkd/lib/network_device_order.ml b/ocaml/networkd/lib/network_device_order.ml new file mode 100644 index 0000000000..3231633304 --- /dev/null +++ b/ocaml/networkd/lib/network_device_order.ml @@ -0,0 +1,570 @@ +(* + * 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. + *) + +(** Generate an order for host network devices and keep the order as stable as possible. + *) + +module D = Debug.Make (struct let name = __MODULE__ end) + +open D +open Network_interface + +let initial_rules_file_path = + "/etc/firstboot.d/data/initial_network_device_rules.conf" + +let ( let* ) = Result.bind + +let cmd_biosdevname = "/usr/sbin/biosdevname" + +type error = + | Pci_addr_parse_error of string + | Mac_addr_parse_error of string + | Rule_parse_error of string + | Missing_biosdevname_key of string + | Duplicate_mac_address + | Duplicate_position + | Invalid_biosdevname_key_value of (string * string) + +let string_of_error = function + | Pci_addr_parse_error s -> + Printf.sprintf "Invalid PCI address: %s" s + | Mac_addr_parse_error s -> + Printf.sprintf "Invalid MAC address: %s" s + | Rule_parse_error s -> + Printf.sprintf "Invalid rule: %s" s + | Missing_biosdevname_key k -> + Printf.sprintf "Missing key in biosdevname output: %s" k + | Duplicate_mac_address -> + "Duplicate MAC address" + | Duplicate_position -> + "Duplicate position" + | Invalid_biosdevname_key_value (k, v) -> + Printf.sprintf "Invalid key-value pair in biosdevname output: %s=%s" k v + +module Pciaddr = struct + type t = Xcp_pci.address + + let default = Xcp_pci.{domain= 0; bus= 0; dev= 0; fn= 0} + + let to_string = Xcp_pci.string_of_address + + let of_string s = + try Ok (Xcp_pci.address_of_string s) + with _ -> Error (Pci_addr_parse_error s) + + let compare t1 t2 = + let open Xcp_pci in + let ( ) a b = if a = 0 then b else a in + compare t1.domain t2.domain + compare t1.bus t2.bus + compare t1.dev t2.dev + compare t1.fn t2.fn +end + +module Macaddr = struct + include Macaddr + + let of_string s = + of_string s |> Result.map_error (fun _ -> Mac_addr_parse_error s) +end + +module PciaddrMap = Map.Make (Pciaddr) +module MacaddrSet = Set.Make (Macaddr) +module MacaddrMap = Map.Make (Macaddr) +module IntMap = Map.Make (Int) +module IntSet = Set.Make (Int) + +module UniqueMap (M : Map.S) : sig + exception Duplicate_key + + val of_unique_list : ('a -> M.key) -> 'a list -> 'a M.t + (** [of_unique_list map lst] creates a map with the values in [lst]. Their + keys are created by calling [map value]. Raises [Duplicate_key] whenever + more than one value in [lst] produces the same key when calling + [map value]. *) +end = struct + exception Duplicate_key + + let fail _ = raise Duplicate_key + + let of_unique_list map l = + List.fold_left + (fun acc v -> + let f x = Some (Option.fold ~none:v ~some:fail x) in + M.update (map v) f acc + ) + M.empty l +end + +module MultiMap (M : Map.S) : sig + val of_list : ('a -> M.key) -> 'a list -> 'a list M.t + (** [of_list map lst] creates a map with the values in [lst]. Their keys are + created by calling [map value]. Whenever more than a value generates the + key when calling [map value], the values are concatenated as a list. *) +end = struct + let of_list map l = + List.fold_left + (fun acc v -> + let f x = Some (Option.fold ~none:[v] ~some:(List.cons v) x) in + M.update (map v) f acc + ) + M.empty l +end + +module IntUniqueMap = UniqueMap (IntMap) +module MacaddrUniqueMap = UniqueMap (MacaddrMap) +module PciaddrMultiMap = MultiMap (PciaddrMap) + +let fold_results (l : ('a, 'e) result list) : ('a list, 'e) result = + List.fold_left + (fun acc r -> + match (acc, r) with + | Ok acc, Ok r -> + Ok (r :: acc) + | Error error, _ -> + Error error + | Ok _, Error error -> + Error error + ) + (Ok []) l + +module Rule = struct + type index = Mac_addr of Macaddr.t | Pci_addr of Pciaddr.t | Label of string + + type t = {position: int; index: index} + + let matches ~(mac : Macaddr.t) ~(pci : Pciaddr.t) ~(label : string) t : bool = + match t.index with + | Mac_addr mac' -> + mac' = mac + | Pci_addr pci' -> + pci' = pci + | Label label' -> + label' = label + + let parse line = + debug "%s: line: %s" __FUNCTION__ line ; + try + Scanf.sscanf line {|%d:%s@="%s@"|} (fun position ty value -> + let to_rule index = Ok {position; index} in + match ty with + | "pci" -> + let* pci = Pciaddr.of_string value in + to_rule (Pci_addr pci) + | "mac" -> + let* mac = Macaddr.of_string value in + to_rule (Mac_addr mac) + | "label" -> + to_rule (Label value) + | _ -> + Error (Rule_parse_error line) + ) + with _ -> Error (Rule_parse_error line) + + let validate (l : (t, error) result list) = + let* rules = fold_results l in + try + IntUniqueMap.of_unique_list (fun dev -> dev.position) rules |> ignore ; + Ok rules + with IntUniqueMap.Duplicate_key -> Error Duplicate_position + + let read ~(path : string) : (t list, error) result = + if not (Sys.file_exists path) then + Ok [] + else + Xapi_stdext_unix.Unixext.read_lines ~path |> List.map parse |> validate +end + +module Dev = struct + type t = { + name: Network_interface.iface + ; mac: Network_interface.mac_address + ; pci: Xcp_pci.address + ; bios_eth_order: int + ; multi_nic: bool + } + + let default = + { + name= "" + ; mac= Macaddr.of_string_exn "00:00:00:00:00:00" + ; pci= Pciaddr.default + ; bios_eth_order= -1 + ; multi_nic= false + } + + let compare_on_mac t1 t2 = Macaddr.compare t1.mac t2.mac + + let compare_on_bios_eth_order t1 t2 = + compare t1.bios_eth_order t2.bios_eth_order + + let to_string t = + Printf.sprintf "Name=%s; MAC=%s; PCI=%s; bios_eth_order=%d; multi_nic=%s" + t.name (Macaddr.to_string t.mac) (Pciaddr.to_string t.pci) + t.bios_eth_order + (string_of_bool t.multi_nic) + + let n_of_ethn ethn = + try Ok (Scanf.sscanf ethn "eth%d" (fun n -> n)) + with _ -> Error (Invalid_biosdevname_key_value ("BIOS device", ethn)) + + let parse output_of_one_dev = + debug "%s: line: %s" __FUNCTION__ output_of_one_dev ; + let kvs = + let open Astring.String in + cuts ~sep:"\n" output_of_one_dev + |> List.filter_map (fun line -> + cut ~sep:":" line |> Option.map (fun (k, v) -> (trim k, trim v)) + ) + in + List.iter (fun (k, v) -> debug "%s: [%s]=[%s]" __FUNCTION__ k v) kvs ; + [ + ( "BIOS device" + , fun r v -> + let* bios_eth_order = n_of_ethn v in + Ok {r with bios_eth_order} + ) + ; ("Kernel name", fun r v -> Ok {r with name= v}) + ; ( "Assigned MAC" + , fun r v -> + let* mac = Macaddr.of_string v in + Ok {r with mac} + ) + ; ( "Bus Info" + , fun r v -> + let pci_str = + match String.split_on_char '-' v with + | ["usb"; pci; _] -> + (* For USB device, the bus-info is like + "usb--", + use the PCI address of the USB controller *) + pci + | _ -> + v + in + let* pci = Pciaddr.of_string pci_str in + Ok {r with pci} + ) + ] + |> List.fold_left + (fun acc (k, f) -> + let* r = acc in + match List.assoc_opt k kvs with + | Some v -> + Result.map_error + (fun _ -> Invalid_biosdevname_key_value (k, v)) + (f r v) + | None -> + Error (Missing_biosdevname_key k) + ) + (Ok default) + + let update_multi_nic devs = + let pci_cnt = + let f o = Some (Option.fold ~none:1 ~some:(fun c -> c + 1) o) in + List.fold_left + (fun acc dev -> PciaddrMap.update dev.pci f acc) + PciaddrMap.empty devs + in + List.map + (fun dev : t -> + let multi_nic = + (* Will never raise exception or be < 1 *) + let c = PciaddrMap.find dev.pci pci_cnt in + if c > 1 then true else false + in + {dev with multi_nic} + ) + devs + + let not_ibft t = + try Scanf.sscanf t.name "ibft%d%!" (fun _ -> false) with _ -> true + + let get_all () : (t list, error) result = + let* devs = + Network_utils.call_script cmd_biosdevname + ["--policy"; "all_ethN"; "-d"; "-x"] + |> Astring.String.cuts ~sep:"\n\n" + |> List.filter (fun line -> line <> "") + |> List.map parse + |> fold_results + in + let devs = List.filter not_ibft devs in + try + MacaddrUniqueMap.of_unique_list (fun v -> v.mac) devs |> ignore ; + Ok (update_multi_nic devs) + with MacaddrUniqueMap.Duplicate_key -> Error Duplicate_mac_address +end + +module OrderedDev = struct + type t = Network_interface.ordered_iface + + let compare_on_mac t1 t2 = Macaddr.compare t1.mac t2.mac + + let to_string t = + Printf.sprintf "position=%d; name=%s; MAC=%s; PCI=%s; present=%s" t.position + t.name (Macaddr.to_string t.mac) (Pciaddr.to_string t.pci) + (string_of_bool t.present) + + let map_by_pci (l : t list) : t list PciaddrMap.t = + PciaddrMultiMap.of_list (fun v -> v.pci) l + + let map_by_position (l : t list) : (t IntMap.t, error) result = + try Ok (IntUniqueMap.of_unique_list (fun v -> v.position) l) + with _ -> Error Duplicate_position + + let validate_no_duplicate_position (l : t list) : (t list, error) result = + try + IntUniqueMap.of_unique_list (fun dev -> dev.position) l |> ignore ; + Ok l + with _ -> Error Duplicate_position + + let validate_no_duplicate_mac (l : t list) : (t list, error) result = + try + MacaddrUniqueMap.of_unique_list (fun dev -> dev.mac) l |> ignore ; + Ok l + with _ -> Error Duplicate_mac_address + + let validate_order (l : t list) : (t list, error) result = + let* l = validate_no_duplicate_position l in + validate_no_duplicate_mac l + + let assign_position (dev : Dev.t) position = + Network_interface. + {name= dev.name; mac= dev.mac; pci= dev.pci; position; present= true} +end + +type ordering = OrderedDev.t list * Dev.t list + +let assign_position_by_rules ~(rules : Rule.t list) + ((ordered, unordered) : ordering) : ordering = + List.fold_left + (fun (acc_ordered, acc_unordered) (dev : Dev.t) -> + match + List.find_opt + (Rule.matches ~mac:dev.mac ~pci:dev.pci ~label:dev.name) + rules + with + | Some {position; _} -> + debug "%s: assign position: %d <- %s" __FUNCTION__ position + (Dev.to_string dev) ; + let dev' = OrderedDev.assign_position dev position in + (dev' :: acc_ordered, acc_unordered) + | None -> + (acc_ordered, dev :: acc_unordered) + ) + (ordered, []) unordered + +let assign_position_by_mac ~(last_order : OrderedDev.t list) + ((ordered, unordered) : ordering) : ordering = + List.fold_left + (fun (acc_ordered, acc_unordered) (dev : Dev.t) -> + match List.find_opt (fun dev' -> dev.mac = dev'.mac) last_order with + | Some {position; _} -> + (* Found a MAC matched network device in [last_order]: assign the position as last. *) + debug "%s: assign position: %d <- %s" __FUNCTION__ position + (Dev.to_string dev) ; + let dev' = OrderedDev.assign_position dev position in + (dev' :: acc_ordered, acc_unordered) + | None -> + debug "%s: skip %s" __FUNCTION__ (Dev.to_string dev) ; + (* a new network device: leave it unassigned at the moment *) + (acc_ordered, dev :: acc_unordered) + ) + (ordered, []) unordered + +let assign_position_by_pci ~(last_pcis : OrderedDev.t list PciaddrMap.t) + ~(curr_macs : MacaddrSet.t) ((ordered, unordered) : ordering) : ordering = + List.fold_left + (fun (acc_ordered, acc_unordered) (dev : Dev.t) -> + match (dev, PciaddrMap.find_opt dev.pci last_pcis) with + | Dev.{multi_nic= false; _}, Some [{position; mac; _}] -> ( + (* Not a multi-nic function. + And found a ever-seen device which had located at the same PCI address. *) + match MacaddrSet.find_opt mac curr_macs with + | None -> + (* The ever-seen device has been removed - not in current MAC addresses. + This is a replacement: assign the position as before. *) + debug "%s: assign position: %d <- %s" __FUNCTION__ position + (Dev.to_string dev) ; + let dev' = OrderedDev.assign_position dev position in + (dev' :: acc_ordered, acc_unordered) + | Some _ -> + (* The ever-seen device is still presenting this time. + It must have been positioned via the MAC address already. But its PCI address changes. *) + debug "%s: skip (seen) %s" __FUNCTION__ (Dev.to_string dev) ; + (acc_ordered, dev :: acc_unordered) + ) + | _ -> + debug "%s: skip %s" __FUNCTION__ (Dev.to_string dev) ; + (acc_ordered, dev :: acc_unordered) + ) + (ordered, []) unordered + +let assign_position_for_multinic ~(last_pcis : OrderedDev.t list PciaddrMap.t) + ~(assigned_positions : IntSet.t) (multinics : Dev.t list) : ordering = + PciaddrMap.fold + (fun pci devs (acc_ordered, acc_unordered) -> + (* The [last_devs] are the devices which were previously occupying the PCI address. + The positions of these devices are called the "last positions". *) + let last_devs = + PciaddrMap.find_opt pci last_pcis |> Option.value ~default:[] + in + match + ( List.exists + (fun {position; _} -> IntSet.mem position assigned_positions) + last_devs + , List.length devs = List.length last_devs + ) + with + | false, true -> + (* All the "last positions" have not been assigned yet. + And no change on the number of devices sharing the PCI address. + Re-assign the "last positions" by sorting with MAC addresses. *) + let devs' = List.sort Dev.compare_on_mac devs in + let lasts' = List.sort OrderedDev.compare_on_mac last_devs in + let ordered_devs = + List.rev_map2 + (fun dev last -> + let position = last.position in + debug "%s: assign position: %d <- %s" __FUNCTION__ position + (Dev.to_string dev) ; + OrderedDev.assign_position dev position + ) + devs' lasts' + in + (List.rev_append ordered_devs acc_ordered, acc_unordered) + | true, _ + (* Some of the "last positions" have been assigned by MAC address. + But there are some new ones reported this time. *) + | false, false -> + (* This means at this PCI address, the devices have completely + different MAC addresses and the number of devices changes as well. + Consider them being new devices. *) + + (* Collect all BIOS eth order numbers *) + let bios_eth_orders = + devs + |> List.map (fun dev -> dev.Dev.bios_eth_order) + |> List.sort compare + in + (* Re-assgin the BIOS eth order by zipping the BIOS eth order and MAC order. *) + let unordered_devs = + devs + |> List.stable_sort Dev.compare_on_mac + |> List.rev_map2 + (fun bios_eth_order dev -> Dev.{dev with bios_eth_order}) + bios_eth_orders + in + (acc_ordered, List.rev_append unordered_devs acc_unordered) + ) + (PciaddrMultiMap.of_list (fun v -> v.Dev.pci) multinics) + ([], []) + +let assign_position_for_remaining ~(max_position : int) (devs : Dev.t list) : + OrderedDev.t list = + List.fold_left + (fun (acc_pos, acc) (dev : Dev.t) -> + let pos = acc_pos + 1 in + debug "%s: assign position: %d <- %s" __FUNCTION__ pos (Dev.to_string dev) ; + let dev' = OrderedDev.assign_position dev pos in + (pos, dev' :: acc) + ) + (max_position, []) devs + |> snd + +let sort' ~(currents : Dev.t list) ~(rules : Rule.t list) + ~(last_order : OrderedDev.t list) : (OrderedDev.t list, error) result = + let open Dev in + let curr_macs = + currents |> List.map (fun dev -> dev.mac) |> MacaddrSet.of_list + in + let last_pcis = OrderedDev.map_by_pci last_order in + let ordered, unordered = + ([], currents) + |> assign_position_by_rules ~rules + |> assign_position_by_mac ~last_order + |> assign_position_by_pci ~last_pcis ~curr_macs + in + let ordered, remaining = + (* Split the unordered list into two: + multinics - the devices each share a PCI BUS ID with others (multinic function). + remaining - the deivces each occupy a PCI BUS ID exclusively. *) + let multinics, remaining = + unordered |> List.partition (fun dev -> dev.multi_nic) + in + let assigned_positions = + ordered |> List.map (fun dev -> dev.position) |> IntSet.of_list + in + let ordered', unordered' = + assign_position_for_multinic ~last_pcis ~assigned_positions multinics + in + (List.rev_append ordered ordered', List.rev_append remaining unordered') + in + let* m = OrderedDev.map_by_position ordered in + let removed = + last_order + |> List.filter_map (fun (dev : OrderedDev.t) -> + if MacaddrSet.mem dev.mac curr_macs then + None + else + Some {dev with present= false} + ) + |> List.filter (fun dev -> not (IntMap.mem dev.position m)) + in + let ordered = List.rev_append ordered removed in + let max_position = + List.fold_left + (fun max dev -> if max < dev.position then dev.position else max) + (-1) ordered + in + let new_order = + remaining + |> List.stable_sort compare_on_bios_eth_order + |> assign_position_for_remaining ~max_position + |> List.rev_append ordered + in + OrderedDev.validate_order new_order + +let sort last_order = + let* rules = Rule.read ~path:initial_rules_file_path in + let rules, last_order = + if last_order = [] then + (rules, []) + else + ([], last_order) + in + let* currents = Dev.get_all () in + currents + |> List.iter (fun x -> debug "%s current: %s" __FUNCTION__ (Dev.to_string x)) ; + let* new_order = sort' ~currents ~rules ~last_order in + new_order + |> List.iter (fun x -> + debug "%s new order: %s" __FUNCTION__ (OrderedDev.to_string x) + ) ; + + (* Find the NICs whose name changes *) + let* m = OrderedDev.map_by_position last_order in + let changes = + List.fold_left + (fun acc {position; name= curr; _} -> + match IntMap.find_opt position m with + | Some {name= last; _} when last <> curr -> + (last, curr) :: acc + | _ -> + acc + ) + [] new_order + in + Ok (new_order, changes) diff --git a/ocaml/networkd/lib/network_device_order.mli b/ocaml/networkd/lib/network_device_order.mli new file mode 100644 index 0000000000..8bd83a13ee --- /dev/null +++ b/ocaml/networkd/lib/network_device_order.mli @@ -0,0 +1,143 @@ +(* + * 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. + *) + +(** Generate an order for host network devices and keep the order as stable as + possible. *) + +type error = + | Pci_addr_parse_error of string + | Mac_addr_parse_error of string + | Rule_parse_error of string + | Missing_biosdevname_key of string + | Duplicate_mac_address + | Duplicate_position + | Invalid_biosdevname_key_value of (string * string) + +val string_of_error : error -> string +(** [string_of_error e] returns a string representation of the error [e]. *) + +(** PCI address in format SBDF: domain:bus:device:function *) +module Pciaddr : sig + (** Type of the PCI address *) + type t = Xcp_pci.address + + val of_string : string -> (t, error) result + (** [of_string s] returns [Ok pci] where [pci] is the PCI address converted + from [s]. Otherwise, it returns [Error error] whenever [s] can't be + parsed. [error] is for the parsing failure. *) + + val compare : t -> t -> int + (** [compare x y] return 0 if [x] is equal to [y]; a negative integer if [x] + is less than [y], and a positive integer if [x] is greater than [y]. *) +end + +module Macaddr : sig + type t = Macaddr.t + + val of_string : string -> (t, error) result + (** [of_string s] returns [Ok pci] where [pci] is the PCI address converted + from [s]. Otherwise, it returns [Error error] whenever [s] can't be + parsed. [error] is for the parsing failure. *) +end + +(** A rule specifies a position for a network device which can be identified by + MAC address, PCI address, or name label. *) +module Rule : sig + type index = + | Mac_addr of Macaddr.t + | Pci_addr of Pciaddr.t + | Label of string (** Type of mapping *) + + (** Type of one mapping configuration. *) + type t = {position: int; index: index} + + val read : path:string -> (t list, error) result + (** [read ~path] returns either [Ok rules], where [rules] are parsed from the + content of the file at [path], or [Error error], where [error] is the + reason for the parsing failure. The file at [path] contains lines in the + following format: + :="", where + label: means the is the name label of the device, + mac: means the is the MAC address of the device like + 00:02:C9:ED:FD:F0, + pci: means the is the PCI address (in SBDF format) of the device + locates at, like 0000:05:00.0. *) + + val matches : mac:Macaddr.t -> pci:Pciaddr.t -> label:string -> t -> bool + (** [true] if any of the [mac], [pci], or [label] meets the rule [t]. *) +end + +(** A network device recognized by biosdevname *) +module Dev : sig + (** Type of an network deivce parsed from the output of biosdevname. *) + type t = { + name: Network_interface.iface + ; mac: Network_interface.mac_address + ; pci: Xcp_pci.address + ; bios_eth_order: int + (** The in eth which is the value of "BIOS device" from output + of [biosdevname --policy all_ethN], is greater than or equal to 0. + *) + ; multi_nic: bool + (** [true] if there are other devices locate at the same PCI address. + Otherwise [false]. *) + } + + val get_all : unit -> (t list, error) result + (** [get_all ()] returns [Ok l], where l is a list of network devices parsed + from the output of biosdevname. Otherwise, it returns [Error error], where + [error] is the reason for the parsing failure. *) +end + +module IntMap : Map.S with type key = int + +(** A network device which has been assigned a postion in the order by sorting *) +module OrderedDev : sig + (** Type of an ordered network device. *) + type t = Network_interface.ordered_iface + + val map_by_position : t list -> (t IntMap.t, error) result + (** [map_by_position lst] returns [Ok map], where [map] is a map with values + from [lst] and their keys are positions. It returns + [Error Duplicate_position] if more than one value in [lst] has the same + position. *) + + val validate_order : t list -> (t list, error) result + (** [validate_order devs] returns [Ok lst], where [lst] is a list of devices + without duplicate MAC addresses or duplicate positions. Otherwise, + [Error error] is returned, where [error] is either Duplicate_position or + Duplicate_mac_address. *) + + val assign_position : Dev.t -> int -> Network_interface.ordered_iface + (** [assign_position dev pos] returns a device with [pos] assigned. *) +end + +val sort : + OrderedDev.t list + -> (OrderedDev.t list * (string * string) list, error) result +(** [sort last_order] sorts and generates an order based on [last_order]. It + returns [Ok (order, changes)], where [order] is a list of devices each + assigned unique positions, and [changes] is a list of pairs like + [(old, new)]. In these pairs, [old] is the name of the device from the + previous call to [sort], and [new] is the current name of the device. + It returns [Error error] when it fails to generate an order.[error] is the + reason for the failure. *) + +(* Below is exposed only for unit tests *) + +val sort' : + currents:Dev.t list + -> rules:Rule.t list + -> last_order:OrderedDev.t list + -> (OrderedDev.t list, error) result diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 1c8c8cd1a2..ca6153dae5 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -51,8 +51,6 @@ let ovs_ofctl = "/usr/bin/ovs-ofctl" let ovs_appctl = "/usr/bin/ovs-appctl" -let ovs_vlan_bug_workaround = "/usr/sbin/ovs-vlan-bug-workaround" - let brctl = ref "/sbin/brctl" let modprobe = "/sbin/modprobe" @@ -162,7 +160,8 @@ module Sysfs = struct with | End_of_file -> "" - | Unix.Unix_error (Unix.EINVAL, _, _) -> + | Unix.Unix_error (Unix.EINVAL, _, _) | Unix.Unix_error (Unix.ENOENT, _, _) + -> (* The device is not yet up *) raise (Network_error (Read_error file)) | exn -> @@ -180,18 +179,29 @@ module Sysfs = struct close_out outchan ; raise (Network_error (Write_error file)) - let is_physical name = + exception Unable_to_read_driver_link + + let is_vif name = + let devpath = getpath name "device" in try - let devpath = getpath name "device" in let driver_link = Unix.readlink (devpath ^ "/driver") in (* filter out symlinks under device/driver which look like /../../../devices/xen-backend/vif- *) - not - (List.mem "xen-backend" - (Astring.String.cuts ~empty:false ~sep:"/" driver_link) - ) + List.mem "xen-backend" + (Astring.String.cuts ~empty:false ~sep:"/" driver_link) + with _ -> raise Unable_to_read_driver_link + + let is_vf name = + let devpath = getpath name "device" in + try + ignore @@ Unix.readlink (devpath ^ "/physfn") ; + true with _ -> false + let is_physical name = + try not (is_vif name || is_vf name) + with Unable_to_read_driver_link -> false + (* device types are defined in linux/if_arp.h *) let is_ether_device name = match int_of_string (read_one_line (getpath name "type")) with @@ -262,25 +272,6 @@ module Sysfs = struct Result.Error (Fail_to_get_driver_name, "Failed to get driver name for: " ^ dev) - (** Returns the features bitmap for the driver for [dev]. The features bitmap - is a set of NETIF_F_ flags supported by its driver. *) - let get_features dev = - try Some (int_of_string (read_one_line (getpath dev "features"))) - with _ -> None - - (** Returns [true] if [dev] supports VLAN acceleration, [false] otherwise. *) - let has_vlan_accel dev = - let flag_NETIF_F_HW_VLAN_TX = 128 in - let flag_NETIF_F_HW_VLAN_RX = 256 in - let flag_NETIF_F_VLAN = - flag_NETIF_F_HW_VLAN_TX lor flag_NETIF_F_HW_VLAN_RX - in - match get_features dev with - | None -> - false - | Some features -> - features land flag_NETIF_F_VLAN <> 0 - let set_multicast_snooping bridge value = try let path = getpath bridge "bridge/multicast_snooping" in @@ -1340,44 +1331,6 @@ module Ovs = struct ) with _ -> warn "Failed to set max-idle=%d on OVS" t - let handle_vlan_bug_workaround override bridge = - (* This is a list of drivers that do support VLAN tx or rx acceleration, - but to which the VLAN bug workaround should not be applied. This could - be because these are known-good drivers (that is, they do not have any - of the bugs that the workaround avoids) or because the VLAN bug - workaround will not work for them and may cause other problems. - - This is a very short list because few drivers have been tested. *) - let no_vlan_workaround_drivers = ["bonding"] in - let phy_interfaces = - try - let interfaces = bridge_to_interfaces bridge in - List.filter Sysfs.is_physical interfaces - with _ -> [] - in - List.iter - (fun interface -> - let do_workaround = - match override with - | Some value -> - value - | None -> ( - match Sysfs.get_driver_name interface with - | None -> - Sysfs.has_vlan_accel interface - | Some driver -> - if List.mem driver no_vlan_workaround_drivers then - false - else - Sysfs.has_vlan_accel interface - ) - in - let setting = if do_workaround then "on" else "off" in - try ignore (call_script ovs_vlan_bug_workaround [interface; setting]) - with _ -> () - ) - phy_interfaces - let get_vlans name = try let vlans_with_uuid = @@ -1474,13 +1427,12 @@ module Ovs = struct ["--"; "--may-exist"; "add-port"; bridge; name] @ type_args let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping - ~fail_mode vlan vlan_bug_workaround name = + ~fail_mode vlan name = let vlan_arg = match vlan with | None -> [] | Some (parent, tag) -> - handle_vlan_bug_workaround vlan_bug_workaround parent ; [parent; string_of_int tag] in let mac_arg = @@ -1546,7 +1498,7 @@ module Ovs = struct let vif_arg = let existing_vifs = List.filter - (fun iface -> not (Sysfs.is_physical iface)) + (fun iface -> try Sysfs.is_vif iface with _ -> false) (bridge_to_interfaces name) in let ifaces_with_type = diff --git a/ocaml/networkd/test/dune b/ocaml/networkd/test/dune index b3519ce2ec..df6ac61ada 100644 --- a/ocaml/networkd/test/dune +++ b/ocaml/networkd/test/dune @@ -4,11 +4,14 @@ (libraries alcotest astring - fmt + macaddr networklibs rpclib.core rpclib.json + xapi-idl + xapi-idl.network + unix xapi-log xapi-test-utils) ) diff --git a/ocaml/networkd/test/network_test.ml b/ocaml/networkd/test/network_test.ml index 601fe8055b..e3c8029c79 100644 --- a/ocaml/networkd/test/network_test.ml +++ b/ocaml/networkd/test/network_test.ml @@ -15,4 +15,8 @@ let () = Debug.log_to_stdout () ; Alcotest.run "base_suite" - (Network_test_lacp_properties.suite @ Test_jsonrpc_client.tests) + (Network_test_lacp_properties.suite + @ Test_jsonrpc_client.tests + @ Test_network_device_order_inherited.tests + @ Test_network_device_order.tests + ) diff --git a/ocaml/networkd/test/test_network_device_order.ml b/ocaml/networkd/test/test_network_device_order.ml new file mode 100644 index 0000000000..b3fd21b89c --- /dev/null +++ b/ocaml/networkd/test/test_network_device_order.ml @@ -0,0 +1,478 @@ +(* + * 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. + *) + +open Network_device_order +open Network_interface + +let pci_addr0 = Pciaddr.of_string "0000:01:0f.0" |> Result.get_ok + +let pci_addr1 = Pciaddr.of_string "0000:01:0f.1" |> Result.get_ok + +let pci_addr2 = Pciaddr.of_string "0000:01:0f.2" |> Result.get_ok + +let pci_addr3 = Pciaddr.of_string "0000:01:0f.3" |> Result.get_ok + +let pci_addr4 = Pciaddr.of_string "0000:05:0f.0" |> Result.get_ok + +let mac_addr0 = Macaddr.of_string "ec:f4:bb:e6:d7:b8" |> Result.get_ok + +let mac_addr1 = Macaddr.of_string "ec:f4:bb:e6:d7:b9" |> Result.get_ok + +let mac_addr2 = Macaddr.of_string "ec:f4:bb:e6:d7:ba" |> Result.get_ok + +let mac_addr3 = Macaddr.of_string "ec:f4:bb:e6:d7:bb" |> Result.get_ok + +let mac_addr4 = Macaddr.of_string "00:02:c9:ed:fd:f0" |> Result.get_ok + +let mac_addr5 = Macaddr.of_string "00:02:c9:ed:fd:f1" |> Result.get_ok + +let name0 = "eno1" + +let name1 = "eno2" + +let name2 = "eno3" + +let name3 = "eno4" + +let name4 = "enp5s0" + +let name5 = "enp5s0d1" + +let seen_dev0 = + {name= name0; pci= pci_addr0; mac= mac_addr0; position= 0; present= true} + +let seen_dev1 = + {name= name1; pci= pci_addr1; mac= mac_addr1; position= 1; present= true} + +let seen_dev2 = + {name= name2; pci= pci_addr2; mac= mac_addr2; position= 2; present= true} + +let seen_dev3 = + {name= name3; pci= pci_addr3; mac= mac_addr3; position= 3; present= true} + +let seen_dev4 = + {name= name4; pci= pci_addr4; mac= mac_addr4; position= 4; present= true} + +let seen_dev5 = + {name= name5; pci= pci_addr4; mac= mac_addr5; position= 5; present= true} + +let dev0 = + { + Dev.name= name0 + ; pci= pci_addr0 + ; mac= mac_addr0 + ; bios_eth_order= 0 + ; multi_nic= false + } + +let dev1 = + { + Dev.name= name1 + ; pci= pci_addr1 + ; mac= mac_addr1 + ; bios_eth_order= 1 + ; multi_nic= false + } + +let dev2 = + { + Dev.name= name2 + ; pci= pci_addr2 + ; mac= mac_addr2 + ; bios_eth_order= 2 + ; multi_nic= false + } + +let dev3 = + { + Dev.name= name3 + ; pci= pci_addr3 + ; mac= mac_addr3 + ; bios_eth_order= 3 + ; multi_nic= false + } + +let dev4 = + { + Dev.name= name4 + ; pci= pci_addr4 + ; mac= mac_addr4 + ; bios_eth_order= 4 + ; multi_nic= true (* multinic: share PCI address with dev4 *) + } + +let dev5 = + { + Dev.name= name5 + ; pci= pci_addr4 + ; mac= mac_addr5 + ; bios_eth_order= 5 + ; multi_nic= true (* multinic: share PCI address with dev4 *) + } + +let plug dev devices = List.cons dev devices + +let unplug d devices = List.filter (fun dev -> dev.Dev.mac <> d.Dev.mac) devices + +let pos_of_mac mac order = + match List.find_opt (fun dev -> dev.mac = mac) order with + | Some {position; _} -> + position + | _ -> + -1 + +let present_of_mac mac order = + match List.find_opt (fun dev -> dev.mac = mac) order with + | Some {present; _} -> + present + | _ -> + failwith "Can't find the device!" + +let test_postion_and_present expected_position expected_present dev order = + let mac = dev.Dev.mac in + let name = Format.asprintf "Position assigned for %a" Macaddr.pp mac in + Alcotest.(check int) name expected_position (pos_of_mac mac order) ; + Alcotest.(check bool) name expected_present (present_of_mac mac order) + +let test_default () = + let currents = [dev0; dev1; dev2; dev3; dev4; dev5] in + let order = sort' ~currents ~rules:[] ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + (* The dev4 and dev5 are multinic functions. To assign initial positions, + they are sorted by MAC addresses. *) + test_postion_and_present 4 true dev4 order ; + test_postion_and_present 5 true dev5 order + +let test_unstable_bios_eth_order () = + let dev4 = {dev4 with mac= mac_addr5; bios_eth_order= 9} in + let dev5 = {dev5 with mac= mac_addr4; bios_eth_order= 10} in + let currents = [dev0; dev1; dev2; dev3; dev4; dev5] in + let order = sort' ~currents ~rules:[] ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + (* The dev4 and dev5 are multinic functions. To assign initial positions, + they are sorted by MAC addresses. *) + test_postion_and_present 5 true dev4 order ; + test_postion_and_present 4 true dev5 order + +let test_initial_rules_via_mac () = + let currents = [dev0; dev1; dev2; dev3; dev4; dev5] in + let rules = + Rule. + [ + {position= 0; index= Mac_addr mac_addr5} + ; {position= 1; index= Mac_addr mac_addr4} + ; {position= 2; index= Mac_addr mac_addr3} + ; {position= 3; index= Mac_addr mac_addr2} + ; {position= 4; index= Mac_addr mac_addr1} + ; {position= 5; index= Mac_addr mac_addr0} + ] + in + let order = sort' ~currents ~rules ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 5 true dev0 order ; + test_postion_and_present 4 true dev1 order ; + test_postion_and_present 3 true dev2 order ; + test_postion_and_present 2 true dev3 order ; + test_postion_and_present 1 true dev4 order ; + test_postion_and_present 0 true dev5 order + +let test_initial_rules_via_label () = + let currents = [dev0; dev1; dev2; dev3; dev4; dev5] in + let rules = + Rule. + [ + {position= 0; index= Label name5} + ; {position= 1; index= Label name4} + ; {position= 2; index= Label name3} + ; {position= 3; index= Label name2} + ; {position= 4; index= Label name1} + ; {position= 5; index= Label name0} + ] + in + let order = sort' ~currents ~rules ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 5 true dev0 order ; + test_postion_and_present 4 true dev1 order ; + test_postion_and_present 3 true dev2 order ; + test_postion_and_present 2 true dev3 order ; + test_postion_and_present 1 true dev4 order ; + test_postion_and_present 0 true dev5 order + +let test_replacement () = + let mac_addr0' = Macaddr.of_string "fc:f4:bb:e6:d7:b8" |> Result.get_ok in + let mac_addr1' = Macaddr.of_string "fc:f4:bb:e6:d7:b9" |> Result.get_ok in + let dev0' = + { + Dev.name= "eno10" + ; pci= pci_addr0 + ; mac= mac_addr0' + ; bios_eth_order= + 1 (* this order is not expected to take effect in this case *) + ; multi_nic= false + } + in + let dev1' = + { + Dev.name= "eno11" + ; pci= pci_addr1 + ; mac= mac_addr1' + ; bios_eth_order= + 0 (* this order is not expected to take effect in this case *) + ; multi_nic= false + } + in + let last_order = + [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4; seen_dev5] + in + let currents = + [dev0; dev1; dev2; dev3; dev4; dev5] + |> unplug dev0 + |> plug dev0' + |> unplug dev1 + |> plug dev1' + in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + + test_postion_and_present 0 true dev0' order ; + test_postion_and_present 1 true dev1' order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4 order ; + test_postion_and_present 5 true dev5 order + +let test_adding () = + let pci_addr6 = Pciaddr.of_string "0000:06:0f.0" |> Result.get_ok in + let mac_addr6 = Macaddr.of_string "fc:f4:bb:e6:d7:b8" |> Result.get_ok in + let pci_addr7 = Pciaddr.of_string "0000:06:0f.1" |> Result.get_ok in + let mac_addr7 = Macaddr.of_string "fc:f4:bb:e6:d7:b9" |> Result.get_ok in + let dev6 = + { + Dev.name= "eno6" + ; pci= pci_addr6 + ; mac= mac_addr6 + ; bios_eth_order= 1 (* This impacts the initial position *) + ; multi_nic= false + } + in + let dev7 = + { + Dev.name= "eno7" + ; pci= pci_addr7 + ; mac= mac_addr7 + ; bios_eth_order= 0 (* This impacts the initial position *) + ; multi_nic= false + } + in + let last_order = + [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4; seen_dev5] + in + (* Add two devices *) + let currents = + [dev0; dev1; dev2; dev3; dev4; dev5] |> plug dev6 |> plug dev7 + in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "8 devices in the order" 8 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4 order ; + test_postion_and_present 5 true dev5 order ; + (* The positions of newly added devices are impacted by the bios_eth_order *) + test_postion_and_present 6 true dev7 order ; + test_postion_and_present 7 true dev6 order + +let test_removing () = + let last_order = + [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4; seen_dev5] + in + (* Remove two devices *) + let currents = + [dev0; dev1; dev2; dev3; dev4; dev5] |> unplug dev0 |> unplug dev1 + in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 0 false dev0 order ; + test_postion_and_present 1 false dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4 order ; + test_postion_and_present 5 true dev5 order + +let test_replug_removed () = + (* Mark the devices as removed. *) + let seen_dev0 = {seen_dev0 with present= false} in + let seen_dev1 = {seen_dev1 with present= false} in + let last_order = + [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4; seen_dev5] + in + let currents = [dev2; dev3; dev4; dev5] |> plug dev0 |> plug dev1 in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4 order ; + test_postion_and_present 5 true dev5 order + +let test_multi_nic_inplace_reorder () = + (* The MAC addresses of multi_nic functions change *) + let mac_addr4' = Macaddr.of_string "01:02:c9:ed:fd:f0" |> Result.get_ok in + let mac_addr5' = Macaddr.of_string "01:02:c9:ed:fd:f1" |> Result.get_ok in + let dev4' = Dev.{dev4 with mac= mac_addr4'; bios_eth_order= 5} in + let dev5' = Dev.{dev5 with mac= mac_addr5'; bios_eth_order= 4} in + let last_order = + [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4; seen_dev5] + in + let currents = [dev0; dev1; dev2; dev3; dev4'; dev5'] in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4' order ; + test_postion_and_present 5 true dev5' order + +let test_multi_nic_new_devices () = + let mac_addr6 = Macaddr.of_string "01:02:c9:ed:fd:f0" |> Result.get_ok in + let mac_addr7 = Macaddr.of_string "01:02:c9:ed:fd:f1" |> Result.get_ok in + let dev6 = + Dev. + { + name= "enp5s0d2" + ; pci= pci_addr4 + ; mac= mac_addr6 + ; bios_eth_order= 1 + ; multi_nic= true (* multinic: share PCI address with dev4 *) + } + in + let dev7 = + Dev. + { + name= "enp5s0d3" + ; pci= pci_addr4 + ; mac= mac_addr7 + ; bios_eth_order= 0 + ; multi_nic= true (* multinic: share PCI address with dev4*) + } + in + (* New devices are reported on the same PCI address. + It's equivalent to plugging new devices but locate at the same PCI address. *) + let last_order = + [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4; seen_dev5] + in + let currents = + [dev0; dev1; dev2; dev3; dev4; dev5] |> plug dev6 |> plug dev7 + in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "8 devices in the order" 8 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4 order ; + test_postion_and_present 5 true dev5 order ; + test_postion_and_present 6 true dev6 order ; + test_postion_and_present 7 true dev7 order + +let test_pci_changes () = + let move_bus_by_1 pci_addr = Xcp_pci.{pci_addr with bus= pci_addr.bus + 1} in + let last_order = + [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4; seen_dev5] + in + let currents = + [dev0; dev1; dev2; dev3; dev4; dev5] + |> List.map (fun dev -> Dev.{dev with pci= move_bus_by_1 dev.pci}) + in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4 order ; + test_postion_and_present 5 true dev5 order + +let test_pci_addr_compare () = + let addr0 = Pciaddr.of_string "0000:01:0e.0" |> Result.get_ok in + let addr1 = Pciaddr.of_string "0000:01:0e.0" |> Result.get_ok in + let addr2 = Pciaddr.of_string "0000:01:0e.2" |> Result.get_ok in + let addr3 = Pciaddr.of_string "0000:01:0e.3" |> Result.get_ok in + let addr4 = Pciaddr.of_string "0000:01:0f.0" |> Result.get_ok in + let addr5 = Pciaddr.of_string "0000:02:0f.0" |> Result.get_ok in + let addr6 = Pciaddr.of_string "0001:02:0f.0" |> Result.get_ok in + Alcotest.(check bool) "equal" true (Pciaddr.compare addr0 addr1 = 0) ; + Alcotest.(check bool) "less than" true (Pciaddr.compare addr0 addr2 < 0) ; + Alcotest.(check bool) "greater than" true (Pciaddr.compare addr3 addr2 > 0) ; + Alcotest.(check bool) "greater than" true (Pciaddr.compare addr4 addr3 > 0) ; + Alcotest.(check bool) "greater than" true (Pciaddr.compare addr5 addr4 > 0) ; + Alcotest.(check bool) "less than" true (Pciaddr.compare addr6 addr5 > 0) + +let tests = + [ + ( "test_known_cases" + , [ + ("test_default", `Quick, test_default) + ; ("test_unstable_bios_eth_order", `Quick, test_unstable_bios_eth_order) + ; ("test_initial_mapping_via_mac", `Quick, test_initial_rules_via_mac) + ; ("test_initial_mapping_via_name", `Quick, test_initial_rules_via_label) + ; ("test_replacement", `Quick, test_replacement) + ; ("test_adding", `Quick, test_adding) + ; ("test_removing", `Quick, test_removing) + ; ("test_replug_removed", `Quick, test_replug_removed) + ; ( "test_multi_nic_inplace_reorder" + , `Quick + , test_multi_nic_inplace_reorder + ) + ; ("test_multi_nic_new_devices", `Quick, test_multi_nic_new_devices) + ; ("test_pci_changes", `Quick, test_pci_changes) + ; ("test_pci_addr_compare", `Quick, test_pci_addr_compare) + ] + ) + ] diff --git a/ocaml/networkd/test/test_network_device_order.mli b/ocaml/networkd/test/test_network_device_order.mli new file mode 100644 index 0000000000..c32d2a7e66 --- /dev/null +++ b/ocaml/networkd/test/test_network_device_order.mli @@ -0,0 +1,15 @@ +(* + * 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. + *) + +val tests : unit Alcotest.test list diff --git a/ocaml/networkd/test/test_network_device_order_inherited.ml b/ocaml/networkd/test/test_network_device_order_inherited.ml new file mode 100644 index 0000000000..1024c4c87f --- /dev/null +++ b/ocaml/networkd/test/test_network_device_order_inherited.ml @@ -0,0 +1,702 @@ +(* + * 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. + *) + +open Network_device_order +open Network_interface + +let pos_of_mac mac_addr order = + match List.find_opt (fun d -> d.mac = mac_addr) order with + | Some {position; _} -> + position + | _ -> + -1 + +let present_of_mac mac order = + match List.find_opt (fun dev -> dev.mac = mac) order with + | Some {present; _} -> + present + | _ -> + failwith "Can't find the device!" + +let test_postion_and_present expected_position expected_present dev order = + let mac = dev.Dev.mac in + let name = Format.asprintf "Position assigned for %a" Macaddr.pp mac in + Alcotest.(check int) name expected_position (pos_of_mac mac order) ; + Alcotest.(check bool) name expected_present (present_of_mac mac order) + +let test_newhw_norules_1eth () = + let mac_addr = Macaddr.of_string "ab:cd:ef:12:34:56" |> Result.get_ok in + let dev0 = + { + Dev.name= "side-12-eth1" + ; pci= Pciaddr.of_string "0000:00:0f.0" |> Result.get_ok + ; mac= mac_addr + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let currents = [dev0] in + let order = sort' ~currents ~rules:[] ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "1 device in the order" 1 (List.length order) ; + test_postion_and_present 0 true dev0 order + +let test_newhw_norules_2eth () = + let dev0 = + { + Dev.name= "side-12-eth1" + ; pci= Pciaddr.of_string "0000:00:0f.0" |> Result.get_ok + ; mac= Macaddr.of_string "ab:cd:ef:12:34:56" |> Result.get_ok + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let dev1 = + { + Dev.name= "side-33-eth0" + ; pci= Pciaddr.of_string "0000:00:01.0" |> Result.get_ok + ; mac= Macaddr.of_string "ab:cd:ef:12:34:57" |> Result.get_ok + ; bios_eth_order= 1 + ; multi_nic= false + } + in + let currents = [dev0; dev1] in + let order = sort' ~currents ~rules:[] ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "2 devices in the order" 2 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order + +let test_newhw_2srule_2eth () = + let mac_addr0 = Macaddr.of_string "12:34:56:78:90:12" |> Result.get_ok in + let mac_addr1 = Macaddr.of_string "ab:cd:ef:12:34:56" |> Result.get_ok in + let rules = + Rule. + [ + {position= 0; index= Mac_addr mac_addr1} + ; {position= 1; index= Mac_addr mac_addr0} + ] + in + let dev0 = + { + Dev.name= "eth0" + ; pci= Pciaddr.of_string "0000:00:01.0" |> Result.get_ok + ; mac= mac_addr0 + ; bios_eth_order= 1 + ; multi_nic= false + } + in + let dev1 = + { + Dev.name= "side-12-eth1" + ; pci= Pciaddr.of_string "0000:00:0f.0" |> Result.get_ok + ; mac= mac_addr1 + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let currents = [dev0; dev1] in + let order = sort' ~currents ~rules ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + test_postion_and_present 1 true dev0 order ; + test_postion_and_present 0 true dev1 order + +let test_nosrules_1eth_incorrect_udev () = + let mac_addr = Macaddr.of_string "ab:cd:ef:12:34:56" |> Result.get_ok in + let pci_addr = Pciaddr.of_string "0000:00:0f.0" |> Result.get_ok in + let dev0 = + { + Dev.name= "side-12-eth0" + ; pci= pci_addr + ; mac= mac_addr + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let currents = [dev0] in + let seen_dev0 = + {name= "eth2"; pci= pci_addr; mac= mac_addr; position= 3; present= true} + in + let last_order = [seen_dev0] in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + test_postion_and_present 3 true dev0 order + +let test_1srule_1eth_1last_correct_udev () = + let mac_addr = Macaddr.of_string "ab:cd:ef:12:34:56" |> Result.get_ok in + let pci_addr = Pciaddr.of_string "0000:00:0f.0" |> Result.get_ok in + let dev0 = + { + Dev.name= "eth1" + ; pci= pci_addr + ; mac= mac_addr + ; bios_eth_order= 1 + ; multi_nic= false + } + in + let currents = [dev0] in + let rules = Rule.[{position= 0; index= Mac_addr mac_addr}] in + let seen_dev0 = + {name= "eth1"; pci= pci_addr; mac= mac_addr; position= 1; present= true} + in + let last_order = [seen_dev0] in + let order = sort' ~currents ~rules ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "1 device in the order" 1 (List.length order) ; + test_postion_and_present 0 true dev0 order + +let test_1srule_1eth_already_complete () = + let mac_addr = Macaddr.of_string "00:13:72:2d:2a:ec" |> Result.get_ok in + let pci_addr = Pciaddr.of_string "0000:04:00.0" |> Result.get_ok in + let dev0 = + { + Dev.name= "eth0" + ; pci= pci_addr + ; mac= mac_addr + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let currents = [dev0] in + let rules = Rule.[{position= 0; index= Mac_addr mac_addr}] in + let order = sort' ~currents ~rules ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "1 device in the order" 1 (List.length order) ; + test_postion_and_present 0 true dev0 order + +let test_1drule_1eth_already_complete () = + let mac_addr = Macaddr.of_string "00:13:72:2d:2a:ec" |> Result.get_ok in + let pci_addr = Pciaddr.of_string "0000:04:00.0" |> Result.get_ok in + let dev0 = + { + Dev.name= "eth0" + ; pci= pci_addr + ; mac= mac_addr + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let currents = [dev0] in + let seen_dev0 = + {name= "eth0"; pci= pci_addr; mac= mac_addr; position= 0; present= true} + in + let last_order = [seen_dev0] in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "1 device in the order" 1 (List.length order) ; + test_postion_and_present 0 true dev0 order + +let test_usecase1 () = + let mac_addr0 = Macaddr.of_string "01:23:45:67:89:01" |> Result.get_ok in + let mac_addr1 = Macaddr.of_string "11:23:45:67:89:01" |> Result.get_ok in + let mac_addr2 = Macaddr.of_string "21:23:45:67:89:01" |> Result.get_ok in + let mac_addr3 = Macaddr.of_string "31:23:45:67:89:01" |> Result.get_ok in + let mac_addr4 = Macaddr.of_string "41:23:45:67:89:01" |> Result.get_ok in + let pci_addr0 = Pciaddr.of_string "0000:01:00.0" |> Result.get_ok in + let pci_addr1 = Pciaddr.of_string "0000:02:00.0" |> Result.get_ok in + let pci_addr2 = Pciaddr.of_string "0000:03:00.0" |> Result.get_ok in + let pci_addr3 = Pciaddr.of_string "0000:04:00.0" |> Result.get_ok in + let pci_addr4 = Pciaddr.of_string "0000:05:00.0" |> Result.get_ok in + + let dev0 = + { + Dev.name= "eth0" + ; pci= pci_addr0 + ; mac= mac_addr0 + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let dev1 = + { + Dev.name= "eth1" + ; pci= pci_addr1 + ; mac= mac_addr1 + ; bios_eth_order= 1 + ; multi_nic= false + } + in + let dev2 = + { + Dev.name= "eth2" + ; pci= pci_addr2 + ; mac= mac_addr2 + ; bios_eth_order= 2 + ; multi_nic= false + } + in + let dev3 = + { + Dev.name= "eth3" + ; pci= pci_addr3 + ; mac= mac_addr3 + ; bios_eth_order= 3 + ; multi_nic= false + } + in + let dev4 = + { + Dev.name= "eth4" + ; pci= pci_addr4 + ; mac= mac_addr4 + ; bios_eth_order= 4 + ; multi_nic= false + } + in + let currents = [dev0; dev1; dev2; dev3; dev4] in + let seen_dev0 = + {name= "eth0"; pci= pci_addr0; mac= mac_addr0; position= 0; present= true} + in + let seen_dev1 = + {name= "eth1"; pci= pci_addr1; mac= mac_addr1; position= 1; present= true} + in + let seen_dev2 = + {name= "eth2"; pci= pci_addr2; mac= mac_addr2; position= 2; present= true} + in + let seen_dev3 = + {name= "eth3"; pci= pci_addr3; mac= mac_addr3; position= 3; present= true} + in + let seen_dev4 = + {name= "eth4"; pci= pci_addr4; mac= mac_addr4; position= 4; present= true} + in + let last_order = [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4] in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "5 devices in the order" 5 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4 order + +let test_usecase5 () = + let mac_addr0' = Macaddr.of_string "02:23:45:67:89:01" |> Result.get_ok in + let mac_addr1' = Macaddr.of_string "12:23:45:67:89:01" |> Result.get_ok in + let mac_addr2' = Macaddr.of_string "22:23:45:67:89:01" |> Result.get_ok in + let mac_addr3' = Macaddr.of_string "32:23:45:67:89:01" |> Result.get_ok in + let mac_addr4' = Macaddr.of_string "42:23:45:67:89:01" |> Result.get_ok in + + let mac_addr0 = Macaddr.of_string "01:23:45:67:89:01" |> Result.get_ok in + let mac_addr1 = Macaddr.of_string "11:23:45:67:89:01" |> Result.get_ok in + let mac_addr2 = Macaddr.of_string "21:23:45:67:89:01" |> Result.get_ok in + let mac_addr3 = Macaddr.of_string "31:23:45:67:89:01" |> Result.get_ok in + let mac_addr4 = Macaddr.of_string "41:23:45:67:89:01" |> Result.get_ok in + + let pci_addr0 = Pciaddr.of_string "0000:01:00.0" |> Result.get_ok in + let pci_addr1 = Pciaddr.of_string "0000:02:00.0" |> Result.get_ok in + let pci_addr2 = Pciaddr.of_string "0000:03:00.0" |> Result.get_ok in + let pci_addr3 = Pciaddr.of_string "0000:04:00.0" |> Result.get_ok in + let pci_addr4 = Pciaddr.of_string "0000:05:00.0" |> Result.get_ok in + + let dev0 = + { + Dev.name= "side-1-eth0" + ; pci= pci_addr0 + ; mac= mac_addr0' + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let dev1 = + { + Dev.name= "side-34-eth1" + ; pci= pci_addr1 + ; mac= mac_addr1' + ; bios_eth_order= 1 + ; multi_nic= false + } + in + let dev2 = + { + Dev.name= "side-71-eth2" + ; pci= pci_addr2 + ; mac= mac_addr2' + ; bios_eth_order= 2 + ; multi_nic= false + } + in + let dev3 = + { + Dev.name= "side-3012-eth3" + ; pci= pci_addr3 + ; mac= mac_addr3' + ; bios_eth_order= 3 + ; multi_nic= false + } + in + let dev4 = + { + Dev.name= "side-4332-eth4" + ; pci= pci_addr4 + ; mac= mac_addr4' + ; bios_eth_order= 4 + ; multi_nic= false + } + in + let currents = [dev0; dev1; dev2; dev3; dev4] in + let seen_dev0 = + {name= "eth0"; pci= pci_addr0; mac= mac_addr0; position= 0; present= true} + in + let seen_dev1 = + {name= "eth1"; pci= pci_addr1; mac= mac_addr1; position= 1; present= true} + in + let seen_dev2 = + {name= "eth2"; pci= pci_addr2; mac= mac_addr2; position= 2; present= true} + in + let seen_dev3 = + {name= "eth3"; pci= pci_addr3; mac= mac_addr3; position= 3; present= true} + in + let seen_dev4 = + {name= "eth4"; pci= pci_addr4; mac= mac_addr4; position= 4; present= true} + in + let last_order = [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4] in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "5 devices in the order" 5 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 3 true dev3 order ; + test_postion_and_present 4 true dev4 order + +let test_CA_94279 () = + let mac_addr0 = Macaddr.of_string "00:1b:21:aa:ef:f0" |> Result.get_ok in + let mac_addr1 = Macaddr.of_string "00:1b:21:aa:ef:f1" |> Result.get_ok in + let mac_addr2 = Macaddr.of_string "00:1b:21:aa:ef:f4" |> Result.get_ok in + let mac_addr3 = Macaddr.of_string "00:1b:21:aa:ef:f5" |> Result.get_ok in + let mac_addr4 = Macaddr.of_string "60:eb:69:ed:9a:16" |> Result.get_ok in + let mac_addr5 = Macaddr.of_string "60:eb:69:ed:9a:17" |> Result.get_ok in + + let pci_addr0 = Pciaddr.of_string "0000:03:00.0" |> Result.get_ok in + let pci_addr1 = Pciaddr.of_string "0000:03:00.1" |> Result.get_ok in + let pci_addr2 = Pciaddr.of_string "0000:04:00.0" |> Result.get_ok in + let pci_addr3 = Pciaddr.of_string "0000:04:00.1" |> Result.get_ok in + let pci_addr4 = Pciaddr.of_string "0000:06:00.0" |> Result.get_ok in + let pci_addr5 = Pciaddr.of_string "0000:06:00.1" |> Result.get_ok in + + let dev0 = + { + Dev.name= "side-1-eth0" + ; pci= pci_addr0 + ; mac= mac_addr0 + ; bios_eth_order= 2 + ; multi_nic= false + } + in + let dev1 = + { + Dev.name= "side-2-eth1" + ; pci= pci_addr1 + ; mac= mac_addr1 + ; bios_eth_order= 3 + ; multi_nic= false + } + in + let dev2 = + { + Dev.name= "side-3-eth2" + ; pci= pci_addr2 + ; mac= mac_addr2 + ; bios_eth_order= 4 + ; multi_nic= false + } + in + let dev3 = + { + Dev.name= "side-4-eth3" + ; pci= pci_addr3 + ; mac= mac_addr3 + ; bios_eth_order= 5 + ; multi_nic= false + } + in + let dev4 = + { + Dev.name= "side-5-eth4" + ; pci= pci_addr4 + ; mac= mac_addr4 + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let dev5 = + { + Dev.name= "side-6-eth5" + ; pci= pci_addr5 + ; mac= mac_addr5 + ; bios_eth_order= 1 + ; multi_nic= false + } + in + let currents = [dev0; dev1; dev2; dev3; dev4; dev5] in + let order = sort' ~currents ~rules:[] ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "6 devices in the order" 6 (List.length order) ; + test_postion_and_present 2 true dev0 order ; + test_postion_and_present 3 true dev1 order ; + test_postion_and_present 4 true dev2 order ; + test_postion_and_present 5 true dev3 order ; + test_postion_and_present 0 true dev4 order ; + test_postion_and_present 1 true dev5 order + +let test_rshp_new_hardware () = + let mac_addr0' = Macaddr.of_string "02:23:45:67:89:01" |> Result.get_ok in + let mac_addr1' = Macaddr.of_string "12:23:45:67:89:01" |> Result.get_ok in + let mac_addr2' = Macaddr.of_string "22:23:45:67:89:01" |> Result.get_ok in + let mac_addr3' = Macaddr.of_string "32:23:45:67:89:01" |> Result.get_ok in + let mac_addr4' = Macaddr.of_string "32:23:45:67:89:02" |> Result.get_ok in + + let pci_addr0 = Pciaddr.of_string "0000:01:00.0" |> Result.get_ok in + let pci_addr1 = Pciaddr.of_string "0000:02:00.0" |> Result.get_ok in + let pci_addr2 = Pciaddr.of_string "0000:03:00.0" |> Result.get_ok in + let pci_addr3 = Pciaddr.of_string "0000:04:00.0" |> Result.get_ok in + + let mac_addr0 = Macaddr.of_string "01:23:45:67:89:01" |> Result.get_ok in + let mac_addr1 = Macaddr.of_string "11:23:45:67:89:01" |> Result.get_ok in + let mac_addr2 = Macaddr.of_string "21:23:45:67:89:01" |> Result.get_ok in + let mac_addr3 = Macaddr.of_string "31:23:45:67:89:02" |> Result.get_ok in + let mac_addr4 = Macaddr.of_string "31:23:45:67:89:01" |> Result.get_ok in + + let dev0 = + { + Dev.name= "side-1-eth0" + ; pci= pci_addr0 + ; mac= mac_addr0' + ; bios_eth_order= 0 + ; multi_nic= false + } + in + + let dev1 = + { + Dev.name= "side-34-eth1" + ; pci= pci_addr1 + ; mac= mac_addr1' + ; bios_eth_order= 1 + ; multi_nic= false + } + in + let dev2 = + { + Dev.name= "side-71-eth2" + ; pci= pci_addr2 + ; mac= mac_addr2' + ; bios_eth_order= 2 + ; multi_nic= false + } + in + + let dev3 = + { + Dev.name= "side-3012-eth3" + ; pci= pci_addr3 + ; mac= mac_addr3' + ; bios_eth_order= 3 + ; multi_nic= true + } + in + let dev4 = + { + Dev.name= "side-4332-eth4" + ; pci= pci_addr3 + ; mac= mac_addr4' + ; bios_eth_order= 4 + ; multi_nic= true + } + in + let seen_dev0 = + {name= "eth0"; pci= pci_addr0; mac= mac_addr0; position= 0; present= true} + in + let seen_dev1 = + {name= "eth1"; pci= pci_addr1; mac= mac_addr1; position= 1; present= true} + in + let seen_dev2 = + {name= "eth2"; pci= pci_addr2; mac= mac_addr2; position= 2; present= true} + in + let seen_dev3 = + {name= "eth3"; pci= pci_addr3; mac= mac_addr3; position= 3; present= true} + in + let seen_dev4 = + {name= "eth4"; pci= pci_addr3; mac= mac_addr4; position= 4; present= true} + in + let currents = [dev0; dev1; dev2; dev3; dev4] in + let last_order = [seen_dev0; seen_dev1; seen_dev2; seen_dev3; seen_dev4] in + let order = sort' ~currents ~rules:[] ~last_order in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "5 devices in the order" 5 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 4 true dev3 order ; + test_postion_and_present 3 true dev4 order + +let test_bad_biosdevname_order () = + let pci_addr0 = Pciaddr.of_string "0000:01:00.0" |> Result.get_ok in + let pci_addr1 = Pciaddr.of_string "0000:02:00.0" |> Result.get_ok in + let pci_addr4 = Pciaddr.of_string "0000:03:00.0" |> Result.get_ok in + let pci_addr5 = Pciaddr.of_string "0000:04:00.0" |> Result.get_ok in + let pci_addr8 = Pciaddr.of_string "0000:05:00.0" |> Result.get_ok in + + let mac_addr0 = Macaddr.of_string "00:00:00:00:00:01" |> Result.get_ok in + let mac_addr1 = Macaddr.of_string "00:00:44:00:01:01" |> Result.get_ok in + let mac_addr2 = Macaddr.of_string "00:00:44:00:01:02" |> Result.get_ok in + let mac_addr3 = Macaddr.of_string "00:00:44:00:01:03" |> Result.get_ok in + let mac_addr4 = Macaddr.of_string "00:00:00:00:02:01" |> Result.get_ok in + let mac_addr5 = Macaddr.of_string "00:00:22:00:03:01" |> Result.get_ok in + let mac_addr6 = Macaddr.of_string "00:00:22:00:03:02" |> Result.get_ok in + let mac_addr7 = Macaddr.of_string "00:00:22:00:03:03" |> Result.get_ok in + let mac_addr8 = Macaddr.of_string "00:00:00:00:04:01" |> Result.get_ok in + + let dev0 = + { + Dev.name= "side-0-eth0" + ; pci= pci_addr0 + ; mac= mac_addr0 + ; bios_eth_order= 0 + ; multi_nic= false + } + in + let dev1 = + { + Dev.name= "side-0-eth2" + ; pci= pci_addr1 + ; mac= mac_addr1 + ; bios_eth_order= 2 + ; multi_nic= true + } + in + let dev2 = + { + Dev.name= "side-0-eth6" + ; pci= pci_addr1 + ; mac= mac_addr2 + ; bios_eth_order= 6 + ; multi_nic= true + } + in + let dev3 = + { + Dev.name= "side-0-eth1" + ; pci= pci_addr1 + ; mac= mac_addr3 + ; bios_eth_order= 1 + ; multi_nic= true + } + in + let dev4 = + { + Dev.name= "side-0-eth4" + ; pci= pci_addr4 + ; mac= mac_addr4 + ; bios_eth_order= 4 + ; multi_nic= true + } + in + let dev5 = + { + Dev.name= "side-0-eth5" + ; pci= pci_addr5 + ; mac= mac_addr5 + ; bios_eth_order= 7 + ; multi_nic= true + } + in + let dev6 = + { + Dev.name= "side-0-eth3" + ; pci= pci_addr5 + ; mac= mac_addr6 + ; bios_eth_order= 3 + ; multi_nic= true + } + in + let dev7 = + { + Dev.name= "side-0-eth7" + ; pci= pci_addr5 + ; mac= mac_addr7 + ; bios_eth_order= 5 + ; multi_nic= true + } + in + let dev8 = + { + Dev.name= "side-0-eth8" + ; pci= pci_addr8 + ; mac= mac_addr8 + ; bios_eth_order= 8 + ; multi_nic= false + } + in + let currents = [dev0; dev1; dev2; dev3; dev4; dev5; dev6; dev7; dev8] in + let order = sort' ~currents ~rules:[] ~last_order:[] in + Alcotest.(check bool) "is Ok" true (Result.is_ok order) ; + let order = Result.get_ok order in + Alcotest.(check int) "9 devices in the order" 9 (List.length order) ; + test_postion_and_present 0 true dev0 order ; + test_postion_and_present 1 true dev1 order ; + test_postion_and_present 2 true dev2 order ; + test_postion_and_present 6 true dev3 order ; + test_postion_and_present 4 true dev4 order ; + test_postion_and_present 3 true dev5 order ; + test_postion_and_present 5 true dev6 order ; + test_postion_and_present 7 true dev7 order ; + test_postion_and_present 8 true dev8 order + +let tests = + [ + ( "test_simple_logic" + , [ + ("test_newhw_norules_1eth", `Quick, test_newhw_norules_1eth) + ; ("test_newhw_norules_2eth", `Quick, test_newhw_norules_2eth) + ; ("test_newhw_2srule_2eth", `Quick, test_newhw_2srule_2eth) + ; ( "test_nosrules_1eth_incorrect_udev" + , `Quick + , test_nosrules_1eth_incorrect_udev + ) + ; ( "test_1srule_1eth_1last_correct_udev" + , `Quick + , test_1srule_1eth_1last_correct_udev + ) + ; ( "test_1srule_1eth_already_complete" + , `Quick + , test_1srule_1eth_already_complete + ) + ; ( "test_1drule_1eth_already_complete" + , `Quick + , test_1drule_1eth_already_complete + ) + ] + ) + ; ( "test_use_cases" + , [ + ("test_usecase1", `Quick, test_usecase1) + ; ("test_usecase5", `Quick, test_usecase5) + ; ("test_CA_94279", `Quick, test_CA_94279) + ; ("test_rshp_new_hardware", `Quick, test_rshp_new_hardware) + ; ("test_bad_biosdevname_order", `Quick, test_bad_biosdevname_order) + ] + ) + ] diff --git a/ocaml/networkd/test/test_network_device_order_inherited.mli b/ocaml/networkd/test/test_network_device_order_inherited.mli new file mode 100644 index 0000000000..c32d2a7e66 --- /dev/null +++ b/ocaml/networkd/test/test_network_device_order_inherited.mli @@ -0,0 +1,15 @@ +(* + * 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. + *) + +val tests : unit Alcotest.test list diff --git a/ocaml/qcow-stream-tool/dune b/ocaml/qcow-stream-tool/dune new file mode 100644 index 0000000000..4daf3469dc --- /dev/null +++ b/ocaml/qcow-stream-tool/dune @@ -0,0 +1,11 @@ +(executable + (modes exe) + (name qcow_stream_tool) + (public_name qcow-stream-tool) + (package qcow-stream-tool) + (libraries + qcow-stream + cmdliner + unix + ) +) diff --git a/ocaml/qcow-stream-tool/qcow_stream_tool.ml b/ocaml/qcow-stream-tool/qcow_stream_tool.ml new file mode 100644 index 0000000000..7158867c24 --- /dev/null +++ b/ocaml/qcow-stream-tool/qcow_stream_tool.ml @@ -0,0 +1,29 @@ +module Impl = struct + let stream_decode output = + Qcow_stream.stream_decode Unix.stdin output ; + `Ok () +end + +module Cli = struct + open Cmdliner + + let stream_decode_cmd = + let doc = "decode qcow2 formatted data from stdin and write a raw image" in + let man = + [ + `S "DESCRIPTION" + ; `P "Decode qcow2 formatted data from stdin and write to a raw file." + ] + in + let output default = + let doc = Printf.sprintf "Path to the output file." in + Arg.(value & pos 0 string default & info [] ~doc) + in + Cmd.v + (Cmd.info "stream_decode" ~doc ~man) + Term.(ret (const Impl.stream_decode $ output "test.raw")) + + let main () = Cmd.eval stream_decode_cmd +end + +let () = exit (Cli.main ()) diff --git a/ocaml/qcow-stream-tool/qcow_stream_tool.mli b/ocaml/qcow-stream-tool/qcow_stream_tool.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/ocaml/quicktest/quicktest_vdi.ml b/ocaml/quicktest/quicktest_vdi.ml index 787e192d3d..b62ce0beb8 100644 --- a/ocaml/quicktest/quicktest_vdi.ml +++ b/ocaml/quicktest/quicktest_vdi.ml @@ -1,5 +1,9 @@ module A = Quicktest_args +let ( let@ ) f x = f x + +let tags = ["quick"; "test"] + (** If VDI_CREATE and VDI_DELETE are present then make sure VDIs appear and disappear correctly VDI_CREATE should make a fresh disk; VDI_DELETE should remove it *) let vdi_create_destroy rpc session_id sr_info () = @@ -67,109 +71,99 @@ let choose_active_pbd rpc session_id sr = (** If VDI_GENERATE_CONFIG is present then try it out *) let vdi_generate_config_test rpc session_id sr_info () = - Qt.VDI.with_any rpc session_id sr_info (fun vdi -> - let sr = sr_info.Qt.sr in - let pbd = choose_active_pbd rpc session_id sr in - let host = Client.Client.PBD.get_host ~rpc ~session_id ~self:pbd in - Alcotest.(check unit) - "VDI_GENERATE_CONFIG should not fail" () - ((Client.Client.VDI.generate_config ~rpc ~session_id ~host ~vdi : string) - |> ignore - ) - ) + let@ vdi = Qt.VDI.with_any rpc session_id sr_info in + let sr = sr_info.Qt.sr in + let pbd = choose_active_pbd rpc session_id sr in + let host = Client.Client.PBD.get_host ~rpc ~session_id ~self:pbd in + Alcotest.(check unit) + "VDI_GENERATE_CONFIG should not fail" () + ((Client.Client.VDI.generate_config ~rpc ~session_id ~host ~vdi : string) + |> ignore + ) (** If VDI_UPDATE is present then try it out *) let vdi_update_test rpc session_id sr_info () = - Qt.VDI.with_any rpc session_id sr_info (fun vdi -> - Alcotest.(check unit) - "VDI_UPDATE should not fail" () - (Client.Client.VDI.update ~rpc ~session_id ~vdi) - ) + let@ vdi = Qt.VDI.with_any rpc session_id sr_info in + Alcotest.(check unit) + "VDI_UPDATE should not fail" () + (Client.Client.VDI.update ~rpc ~session_id ~vdi) (** If VDI_RESIZE is present then try it out *) let vdi_resize_test rpc session_id sr_info () = - Qt.VDI.with_new rpc session_id sr_info.Qt.sr (fun vdi -> - let current = - Client.Client.VDI.get_virtual_size ~rpc ~session_id ~self:vdi - in - print_endline (Printf.sprintf "current size = %Ld" current) ; - (* Make it 1 MiB bigger *) - let new_size = Int64.add current 1048576L in - print_endline (Printf.sprintf "requested size = %Ld" new_size) ; - Client.Client.VDI.resize ~rpc ~session_id ~vdi ~size:new_size ; - let actual_size = - Client.Client.VDI.get_virtual_size ~rpc ~session_id ~self:vdi - in - print_endline (Printf.sprintf "final size = %Ld" actual_size) ; - if actual_size < new_size then - Alcotest.fail "The final size should be >= the requested size" - ) + let@ vdi = Qt.VDI.with_new rpc session_id sr_info.Qt.sr in + let current = Client.Client.VDI.get_virtual_size ~rpc ~session_id ~self:vdi in + print_endline (Printf.sprintf "current size = %Ld" current) ; + (* Make it 1 MiB bigger *) + let new_size = Int64.add current 1048576L in + print_endline (Printf.sprintf "requested size = %Ld" new_size) ; + Client.Client.VDI.resize ~rpc ~session_id ~vdi ~size:new_size ; + let actual_size = + Client.Client.VDI.get_virtual_size ~rpc ~session_id ~self:vdi + in + print_endline (Printf.sprintf "final size = %Ld" actual_size) ; + if actual_size < new_size then + Alcotest.fail "The final size should be >= the requested size" (** Make sure that I can't call VDI.db_forget VDI.db_forget should always fail without authorisation *) let vdi_db_forget rpc session_id sr_info () = - Qt.VDI.with_any rpc session_id sr_info (fun vdi -> - try - Client.Client.VDI.db_forget ~rpc ~session_id ~vdi ; - Alcotest.fail "Call succeeded but it shouldn't have" - with - | Api_errors.Server_error (code, _) - when code = Api_errors.permission_denied -> - print_endline "Caught PERMISSION_DENIED" - | e -> - Alcotest.fail - (Printf.sprintf "Caught wrong error: %s" (Printexc.to_string e)) - ) + let@ vdi = Qt.VDI.with_any rpc session_id sr_info in + try + Client.Client.VDI.db_forget ~rpc ~session_id ~vdi ; + Alcotest.fail "Call succeeded but it shouldn't have" + with + | Api_errors.Server_error (code, _) when code = Api_errors.permission_denied + -> + print_endline "Caught PERMISSION_DENIED" + | e -> + Alcotest.fail + (Printf.sprintf "Caught wrong error: %s" (Printexc.to_string e)) (** If VDI_INTRODUCE is present then attempt to introduce a VDI with a duplicate location and another with a bad UUID to make sure that is reported as an error *) let vdi_bad_introduce rpc session_id sr_info () = - Qt.VDI.with_any rpc session_id sr_info (fun vdi -> - let vdir = Client.Client.VDI.get_record ~rpc ~session_id ~self:vdi in - ( try - print_endline - (Printf.sprintf "Introducing a VDI with a duplicate UUID (%s)" - vdir.API.vDI_uuid - ) ; - let (_ : API.ref_VDI) = - Client.Client.VDI.introduce ~rpc ~session_id ~uuid:vdir.API.vDI_uuid - ~name_label:"bad uuid" ~name_description:"" ~sR:vdir.API.vDI_SR - ~_type:vdir.API.vDI_type ~sharable:false ~read_only:false - ~other_config:[] - ~location:(Ref.string_of (Ref.make ())) - ~xenstore_data:[] ~sm_config:[] ~managed:true ~virtual_size:0L - ~physical_utilisation:0L ~metadata_of_pool:Ref.null - ~is_a_snapshot:false ~snapshot_time:Clock.Date.epoch - ~snapshot_of:Ref.null - in - Alcotest.fail - "vdi_bad_introduce: A bad VDI with a duplicate UUID was introduced" - with Api_errors.Server_error (_, _) as e -> - Printf.printf "API error caught as expected: %s\n" - (Printexc.to_string e) + let@ vdi = Qt.VDI.with_any rpc session_id sr_info in + let vdir = Client.Client.VDI.get_record ~rpc ~session_id ~self:vdi in + ( try + print_endline + (Printf.sprintf "Introducing a VDI with a duplicate UUID (%s)" + vdir.API.vDI_uuid + ) ; + let (_ : API.ref_VDI) = + Client.Client.VDI.introduce ~rpc ~session_id ~uuid:vdir.API.vDI_uuid + ~name_label:"bad uuid" ~name_description:"" ~sR:vdir.API.vDI_SR + ~_type:vdir.API.vDI_type ~sharable:false ~read_only:false + ~other_config:[] + ~location:(Ref.string_of (Ref.make ())) + ~xenstore_data:[] ~sm_config:[] ~managed:true ~virtual_size:0L + ~physical_utilisation:0L ~metadata_of_pool:Ref.null + ~is_a_snapshot:false ~snapshot_time:Clock.Date.epoch + ~snapshot_of:Ref.null + in + Alcotest.fail + "vdi_bad_introduce: A bad VDI with a duplicate UUID was introduced" + with Api_errors.Server_error (_, _) as e -> + Printf.printf "API error caught as expected: %s\n" (Printexc.to_string e) + ) ; + try + print_endline + (Printf.sprintf "Introducing a VDI with a duplicate location (%s)" + vdir.API.vDI_location ) ; - try - print_endline - (Printf.sprintf "Introducing a VDI with a duplicate location (%s)" - vdir.API.vDI_location - ) ; - let (_ : API.ref_VDI) = - Client.Client.VDI.introduce ~rpc ~session_id - ~uuid:(Uuidx.to_string (Uuidx.make ())) - ~name_label:"bad location" ~name_description:"" ~sR:vdir.API.vDI_SR - ~_type:vdir.API.vDI_type ~sharable:false ~read_only:false - ~other_config:[] ~location:vdir.API.vDI_location ~xenstore_data:[] - ~sm_config:[] ~managed:true ~virtual_size:0L - ~physical_utilisation:0L ~metadata_of_pool:Ref.null - ~is_a_snapshot:false ~snapshot_time:Clock.Date.epoch - ~snapshot_of:Ref.null - in - Alcotest.fail - "vdi_bad_introduce: A bad VDI with a duplicate location was \ - introduced" - with Api_errors.Server_error (_, _) as e -> - Printf.printf "API error caught as expected: %s\n" (Printexc.to_string e) - ) + let (_ : API.ref_VDI) = + Client.Client.VDI.introduce ~rpc ~session_id + ~uuid:(Uuidx.to_string (Uuidx.make ())) + ~name_label:"bad location" ~name_description:"" ~sR:vdir.API.vDI_SR + ~_type:vdir.API.vDI_type ~sharable:false ~read_only:false + ~other_config:[] ~location:vdir.API.vDI_location ~xenstore_data:[] + ~sm_config:[] ~managed:true ~virtual_size:0L ~physical_utilisation:0L + ~metadata_of_pool:Ref.null ~is_a_snapshot:false + ~snapshot_time:Clock.Date.epoch ~snapshot_of:Ref.null + in + Alcotest.fail + "vdi_bad_introduce: A bad VDI with a duplicate location was introduced" + with Api_errors.Server_error (_, _) as e -> + Printf.printf "API error caught as expected: %s\n" (Printexc.to_string e) (** When cloning/snapshotting perform field by field comparisons to look for problems *) @@ -183,6 +177,7 @@ let check_clone_snapshot_fields rpc session_id original_vdi new_vdi = , fun vdi -> vdi.API.vDI_virtual_size |> Int64.to_string ) ; (`Different, "location", fun vdi -> vdi.API.vDI_location) + ; (`Same, "tags", fun vdi -> String.concat ", " vdi.API.vDI_tags) ] in let a = Client.Client.VDI.get_record ~rpc ~session_id ~self:original_vdi in @@ -194,35 +189,31 @@ let check_vdi_snapshot rpc session_id vdi = let snapshot_vdi = Client.Client.VDI.snapshot ~rpc ~session_id ~vdi ~driver_params:[] in - Qt.VDI.with_destroyed rpc session_id snapshot_vdi (fun () -> - let snapshot_finish = Qt.Time.now () in - let r = - Client.Client.VDI.get_record ~rpc ~session_id ~self:snapshot_vdi - in - Qt.Time.(check (of_field r.API.vDI_snapshot_time)) - ~after:snapshot_start ~before:snapshot_finish ; - Alcotest.(check bool) - "VDI.is_a_snapshot of must be true for snapshot VDI" true - r.API.vDI_is_a_snapshot ; - Alcotest.(check bool) - "VDI.snapshot_of must not be null for snapshot VDI" true - (r.API.vDI_snapshot_of <> API.Ref.null) ; - check_clone_snapshot_fields rpc session_id vdi snapshot_vdi ; - Qt.VDI.test_update rpc session_id snapshot_vdi - ) + let@ () = Qt.VDI.with_destroyed rpc session_id snapshot_vdi in + let snapshot_finish = Qt.Time.now () in + let r = Client.Client.VDI.get_record ~rpc ~session_id ~self:snapshot_vdi in + Qt.Time.(check (of_field r.API.vDI_snapshot_time)) + ~after:snapshot_start ~before:snapshot_finish ; + Alcotest.(check bool) + "VDI.is_a_snapshot of must be true for snapshot VDI" true + r.API.vDI_is_a_snapshot ; + Alcotest.(check bool) + "VDI.snapshot_of must not be null for snapshot VDI" true + (r.API.vDI_snapshot_of <> API.Ref.null) ; + check_clone_snapshot_fields rpc session_id vdi snapshot_vdi ; + Qt.VDI.test_update rpc session_id snapshot_vdi let test_vdi_snapshot rpc session_id sr_info () = - Qt.VDI.with_any rpc session_id sr_info (check_vdi_snapshot rpc session_id) + let@ vdi = Qt.VDI.with_any rpc session_id sr_info in + Client.Client.VDI.set_tags ~rpc ~session_id ~self:vdi ~value:tags ; + check_vdi_snapshot rpc session_id vdi let test_vdi_clone rpc session_id sr_info () = - Qt.VDI.with_any rpc session_id sr_info (fun vdi -> - let vdi' = - Client.Client.VDI.clone ~rpc ~session_id ~vdi ~driver_params:[] - in - Qt.VDI.with_destroyed rpc session_id vdi' (fun () -> - check_clone_snapshot_fields rpc session_id vdi vdi' - ) - ) + let@ vdi = Qt.VDI.with_any rpc session_id sr_info in + Client.Client.VDI.set_tags ~rpc ~session_id ~self:vdi ~value:tags ; + let vdi' = Client.Client.VDI.clone ~rpc ~session_id ~vdi ~driver_params:[] in + let@ () = Qt.VDI.with_destroyed rpc session_id vdi' in + check_clone_snapshot_fields rpc session_id vdi vdi' (* Helper function to make a VBD *) let vbd_create_helper ~rpc ~session_id ~vM ~vDI ?(userdevice = "autodetect") () @@ -234,28 +225,25 @@ let vbd_create_helper ~rpc ~session_id ~vM ~vDI ?(userdevice = "autodetect") () (** Check that snapshot works regardless which host has the VDI activated *) let vdi_snapshot_in_pool rpc session_id sr_info () = - Qt.VDI.with_any rpc session_id sr_info (fun vdi -> - let localhost = - Client.Client.Host.get_by_uuid ~rpc ~session_id ~uuid:Qt.localhost_uuid - in - let do_test () = check_vdi_snapshot rpc session_id vdi in - let test_snapshot_on host = - let name = - Client.Client.Host.get_name_label ~rpc ~session_id ~self:host - in - let dom0 = Qt.VM.dom0_of_host rpc session_id host in - let vbd = vbd_create_helper ~rpc ~session_id ~vM:dom0 ~vDI:vdi () in - print_endline (Printf.sprintf "Plugging in to host %s" name) ; - Client.Client.VBD.plug ~rpc ~session_id ~self:vbd ; - Xapi_stdext_pervasives.Pervasiveext.finally do_test (fun () -> - print_endline (Printf.sprintf "Unplugging from host %s" name) ; - Client.Client.VBD.unplug ~rpc ~session_id ~self:vbd ; - print_endline "Destroying VBD" ; - Client.Client.VBD.destroy ~rpc ~session_id ~self:vbd - ) - in - test_snapshot_on localhost ; do_test () - ) + let@ vdi = Qt.VDI.with_any rpc session_id sr_info in + Client.Client.VDI.set_tags ~rpc ~session_id ~self:vdi ~value:tags ; + let localhost = + Client.Client.Host.get_by_uuid ~rpc ~session_id ~uuid:Qt.localhost_uuid + in + let do_test () = check_vdi_snapshot rpc session_id vdi in + let test_snapshot_on host = + let name = Client.Client.Host.get_name_label ~rpc ~session_id ~self:host in + let dom0 = Qt.VM.dom0_of_host rpc session_id host in + let vbd = vbd_create_helper ~rpc ~session_id ~vM:dom0 ~vDI:vdi () in + print_endline (Printf.sprintf "Plugging in to host %s" name) ; + Client.Client.VBD.plug ~rpc ~session_id ~self:vbd ; + let@ () = Xapi_stdext_pervasives.Pervasiveext.finally do_test in + print_endline (Printf.sprintf "Unplugging from host %s" name) ; + Client.Client.VBD.unplug ~rpc ~session_id ~self:vbd ; + print_endline "Destroying VBD" ; + Client.Client.VBD.destroy ~rpc ~session_id ~self:vbd + in + test_snapshot_on localhost ; do_test () (** Make sure that VDI_CREATE; plug; VDI_DESTROY; VDI_CREATE; plug results in a device of the correct size in dom0. @@ -321,15 +309,12 @@ let vdi_create_destroy_plug_checksize rpc session_id sr_info () = Client.Client.PBD.plug ~rpc ~session_id ~self:pbd ; print_endline (Printf.sprintf "Creating VDI with requested size: %Ld" small_size) ; - Qt.VDI.with_new rpc session_id ~virtual_size:small_size sr (fun small_vdi -> - print_endline - (Printf.sprintf "Creating VDI with requested size: %Ld" large_size) ; - Qt.VDI.with_new rpc session_id ~virtual_size:large_size sr - (fun large_vdi -> - plug_in_check_size rpc session_id host small_vdi |> ignore ; - plug_in_check_size rpc session_id host large_vdi |> ignore - ) - ) + let@ small_vdi = Qt.VDI.with_new rpc session_id ~virtual_size:small_size sr in + print_endline + (Printf.sprintf "Creating VDI with requested size: %Ld" large_size) ; + let@ large_vdi = Qt.VDI.with_new rpc session_id ~virtual_size:large_size sr in + plug_in_check_size rpc session_id host small_vdi |> ignore ; + plug_in_check_size rpc session_id host large_vdi |> ignore (** Make a VDI, find a host to put it on, create a VBD to dom0 on that host, Attach, Unattach, destroy VBD, destroy VDI *) @@ -337,40 +322,37 @@ let vdi_general_test rpc session_id sr_info () = print_endline "VDI.create/copy/destroy test" ; let sr = sr_info.Qt.sr in let t = Unix.gettimeofday () in - Qt.VDI.with_new rpc session_id sr (fun newvdi -> - let createtime = Unix.gettimeofday () -. t in - print_endline (Printf.sprintf "Time to create: %f%!" createtime) ; - let pbd = List.hd (Client.Client.SR.get_PBDs ~rpc ~session_id ~self:sr) in - let host = Client.Client.PBD.get_host ~rpc ~session_id ~self:pbd in - let dom0 = Qt.VM.dom0_of_host rpc session_id host in - let device = - List.hd - (Client.Client.VM.get_allowed_VBD_devices ~rpc ~session_id ~vm:dom0) - in - print_endline - (Printf.sprintf "Creating a VBD connecting the VDI to localhost%!") ; - let vbd = - Client.Client.VBD.create ~rpc ~session_id ~vM:dom0 ~vDI:newvdi - ~userdevice:device ~bootable:false ~mode:`RW ~_type:`Disk - ~unpluggable:true ~empty:false ~other_config:[] ~qos_algorithm_type:"" - ~qos_algorithm_params:[] ~device:"" ~currently_attached:false + let@ newvdi = Qt.VDI.with_new rpc session_id sr in + let createtime = Unix.gettimeofday () -. t in + print_endline (Printf.sprintf "Time to create: %f%!" createtime) ; + let pbd = List.hd (Client.Client.SR.get_PBDs ~rpc ~session_id ~self:sr) in + let host = Client.Client.PBD.get_host ~rpc ~session_id ~self:pbd in + let dom0 = Qt.VM.dom0_of_host rpc session_id host in + let device = + List.hd (Client.Client.VM.get_allowed_VBD_devices ~rpc ~session_id ~vm:dom0) + in + print_endline + (Printf.sprintf "Creating a VBD connecting the VDI to localhost%!") ; + let vbd = + Client.Client.VBD.create ~rpc ~session_id ~vM:dom0 ~vDI:newvdi + ~userdevice:device ~bootable:false ~mode:`RW ~_type:`Disk + ~unpluggable:true ~empty:false ~other_config:[] ~qos_algorithm_type:"" + ~qos_algorithm_params:[] ~device:"" ~currently_attached:false + in + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> + let t = Unix.gettimeofday () in + print_endline (Printf.sprintf "Attempting to copy the VDI%!") ; + let newvdi2 = + Client.Client.VDI.copy ~rpc ~session_id ~vdi:newvdi ~sr + ~base_vdi:Ref.null ~into_vdi:Ref.null in - Xapi_stdext_pervasives.Pervasiveext.finally - (fun () -> - let t = Unix.gettimeofday () in - print_endline (Printf.sprintf "Attempting to copy the VDI%!") ; - let newvdi2 = - Client.Client.VDI.copy ~rpc ~session_id ~vdi:newvdi ~sr - ~base_vdi:Ref.null ~into_vdi:Ref.null - in - Qt.VDI.with_destroyed rpc session_id newvdi2 (fun () -> - let copytime = Unix.gettimeofday () -. t in - print_endline (Printf.sprintf "Time to copy: %f%!" copytime) ; - print_endline (Printf.sprintf "Destroying copied VDI%!") - ) - ) - (fun () -> Client.Client.VBD.destroy ~rpc ~session_id ~self:vbd) - ) + let@ () = Qt.VDI.with_destroyed rpc session_id newvdi2 in + let copytime = Unix.gettimeofday () -. t in + print_endline (Printf.sprintf "Time to copy: %f%!" copytime) ; + print_endline (Printf.sprintf "Destroying copied VDI%!") + ) + (fun () -> Client.Client.VBD.destroy ~rpc ~session_id ~self:vbd) let multiple_dom0_attach rpc session_id sr_info () = let rec loop vdi = function diff --git a/ocaml/quicktest/quicktest_vdi_ops_data_integrity.ml b/ocaml/quicktest/quicktest_vdi_ops_data_integrity.ml index 5b385d9b34..01d830b878 100644 --- a/ocaml/quicktest/quicktest_vdi_ops_data_integrity.ml +++ b/ocaml/quicktest/quicktest_vdi_ops_data_integrity.ml @@ -76,53 +76,107 @@ let check_vdi_unchanged rpc session_id ~vdi_size ~prepare_vdi ~vdi_op sr_info () ) ) +let check_vdi_delta rpc session_id ~vdi_size ~prepare_vdi ~prepare_vdi_base + ~vdi_op sr_info () = + let sR = sr_info.Qt.sr in + Qt.VDI.with_new ~virtual_size:vdi_size rpc session_id sR + @@ fun vdi_original -> + Qt.VDI.with_new ~virtual_size:vdi_size rpc session_id sR @@ fun base_vdi -> + prepare_vdi rpc session_id vdi_original ; + let checksum_original = checksum rpc session_id vdi_original in + prepare_vdi_base rpc session_id base_vdi ; + + vdi_op rpc session_id ~vdi:vdi_original ~base_vdi ; + let checksum_copy = checksum rpc session_id base_vdi in + if checksum_copy <> checksum_original then + failwith + (Printf.sprintf + "New VDI (checksum: %s) has different data than original (checksum: \ + %s)." + checksum_copy checksum_original + ) + let copy_vdi rpc session_id sr vdi = Client.Client.VDI.copy ~rpc ~session_id ~vdi ~base_vdi:API.Ref.null ~into_vdi:API.Ref.null ~sr -let export_import_vdi rpc session_id ~exportformat sR vdi = - let vdi_uuid = Client.Client.VDI.get_uuid ~rpc ~session_id ~self:vdi in +let export_vdi_to_file ~rpc ~session_id ~exportformat ?base_vdi ~vdi () = + let get_uuid vdi = Client.Client.VDI.get_uuid ~rpc ~session_id ~self:vdi in + let vdi_uuid = get_uuid vdi in + let base_vdi_uuid = Option.map get_uuid base_vdi in let file = "/tmp/quicktest_export_" ^ vdi_uuid in + Qt.cli_cmd + ([ + "vdi-export" + ; "uuid=" ^ vdi_uuid + ; "filename=" ^ file + ; "format=" ^ exportformat + ] + @ match base_vdi_uuid with None -> [] | Some x -> ["base=" ^ x] + ) + |> ignore ; + file + +let create_new_vdi ~rpc ~session_id ~sR ~vdi = + let virtual_size = + Client.Client.VDI.get_virtual_size ~rpc ~session_id ~self:vdi + in + let new_vdi = + Client.Client.VDI.create ~rpc ~session_id ~name_label:"" + ~name_description:"" ~sR ~virtual_size ~_type:`user ~sharable:false + ~read_only:false ~other_config:[] ~xenstore_data:[] ~sm_config:[] ~tags:[] + in + let new_vdi_uuid = + Client.Client.VDI.get_uuid ~rpc ~session_id ~self:new_vdi + in + (new_vdi_uuid, new_vdi) + +let import_file_into_vdi ~file ~vdi_uuid ~exportformat = Qt.cli_cmd [ - "vdi-export" + "vdi-import" ; "uuid=" ^ vdi_uuid ; "filename=" ^ file ; "format=" ^ exportformat ] - |> ignore ; + |> ignore + +let export_import_vdi rpc session_id ~exportformat sR vdi = + let file = export_vdi_to_file ~rpc ~session_id ~exportformat ~vdi () in Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> - let virtual_size = - Client.Client.VDI.get_virtual_size ~rpc ~session_id ~self:vdi - in - let new_vdi = - Client.Client.VDI.create ~rpc ~session_id ~name_label:"" - ~name_description:"" ~sR ~virtual_size ~_type:`user ~sharable:false - ~read_only:false ~other_config:[] ~xenstore_data:[] ~sm_config:[] - ~tags:[] - in - let new_vdi_uuid = - Client.Client.VDI.get_uuid ~rpc ~session_id ~self:new_vdi - in - Qt.cli_cmd - [ - "vdi-import" - ; "uuid=" ^ new_vdi_uuid - ; "filename=" ^ file - ; "format=" ^ exportformat - ] - |> ignore ; + let new_vdi_uuid, new_vdi = create_new_vdi ~rpc ~session_id ~sR ~vdi in + import_file_into_vdi ~file ~vdi_uuid:new_vdi_uuid ~exportformat ; new_vdi ) (fun () -> Sys.remove file) +let export_delta_import_vdi rpc session_id ~exportformat ~vdi ~base_vdi = + let file = + export_vdi_to_file ~rpc ~session_id ~exportformat ~vdi ~base_vdi () + in + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> + (* Import delta on top of base_vdi *) + let base_uuid = + Client.Client.VDI.get_uuid ~rpc ~session_id ~self:base_vdi + in + import_file_into_vdi ~file ~vdi_uuid:base_uuid ~exportformat + ) + (fun () -> Sys.remove file) + let export_import_raw = export_import_vdi ~exportformat:"raw" let export_import_vhd = export_import_vdi ~exportformat:"vhd" let export_import_tar = export_import_vdi ~exportformat:"tar" +let export_import_qcow = export_import_vdi ~exportformat:"qcow2" + +let delta_export_import_vhd = export_delta_import_vdi ~exportformat:"vhd" + +let delta_export_import_qcow = export_delta_import_vdi ~exportformat:"qcow2" + let data_integrity_tests vdi_op op_name = [ ( op_name ^ ": small empty VDI" @@ -141,6 +195,47 @@ let data_integrity_tests vdi_op op_name = ) ] +let delta_data_integrity_tests vdi_op op_name = + [ + ( op_name ^ ": delta between empty & empty VDI" + , `Slow + , check_vdi_delta + ~vdi_size:Sizes.(4L ** mib) + ~prepare_vdi:noop ~prepare_vdi_base:noop ~vdi_op + ) + ; ( op_name ^ ": delta between random & empty VDI" + , `Slow + , check_vdi_delta + ~vdi_size:Sizes.(4L ** mib) + ~prepare_vdi:write_random_data ~prepare_vdi_base:noop ~vdi_op + ) + ; ( op_name ^ ": delta between random & random VDI" + , `Slow + , check_vdi_delta + ~vdi_size:Sizes.(4L ** mib) + ~prepare_vdi:write_random_data ~prepare_vdi_base:write_random_data + ~vdi_op + ) + ; ( op_name ^ ": delta between full and empty VDI" + , `Slow + , check_vdi_delta + ~vdi_size:Sizes.(4L ** mib) + ~prepare_vdi:fill ~prepare_vdi_base:noop ~vdi_op + ) + ; ( op_name ^ ": delta between full and random VDI" + , `Slow + , check_vdi_delta + ~vdi_size:Sizes.(4L ** mib) + ~prepare_vdi:fill ~prepare_vdi_base:write_random_data ~vdi_op + ) + ; ( op_name ^ ": delta between full and full VDI" + , `Slow + , check_vdi_delta + ~vdi_size:Sizes.(4L ** mib) + ~prepare_vdi:fill ~prepare_vdi_base:fill ~vdi_op + ) + ] + let large_data_integrity_tests vdi_op op_name = let b = Random.int64 16L in [ @@ -179,9 +274,21 @@ let tests () = @ (data_integrity_tests export_import_vhd "VDI export/import to/from VHD file" |> supported_srs ) + @ (delta_data_integrity_tests delta_export_import_vhd + "VDI delta export/import to/from VHD file" + |> supported_srs + ) @ (data_integrity_tests export_import_tar "VDI export/import to/from TAR file" |> supported_srs ) + @ (data_integrity_tests export_import_qcow + "VDI export/import to/from QCOW file" + |> supported_srs + ) + @ (delta_data_integrity_tests delta_export_import_qcow + "VDI delta export/import to/from QCOW file" + |> supported_srs + ) @ (large_data_integrity_tests export_import_tar "VDI export/import to/from TAR file" |> supported_gfs2_srs diff --git a/ocaml/rrd2csv/src/dune b/ocaml/rrd2csv/src/dune index 28f26f831c..a04e8dc33c 100644 --- a/ocaml/rrd2csv/src/dune +++ b/ocaml/rrd2csv/src/dune @@ -7,6 +7,7 @@ http_lib threads.posix + unix xapi-idl.rrd xapi-client xapi-rrd diff --git a/ocaml/rrd2csv/src/rrd2csv.ml b/ocaml/rrd2csv/src/rrd2csv.ml index a6866874ee..37e00f8148 100644 --- a/ocaml/rrd2csv/src/rrd2csv.ml +++ b/ocaml/rrd2csv/src/rrd2csv.ml @@ -304,7 +304,7 @@ module Ds_selector = struct if fs = [] then true else - List.fold_left (fun acc f -> acc || filter11 f d) false fs + List.exists (fun f -> filter11 f d) fs (* Returns the d \in ds that passes at least one of the filters fs *) diff --git a/ocaml/sdk-gen/c/gen_c_binding.ml b/ocaml/sdk-gen/c/gen_c_binding.ml index ebf5acae15..7f27cff338 100644 --- a/ocaml/sdk-gen/c/gen_c_binding.ml +++ b/ocaml/sdk-gen/c/gen_c_binding.ml @@ -346,7 +346,7 @@ and gen_impl cls = ; ("async_params", `A (List.map paramJson (asyncParams msg))) ; ("msg_params", `A (List.map paramJson msg.msg_params)) ; ("abstract_result_type", `String (result_type msg)) - ; ("has_params", `Bool (List.length msg.msg_params <> 0)) + ; ("has_params", `Bool (msg.msg_params <> [])) ; ("param_count", `String (string_of_int (List.length msg.msg_params))) ; ("has_result", `Bool (String.compare (result_type msg) "" <> 0)) ; ("init_result", `Bool (init_result msg)) diff --git a/ocaml/sdk-gen/common/dune b/ocaml/sdk-gen/common/dune index 1475ba4da8..1b4bd0bc64 100644 --- a/ocaml/sdk-gen/common/dune +++ b/ocaml/sdk-gen/common/dune @@ -2,5 +2,5 @@ (name CommonFunctions) (modes best) (wrapped false) - (libraries astring xapi-datamodel mustache xapi-stdext-std xapi-stdext-unix) + (libraries astring xapi-datamodel mustache unix xapi-stdext-std xapi-stdext-unix) (modules_without_implementation license)) diff --git a/ocaml/sdk-gen/csharp/XE_SR_ERRORCODES.xml b/ocaml/sdk-gen/csharp/XE_SR_ERRORCODES.xml index 47fefd8308..792fe17fcd 100644 --- a/ocaml/sdk-gen/csharp/XE_SR_ERRORCODES.xml +++ b/ocaml/sdk-gen/csharp/XE_SR_ERRORCODES.xml @@ -513,6 +513,12 @@ 117 + + PVMultiIDs + PVs found with multiple SCSI IDs + 119 + + APISession diff --git a/ocaml/sdk-gen/csharp/autogen/src/Event.cs b/ocaml/sdk-gen/csharp/autogen/src/Event.cs index 62bb7d16ae..1eed4e3ef1 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/Event.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/Event.cs @@ -45,6 +45,7 @@ public override void UpdateFrom(Event update) id = update.id; } + [Obsolete("Use the calls setting individual fields of the API object instead.")] public override string SaveChanges(Session session, string opaqueRef, Event serverObject) { if (opaqueRef == null) diff --git a/ocaml/sdk-gen/csharp/autogen/src/Failure.cs b/ocaml/sdk-gen/csharp/autogen/src/Failure.cs index 62cd536afd..e8b514f20e 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/Failure.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/Failure.cs @@ -31,9 +31,11 @@ using System.Collections.Generic; using System.Linq; using System.Resources; +#if !(NET8_0_OR_GREATER) using System.Runtime.Serialization; using System.Text.RegularExpressions; using System.Xml; +#endif using Newtonsoft.Json.Linq; @@ -88,12 +90,14 @@ public Failure(string message, Exception exception) ParseExceptionMessage(); } +#if !(NET8_0_OR_GREATER) protected Failure(SerializationInfo info, StreamingContext context) : base(info, context) { errorDescription = (List)info.GetValue("errorDescription", typeof(List)); errorText = info.GetString("errorText"); } +#endif #endregion @@ -174,7 +178,7 @@ public override string ToString() { return Message; } - +#if !(NET8_0_OR_GREATER) public override void GetObjectData(SerializationInfo info, StreamingContext context) { if (info == null) @@ -185,5 +189,6 @@ public override void GetObjectData(SerializationInfo info, StreamingContext cont base.GetObjectData(info, context); } +#endif } } diff --git a/ocaml/sdk-gen/csharp/autogen/src/HTTP.cs b/ocaml/sdk-gen/csharp/autogen/src/HTTP.cs index 60fe64f4de..732478828f 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/HTTP.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/HTTP.cs @@ -38,7 +38,9 @@ using System.Security.Authentication; using System.Security.Cryptography; using System.Security.Cryptography.X509Certificates; +#if !(NET8_0_OR_GREATER) using System.Runtime.Serialization; +#endif namespace XenAPI { @@ -58,12 +60,13 @@ public TooManyRedirectsException(int redirect, Uri uri) this.uri = uri; } - public TooManyRedirectsException() : base() { } + public TooManyRedirectsException() { } public TooManyRedirectsException(string message) : base(message) { } public TooManyRedirectsException(string message, Exception exception) : base(message, exception) { } +#if !(NET8_0_OR_GREATER) protected TooManyRedirectsException(SerializationInfo info, StreamingContext context) : base(info, context) { @@ -81,42 +84,47 @@ public override void GetObjectData(SerializationInfo info, StreamingContext cont base.GetObjectData(info, context); } +#endif } [Serializable] public class BadServerResponseException : Exception { - public BadServerResponseException() : base() { } + public BadServerResponseException() { } public BadServerResponseException(string message) : base(message) { } public BadServerResponseException(string message, Exception exception) : base(message, exception) { } +#if !(NET8_0_OR_GREATER) protected BadServerResponseException(SerializationInfo info, StreamingContext context) : base(info, context) { } +#endif } [Serializable] public class CancelledException : Exception { - public CancelledException() : base() { } + public CancelledException() { } public CancelledException(string message) : base(message) { } public CancelledException(string message, Exception exception) : base(message, exception) { } - +#if !(NET8_0_OR_GREATER) protected CancelledException(SerializationInfo info, StreamingContext context) : base(info, context) { } +#endif } [Serializable] public class ProxyServerAuthenticationException : Exception { - public ProxyServerAuthenticationException() : base() { } + public ProxyServerAuthenticationException() { } public ProxyServerAuthenticationException(string message) : base(message) { } public ProxyServerAuthenticationException(string message, Exception exception) : base(message, exception) { } - +#if !(NET8_0_OR_GREATER) protected ProxyServerAuthenticationException(SerializationInfo info, StreamingContext context) : base(info, context) { } +#endif } #endregion @@ -133,6 +141,9 @@ protected ProxyServerAuthenticationException(SerializationInfo info, StreamingCo public const int DEFAULT_HTTPS_PORT = 443; private const int NONCE_LENGTH = 16; + private const int FILE_MOVE_MAX_RETRIES = 5; + private const int FILE_MOVE_SLEEP_BETWEEN_RETRIES = 100; + public enum ProxyAuthenticationMethod { Basic = 0, @@ -149,7 +160,7 @@ public enum ProxyAuthenticationMethod private static void WriteLine(String txt, Stream stream) { - byte[] bytes = System.Text.Encoding.ASCII.GetBytes(String.Format("{0}\r\n", txt)); + byte[] bytes = Encoding.ASCII.GetBytes($"{txt}\r\n"); stream.Write(bytes, 0, bytes.Length); } @@ -164,7 +175,7 @@ private static void WriteLine(Stream stream) // done here. private static string ReadLine(Stream stream) { - System.Text.StringBuilder result = new StringBuilder(); + StringBuilder result = new StringBuilder(); while (true) { int b = stream.ReadByte(); @@ -208,9 +219,8 @@ private static bool ReadHttpHeaders(ref Stream stream, IWebProxy proxy, bool nod // read chunk size string chunkSizeStr = ReadLine(stream); chunkSizeStr = chunkSizeStr.TrimEnd('\r', '\n'); - int chunkSize = 0; int.TryParse(chunkSizeStr, System.Globalization.NumberStyles.HexNumber, - System.Globalization.CultureInfo.InvariantCulture, out chunkSize); + System.Globalization.CultureInfo.InvariantCulture, out var chunkSize); // read number of bytes from the stream int totalNumberOfBytesRead = 0; @@ -222,8 +232,8 @@ private static bool ReadHttpHeaders(ref Stream stream, IWebProxy proxy, bool nod totalNumberOfBytesRead += numberOfBytesRead; } while (numberOfBytesRead > 0 && totalNumberOfBytesRead < chunkSize); - string str = System.Text.Encoding.ASCII.GetString(bytes); - string[] split = str.Split(new string[] {"\r\n"}, StringSplitOptions.RemoveEmptyEntries); + string str = Encoding.ASCII.GetString(bytes); + string[] split = str.Split(new [] {"\r\n"}, StringSplitOptions.RemoveEmptyEntries); headers.AddRange(split); entityBody += str; @@ -267,7 +277,7 @@ private static bool ReadHttpHeaders(ref Stream stream, IWebProxy proxy, bool nod private static int getResultCode(string line) { - string[] bits = line.Split(new char[] { ' ' }); + string[] bits = line.Split(' '); return (bits.Length < 2 ? 0 : Int32.Parse(bits[1])); } @@ -292,7 +302,8 @@ private static bool ValidateServerCertificate( /// The secure hash as a hex string. private static string _MD5Hash(string str) { - return ComputeHash(str, "MD5"); + using (var hasher = MD5.Create()) + return ComputeHash(hasher, str); } /// @@ -302,32 +313,24 @@ private static string _MD5Hash(string str) /// The secure hash as a hex string. private static string Sha256Hash(string str) { - return ComputeHash(str, "SHA256"); + using (var hasher = SHA256.Create()) + return ComputeHash(hasher, str); } - private static string ComputeHash(string input, string method) + private static string ComputeHash(HashAlgorithm hasher, string input) { - if (input == null) + if (hasher == null || input == null) return null; var enc = new UTF8Encoding(); byte[] bytes = enc.GetBytes(input); - - using (var hasher = HashAlgorithm.Create(method)) - { - if (hasher != null) - { - byte[] hash = hasher.ComputeHash(bytes); - return BitConverter.ToString(hash).Replace("-", "").ToLowerInvariant(); - } - } - - return null; + byte[] hash = hasher.ComputeHash(bytes); + return BitConverter.ToString(hash).Replace("-", "").ToLowerInvariant(); } private static string GenerateNonce() { - using (var rngCsProvider = new RNGCryptoServiceProvider()) + using (var rngCsProvider = RandomNumberGenerator.Create()) { var nonceBytes = new byte[NONCE_LENGTH]; rngCsProvider.GetBytes(nonceBytes); @@ -417,7 +420,7 @@ public static Uri BuildUri(string hostname, string path, params object[] args) private static string GetPartOrNull(string str, int partIndex) { - string[] parts = str.Split(new char[] { ' ' }, partIndex + 2, StringSplitOptions.RemoveEmptyEntries); + string[] parts = str.Split(new [] { ' ' }, partIndex + 2, StringSplitOptions.RemoveEmptyEntries); return partIndex < parts.Length - 1 ? parts[partIndex] : null; } @@ -448,8 +451,7 @@ 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) { - IMockWebProxy mockProxy = proxy as IMockWebProxy; - if (mockProxy != null) + if (proxy is IMockWebProxy mockProxy) return mockProxy.GetStream(uri); Stream stream; @@ -469,7 +471,7 @@ public static Stream ConnectStream(Uri uri, IWebProxy proxy, bool nodelay, int t { if (useProxy) { - string line = string.Format("CONNECT {0}:{1} HTTP/1.0", uri.Host, uri.Port); + string line = $"CONNECT {uri.Host}:{uri.Port} HTTP/1.0"; WriteLine(line, stream); WriteLine(stream); @@ -481,9 +483,8 @@ public static Stream ConnectStream(Uri uri, IWebProxy proxy, bool nodelay, int t if (UseSSL(uri)) { - SslStream sslStream = new SslStream(stream, false, - new RemoteCertificateValidationCallback(ValidateServerCertificate), null); - sslStream.AuthenticateAsClient("", null, SslProtocols.Tls | SslProtocols.Tls11 | SslProtocols.Tls12, true); + SslStream sslStream = new SslStream(stream, false, ValidateServerCertificate, null); + sslStream.AuthenticateAsClient("", null, SslProtocols.Tls12, true); stream = sslStream; } @@ -514,7 +515,7 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox } if (proxy.Credentials == null) - throw new BadServerResponseException(string.Format("Received error code {0} from the server", initialResponse[0])); + throw new BadServerResponseException($"Received error code {initialResponse[0]} from the server"); NetworkCredential credentials = proxy.Credentials.GetCredential(uri, null); @@ -526,10 +527,9 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox if (string.IsNullOrEmpty(basicField)) throw new ProxyServerAuthenticationException("Basic authentication scheme is not supported/enabled by the proxy server."); - string authenticationFieldReply = string.Format("Proxy-Authorization: Basic {0}", - Convert.ToBase64String(Encoding.UTF8.GetBytes(credentials.UserName + ":" + credentials.Password))); + var creds = Convert.ToBase64String(Encoding.UTF8.GetBytes(credentials.UserName + ":" + credentials.Password)); WriteLine(header, stream); - WriteLine(authenticationFieldReply, stream); + WriteLine($"Proxy-Authorization: Basic {creds}", stream); WriteLine(stream); } else if (CurrentProxyAuthenticationMethod == ProxyAuthenticationMethod.Digest) @@ -539,9 +539,7 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox if (string.IsNullOrEmpty(digestField)) throw new ProxyServerAuthenticationException("Digest authentication scheme is not supported/enabled by the proxy server."); - string authenticationFieldReply = string.Format( - "Proxy-Authorization: Digest username=\"{0}\", uri=\"{1}:{2}\"", - credentials.UserName, uri.Host, uri.Port); + string authenticationFieldReply = $"Proxy-Authorization: Digest username=\"{credentials.UserName}\", uri=\"{uri.Host}:{uri.Port}\""; int len = "Proxy-Authorization: Digest".Length; string directiveString = digestField.Substring(len, digestField.Length - len); @@ -562,19 +560,19 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox throw new ProxyServerAuthenticationException("Stale nonce in Digest authentication attempt."); break; case "realm=": - authenticationFieldReply += string.Format(", realm=\"{0}\"", directives[++i]); + authenticationFieldReply += $", realm=\"{directives[++i]}\""; realm = directives[i]; break; case "nonce=": - authenticationFieldReply += string.Format(", nonce=\"{0}\"", directives[++i]); + authenticationFieldReply += $", nonce=\"{directives[++i]}\""; nonce = directives[i]; break; case "opaque=": - authenticationFieldReply += string.Format(", opaque=\"{0}\"", directives[++i]); + authenticationFieldReply += $", opaque=\"{directives[++i]}\""; opaque = directives[i]; break; case "algorithm=": - authenticationFieldReply += string.Format(", algorithm={0}", directives[++i]); //unquoted; see RFC7616-3.4 + authenticationFieldReply += $", algorithm={directives[++i]}"; //unquoted; see RFC7616-3.4 algorithm = directives[i]; break; case "qop=": @@ -584,9 +582,8 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox qop = qops.FirstOrDefault(q => q.ToLowerInvariant() == "auth") ?? qops.FirstOrDefault(q => q.ToLowerInvariant() == "auth-int"); if (qop == null) - throw new ProxyServerAuthenticationException( - "Digest authentication's quality-of-protection directive is not supported."); - authenticationFieldReply += string.Format(", qop={0}", qop); //unquoted; see RFC7616-3.4 + throw new ProxyServerAuthenticationException("Digest authentication's quality-of-protection directive is not supported."); + authenticationFieldReply += $", qop={qop}"; //unquoted; see RFC7616-3.4 } break; } @@ -594,11 +591,11 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox string clientNonce = GenerateNonce(); if (qop != null) - authenticationFieldReply += string.Format(", cnonce=\"{0}\"", clientNonce); + authenticationFieldReply += $", cnonce=\"{clientNonce}\""; string nonceCount = "00000001"; // todo: track nonces and their corresponding nonce counts if (qop != null) - authenticationFieldReply += string.Format(", nc={0}", nonceCount); //unquoted; see RFC7616-3.4 + authenticationFieldReply += $", nc={nonceCount}"; //unquoted; see RFC7616-3.4 Func algFunc; var scratch1 = string.Join(":", credentials.UserName, realm, credentials.Password); @@ -636,7 +633,7 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox : new[] {HA1, nonce, nonceCount, clientNonce, qop, HA2}; var response = algFunc(string.Join(":", array3)); - authenticationFieldReply += string.Format(", response=\"{0}\"", response); + authenticationFieldReply += $", response=\"{response}\""; WriteLine(header, stream); WriteLine(authenticationFieldReply, stream); @@ -645,8 +642,7 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox else { string authType = GetPartOrNull(fields[0], 1); - throw new ProxyServerAuthenticationException( - string.Format("Proxy server's {0} authentication method is not supported.", authType ?? "chosen")); + throw new ProxyServerAuthenticationException($"Proxy server's {authType ?? "chosen"} authentication method is not supported."); } // handle authentication attempt response @@ -662,12 +658,10 @@ private static void AuthenticateProxy(ref Stream stream, Uri uri, IWebProxy prox case 407: throw new ProxyServerAuthenticationException("Proxy server denied access due to wrong credentials."); default: - throw new BadServerResponseException(string.Format( - "Received error code {0} from the server", authenticatedResponse[0])); + throw new BadServerResponseException($"Received error code {authenticatedResponse[0]} from the server"); } } - private static Stream DoHttp(Uri uri, IWebProxy proxy, bool noDelay, int timeoutMs, params string[] headers) { Stream stream = ConnectStream(uri, proxy, noDelay, timeoutMs); @@ -829,9 +823,6 @@ public static void Get(DataCopiedDelegate dataCopiedDelegate, FuncBool cancellin } } - private const int FILE_MOVE_MAX_RETRIES = 5; - private const int FILE_MOVE_SLEEP_BETWEEN_RETRIES = 100; - /// /// Move a file, retrying a few times with a short sleep between retries. /// If it still fails after these retries, then throw the error. diff --git a/ocaml/sdk-gen/csharp/autogen/src/JsonRpc.cs b/ocaml/sdk-gen/csharp/autogen/src/JsonRpc.cs index 519cc430d4..a790f39732 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/JsonRpc.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/JsonRpc.cs @@ -31,6 +31,13 @@ using System.Collections.Generic; using System.IO; using System.Net; +#if (NET8_0_OR_GREATER) +using System.Diagnostics; +using System.Linq; +using System.Net.Http; +using System.Net.Http.Headers; +using System.Security.Cryptography.X509Certificates; +#endif using System.Net.Security; using System.Threading; using Newtonsoft.Json; @@ -49,9 +56,9 @@ internal abstract class JsonRequest { protected JsonRequest(int id, string method, JToken parameters) { - this.Id = id; - this.Method = method; - this.Parameters = parameters; + Id = id; + Method = method; + Parameters = parameters; } public static JsonRequest Create(JsonRpcVersion jsonRpcVersion, int id, string method, JToken parameters) @@ -65,6 +72,8 @@ public static JsonRequest Create(JsonRpcVersion jsonRpcVersion, int id, string m } } + public abstract string JsonRPC { get;} + /// /// Unique call id. Can be null in JSON_RPC v2.0, but xapi disallows it. /// @@ -95,6 +104,9 @@ public JsonRequestV1(int id, string method, JToken parameters) : base(id, method, parameters) { } + + [JsonIgnore] + public override string JsonRPC => "1.0"; } internal class JsonRequestV2 : JsonRequest @@ -105,18 +117,15 @@ public JsonRequestV2(int id, string method, JToken parameters) } [JsonProperty("jsonrpc", Required = Required.Always)] - public string JsonRPC - { - get { return "2.0"; } - } + public override string JsonRPC => "2.0"; } internal abstract class JsonResponse { - [JsonProperty("id", Required = Required.AllowNull)] public int Id = 0; + [JsonProperty("id", Required = Required.AllowNull)] public int Id { get; set; } - [JsonProperty("result", Required = Required.Default)] public T Result = default(T); + [JsonProperty("result", Required = Required.Default)] public T Result { get; set; } public override string ToString() { @@ -126,23 +135,23 @@ public override string ToString() internal class JsonResponseV1 : JsonResponse { - [JsonProperty("error", Required = Required.AllowNull)] public JToken Error = null; + [JsonProperty("error", Required = Required.AllowNull)] public JToken Error { get; set; } } internal class JsonResponseV2 : JsonResponse { - [JsonProperty("error", Required = Required.DisallowNull)] public JsonResponseV2Error Error = null; + [JsonProperty("error", Required = Required.DisallowNull)] public JsonResponseV2Error Error { get; set; } - [JsonProperty("jsonrpc", Required = Required.Always)] public string JsonRpc = null; + [JsonProperty("jsonrpc", Required = Required.Always)] public string JsonRpc { get; set; } } internal class JsonResponseV2Error { - [JsonProperty("code", Required = Required.Always)] public int Code = 0; + [JsonProperty("code", Required = Required.Always)] public int Code { get; set; } - [JsonProperty("message", Required = Required.Always)] public string Message = null; + [JsonProperty("message", Required = Required.Always)] public string Message { get; set; } - [JsonProperty("data", Required = Required.Default)] public JToken Data = null; + [JsonProperty("data", Required = Required.Default)] public JToken Data { get; set; } public override string ToString() { @@ -155,6 +164,42 @@ public partial class JsonRpcClient { private int _globalId; +#if (NET8_0_OR_GREATER) + private static readonly Type ClassType = typeof(JsonRpcClient); + private static readonly System.Reflection.AssemblyName ClassAssemblyName = ClassType?.Assembly?.GetName(); + private static readonly ActivitySource source = new ActivitySource(ClassAssemblyName.Name + "." + ClassType?.FullName, ClassAssemblyName.Version?.ToString()); + + // Follow naming conventions from OpenTelemetry.SemanticConventions + // Not yet on NuGet though: + // dotnet add package OpenTelemetry.SemanticConventions + private static class RpcAttributes + { + public const string AttributeRpcMethod = "rpc.method"; + public const string AttributeRpcSystem = "rpc.system"; + public const string AttributeRpcService = "rpc.service"; + public const string AttributeRpcJsonrpcErrorCode = "rpc.jsonrpc.error_code"; + public const string AttributeRpcJsonrpcErrorMessage = "rpc.jsonrpc.error_message"; + public const string AttributeRpcJsonrpcRequestId = "rpc.jsonrpc.request_id"; + public const string AttributeRpcJsonrpcVersion = "rpc.jsonrpc.version"; + public const string AttributeRpcMessageType = "rpc.message.type"; + + public static class RpcMessageTypeValues + { + public const string Sent = "SENT"; + public const string Received = "RECEIVED"; + } + } + + private static class ServerAttributes + { + public const string AttributeServerAddress = "server.address"; + } + + // not part of the SemanticConventions package + private const string ValueJsonRpc = "jsonrpc"; + private const string EventRpcMessage = "rpc.message"; +#endif + public JsonRpcClient(string baseUrl) { Url = baseUrl; @@ -180,7 +225,13 @@ public JsonRpcClient(string baseUrl) public bool AllowAutoRedirect { get; set; } public bool PreAuthenticate { get; set; } public CookieContainer Cookies { get; set; } + +#if (NET8_0_OR_GREATER) + public Func ServerCertificateValidationCallback { get; set; } +#else public RemoteCertificateValidationCallback ServerCertificateValidationCallback { get; set; } +#endif + public Dictionary RequestHeaders { get; set; } public Dictionary ResponseHeaders { get; set; } @@ -207,69 +258,186 @@ protected virtual T Rpc(string callName, JToken parameters, JsonSerializer se // therefore the latter will be done only in DEBUG mode using (var postStream = new MemoryStream()) { - using (var sw = new StreamWriter(postStream)) +#if (NET8_0_OR_GREATER) + // the semantic convention is $package.$service/$method + using (Activity activity = source.CreateActivity("XenAPI/" + callName, ActivityKind.Client)) { + activity?.Start(); + // Set the fields described in the OpenTelemetry Semantic Conventions: + // https://opentelemetry.io/docs/specs/semconv/rpc/json-rpc/ + // https://opentelemetry.io/docs/specs/semconv/rpc/rpc-spans/ + activity?.SetTag(RpcAttributes.AttributeRpcSystem, ValueJsonRpc); + activity?.SetTag(ServerAttributes.AttributeServerAddress, new Uri(Url).Host); + activity?.SetTag(RpcAttributes.AttributeRpcMethod, callName); + activity?.SetTag(RpcAttributes.AttributeRpcJsonrpcRequestId, id.ToString()); +#endif + using (var sw = new StreamWriter(postStream)) + { #if DEBUG - var settings = CreateSettings(serializer.Converters); - string jsonReq = JsonConvert.SerializeObject(request, settings); - if (RequestEvent != null) - RequestEvent(jsonReq); - sw.Write(jsonReq); + var settings = CreateSettings(serializer.Converters); + string jsonReq = JsonConvert.SerializeObject(request, settings); + if (RequestEvent != null) + RequestEvent(jsonReq); + sw.Write(jsonReq); #else - if (RequestEvent != null) - RequestEvent(callName); - serializer.Serialize(sw, request); + if (RequestEvent != null) + RequestEvent(callName); + serializer.Serialize(sw, request); #endif - sw.Flush(); - postStream.Seek(0, SeekOrigin.Begin); + sw.Flush(); + postStream.Seek(0, SeekOrigin.Begin); - using (var responseStream = new MemoryStream()) - { - PerformPostRequest(postStream, responseStream); - responseStream.Position = 0; - - using (var responseReader = new StreamReader(responseStream)) + using (var responseStream = new MemoryStream()) { - switch (JsonRpcVersion) + PerformPostRequest(postStream, responseStream); + responseStream.Position = 0; + + using (var responseReader = new StreamReader(responseStream)) { - case JsonRpcVersion.v2: +#if (NET8_0_OR_GREATER) + activity?.SetTag(RpcAttributes.AttributeRpcJsonrpcVersion, request.JsonRPC); +#endif + switch (JsonRpcVersion) + { + case JsonRpcVersion.v2: #if DEBUG - string json2 = responseReader.ReadToEnd(); - var res2 = JsonConvert.DeserializeObject>(json2, settings); + string json2 = responseReader.ReadToEnd(); + var res2 = JsonConvert.DeserializeObject>(json2, settings); #else - var res2 = (JsonResponseV2)serializer.Deserialize(responseReader, typeof(JsonResponseV2)); + var res2 = (JsonResponseV2)serializer.Deserialize(responseReader, typeof(JsonResponseV2)); #endif - if (res2.Error != null) - { - var descr = new List { res2.Error.Message }; - descr.AddRange(res2.Error.Data.ToObject()); - throw new Failure(descr); - } - return res2.Result; - default: + if (res2.Error != null) + { + var descr = new List { res2.Error.Message }; + descr.AddRange(res2.Error.Data.ToObject()); +#if (NET8_0_OR_GREATER) + activity?.SetTag(RpcAttributes.AttributeRpcJsonrpcErrorCode, res2.Error.Code); + activity?.SetTag(RpcAttributes.AttributeRpcJsonrpcErrorMessage, descr); + activity?.SetStatus(ActivityStatusCode.Error); +#endif + throw new Failure(descr); + } +#if (NET8_0_OR_GREATER) + activity?.SetStatus(ActivityStatusCode.Ok); +#endif + return res2.Result; + default: #if DEBUG - string json1 = responseReader.ReadToEnd(); - var res1 = JsonConvert.DeserializeObject>(json1, settings); + string json1 = responseReader.ReadToEnd(); + var res1 = JsonConvert.DeserializeObject>(json1, settings); #else - var res1 = (JsonResponseV1)serializer.Deserialize(responseReader, typeof(JsonResponseV1)); + var res1 = (JsonResponseV1)serializer.Deserialize(responseReader, typeof(JsonResponseV1)); #endif - if (res1.Error != null) - { - var errorArray = res1.Error.ToObject(); + var errorArray = res1.Error?.ToObject(); if (errorArray != null) + { +#if (NET8_0_OR_GREATER) + activity?.SetStatus(ActivityStatusCode.Error); + // we can't be sure whether we'll have a Code here + // the exact format of an error object is not specified in JSONRPC v1 + activity?.SetTag(RpcAttributes.AttributeRpcJsonrpcErrorMessage, errorArray.ToString()); +#endif throw new Failure(errorArray); - } - return res1.Result; + } +#if (NET8_0_OR_GREATER) + activity?.SetStatus(ActivityStatusCode.Ok); +#endif + return res1.Result; + } } } } +#if (NET8_0_OR_GREATER) } +#endif } } - protected virtual void PerformPostRequest(Stream postStream, Stream responseStream) { +#if (NET8_0_OR_GREATER) + HttpClient httpClient = null; + HttpClientHandler httpHandler = null; + HttpRequestMessage requestMessage = null; + HttpResponseMessage responseMessage = null; + + try + { + httpHandler = new HttpClientHandler + { + AllowAutoRedirect = AllowAutoRedirect, + PreAuthenticate = PreAuthenticate, + CookieContainer = Cookies ?? new CookieContainer(), + Proxy = WebProxy + }; + + Func callBack = null; + if (ServicePointManager.ServerCertificateValidationCallback != null) + callBack = ServicePointManager.ServerCertificateValidationCallback.Invoke; + + httpHandler.ServerCertificateCustomValidationCallback = ServerCertificateValidationCallback ?? callBack; + + httpClient = new HttpClient(httpHandler) { Timeout = TimeSpan.FromMilliseconds(Timeout) }; + + requestMessage = new HttpRequestMessage(HttpMethod.Post, new Uri(JsonRpcUrl)); + if (ProtocolVersion != null) + requestMessage.Version = ProtocolVersion; + requestMessage.Headers.Accept.Add(new MediaTypeWithQualityHeaderValue("application/json")); + requestMessage.Headers.UserAgent.ParseAdd(UserAgent); + requestMessage.Headers.ConnectionClose = !KeepAlive; + requestMessage.Headers.ExpectContinue = Expect100Continue; + requestMessage.Content = new StreamContent(postStream); + + if (RequestHeaders != null) + { + foreach (var header in RequestHeaders) + requestMessage.Headers.Add(header.Key, header.Value); + } + + // propagate W3C traceparent and tracestate + // HttpClient would do this automatically on .NET 5, + // and .NET 6 would provide even more control over this: https://blog.ladeak.net/posts/opentelemetry-net6-httpclient + // the caller must ensure that the activity is in W3C format (by inheritance or direct setting) + var activity = Activity.Current; + if (activity != null) + { + if (activity.IdFormat == ActivityIdFormat.W3C) + { + requestMessage.Headers.Add("traceparent", activity.Id); + var state = activity.TraceStateString; + + if (state?.Length > 0) + requestMessage.Headers.Add("tracestate", state); + } + + var tags = new ActivityTagsCollection { { RpcAttributes.AttributeRpcMessageType, RpcAttributes.RpcMessageTypeValues.Sent } }; + activity.AddEvent(new ActivityEvent(EventRpcMessage, DateTimeOffset.Now, tags)); + } + + responseMessage = httpClient.SendAsync(requestMessage).Result; + responseMessage.EnsureSuccessStatusCode(); + + var str = responseMessage.Content.ReadAsStream(); + str.CopyTo(responseStream); + responseStream.Flush(); + + ResponseHeaders = responseMessage.Headers.ToDictionary(header => header.Key, header => string.Join(",", header.Value)); + + if (activity != null) + { + var tags = new ActivityTagsCollection { { RpcAttributes.AttributeRpcMessageType, RpcAttributes.RpcMessageTypeValues.Received } }; + activity.AddEvent(new ActivityEvent(EventRpcMessage, DateTimeOffset.Now, tags)); + } + } + finally + { + RequestHeaders = null; + responseMessage?.Dispose(); + requestMessage?.Dispose(); + httpClient?.Dispose(); + httpHandler?.Dispose(); + } +#else var webRequest = (HttpWebRequest)WebRequest.Create(JsonRpcUrl); webRequest.Method = "POST"; webRequest.ContentType = "application/json"; @@ -332,6 +500,7 @@ protected virtual void PerformPostRequest(Stream postStream, Stream responseStre RequestHeaders = null; webResponse?.Dispose(); } +#endif } private JsonSerializerSettings CreateSettings(IList converters) diff --git a/ocaml/sdk-gen/csharp/autogen/src/Session.cs b/ocaml/sdk-gen/csharp/autogen/src/Session.cs index 82db84a821..5d99913683 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/Session.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/Session.cs @@ -31,6 +31,10 @@ using System.Collections.Generic; using System.Linq; using System.Net; +#if (NET8_0_OR_GREATER) +using System.Net.Http; +using System.Security.Cryptography.X509Certificates; +#endif using System.Net.Security; using Newtonsoft.Json; @@ -44,7 +48,7 @@ public partial class Session : XenObject /// /// This string is used as the HTTP UserAgent for each request. /// - public static string UserAgent = string.Format("XenAPI/{0}", Helper.APIVersionString(API_Version.LATEST)); + public static string UserAgent = $"XenAPI/{Helper.APIVersionString(API_Version.LATEST)}"; /// /// If null, no proxy is used, otherwise this proxy is used for each request. @@ -55,8 +59,6 @@ public partial class Session : XenObject public object Tag; - private List roles = new List(); - #region Constructors public Session(JsonRpcClient client) @@ -124,7 +126,7 @@ public Session(Session session) private static string GetUrl(string hostname, int port) { - return string.Format("{0}://{1}:{2}", port == 8080 || port == 80 ? "http" : "https", hostname, port); + return $"{(port == 8080 || port == 80 ? "http" : "https")}://{hostname}:{port}"; } private void SetupSessionDetails() @@ -159,7 +161,7 @@ private void CopyADFromSession(Session session) IsLocalSuperuser = session.IsLocalSuperuser; SessionSubject = session.SessionSubject; UserSid = session.UserSid; - roles = session.Roles; + Roles = session.Roles; Permissions = session.Permissions; } @@ -208,7 +210,7 @@ private void SetRbacPermissions() if (r.subroles.Count > 0 && r.name_label == s) { r.opaque_ref = xr.opaque_ref; - roles.Add(r); + Roles.Add(r); break; } } @@ -220,7 +222,8 @@ public override void UpdateFrom(Session update) throw new Exception("The method or operation is not implemented."); } - public override string SaveChanges(Session session, string _serverOpaqueRef, Session serverObject) + [Obsolete("Use the calls setting individual fields of the API object instead.")] + public override string SaveChanges(Session session, string serverOpaqueRef, Session serverObject) { throw new Exception("The method or operation is not implemented."); } @@ -248,11 +251,19 @@ public int Timeout set => JsonRpcClient.Timeout = value; } +#if (NET8_0_OR_GREATER) + public Func ServerCertificateValidationCallback + { + get => JsonRpcClient?.ServerCertificateValidationCallback; + set => JsonRpcClient.ServerCertificateValidationCallback = value; + } +#else public RemoteCertificateValidationCallback ServerCertificateValidationCallback { get => JsonRpcClient?.ServerCertificateValidationCallback; set => JsonRpcClient.ServerCertificateValidationCallback = value; } +#endif public ICredentials Credentials => JsonRpcClient?.WebProxy?.Credentials; @@ -306,7 +317,7 @@ public Dictionary RequestHeaders /// instead use Permissions. This list should only be used for UI purposes. /// [JsonConverter(typeof(XenRefListConverter))] - public List Roles => roles; + public List Roles { get; private set; } = new List(); #endregion @@ -315,9 +326,9 @@ public string[] GetSystemMethods() return JsonRpcClient.system_list_methods(); } - public static Session get_record(Session session, string _session) + public static Session get_record(Session session, string sessionOpaqueRef) { - Session newSession = new Session(session.Url) { opaque_ref = _session }; + Session newSession = new Session(session.Url) { opaque_ref = sessionOpaqueRef }; newSession.SetAPIVersion(); return newSession; } @@ -402,13 +413,13 @@ public void logout(Session session2) /// /// Log out of the session with the given reference, using this session for the connection. /// - /// The session to log out - public void logout(string _self) + /// The session to log out + public void logout(string self) { - if (_self == null) + if (self == null) return; - JsonRpcClient.session_logout(_self); + JsonRpcClient.session_logout(self); } public void local_logout() @@ -451,9 +462,9 @@ public string get_this_host() return get_this_host(this, opaque_ref); } - public static string get_this_host(Session session, string _self) + public static string get_this_host(Session session, string self) { - return session.JsonRpcClient.session_get_this_host(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_this_host(session.opaque_ref, self ?? ""); } public string get_this_user() @@ -461,9 +472,9 @@ public string get_this_user() return get_this_user(this, opaque_ref); } - public static string get_this_user(Session session, string _self) + public static string get_this_user(Session session, string self) { - return session.JsonRpcClient.session_get_this_user(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_this_user(session.opaque_ref, self ?? ""); } public bool get_is_local_superuser() @@ -471,14 +482,14 @@ public bool get_is_local_superuser() return get_is_local_superuser(this, opaque_ref); } - public static bool get_is_local_superuser(Session session, string _self) + public static bool get_is_local_superuser(Session session, string self) { - return session.JsonRpcClient.session_get_is_local_superuser(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_is_local_superuser(session.opaque_ref, self ?? ""); } - public static string[] get_rbac_permissions(Session session, string _self) + public static string[] get_rbac_permissions(Session session, string self) { - return session.JsonRpcClient.session_get_rbac_permissions(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_rbac_permissions(session.opaque_ref, self ?? ""); } public DateTime get_last_active() @@ -486,9 +497,9 @@ public DateTime get_last_active() return get_last_active(this, opaque_ref); } - public static DateTime get_last_active(Session session, string _self) + public static DateTime get_last_active(Session session, string self) { - return session.JsonRpcClient.session_get_last_active(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_last_active(session.opaque_ref, self ?? ""); } public bool get_pool() @@ -496,9 +507,9 @@ public bool get_pool() return get_pool(this, opaque_ref); } - public static bool get_pool(Session session, string _self) + public static bool get_pool(Session session, string self) { - return session.JsonRpcClient.session_get_pool(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_pool(session.opaque_ref, self ?? ""); } public XenRef get_subject() @@ -506,9 +517,9 @@ public XenRef get_subject() return get_subject(this, opaque_ref); } - public static XenRef get_subject(Session session, string _self) + public static XenRef get_subject(Session session, string self) { - return session.JsonRpcClient.session_get_subject(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_subject(session.opaque_ref, self ?? ""); } public string get_auth_user_sid() @@ -516,9 +527,9 @@ public string get_auth_user_sid() return get_auth_user_sid(this, opaque_ref); } - public static string get_auth_user_sid(Session session, string _self) + public static string get_auth_user_sid(Session session, string self) { - return session.JsonRpcClient.session_get_auth_user_sid(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_auth_user_sid(session.opaque_ref, self ?? ""); } #region AD SID enumeration and bootout @@ -543,25 +554,25 @@ public static XenRef async_get_all_subject_identifiers(Session session) return session.JsonRpcClient.async_session_get_all_subject_identifiers(session.opaque_ref); } - public string logout_subject_identifier(string subject_identifier) + public string logout_subject_identifier(string subjectIdentifier) { - return logout_subject_identifier(this, subject_identifier); + return logout_subject_identifier(this, subjectIdentifier); } - public static string logout_subject_identifier(Session session, string subject_identifier) + public static string logout_subject_identifier(Session session, string subjectIdentifier) { - session.JsonRpcClient.session_logout_subject_identifier(session.opaque_ref, subject_identifier); + session.JsonRpcClient.session_logout_subject_identifier(session.opaque_ref, subjectIdentifier); return string.Empty; } - public XenRef async_logout_subject_identifier(string subject_identifier) + public XenRef async_logout_subject_identifier(string subjectIdentifier) { - return async_logout_subject_identifier(this, subject_identifier); + return async_logout_subject_identifier(this, subjectIdentifier); } - public static XenRef async_logout_subject_identifier(Session session, string subject_identifier) + public static XenRef async_logout_subject_identifier(Session session, string subjectIdentifier) { - return session.JsonRpcClient.async_session_logout_subject_identifier(session.opaque_ref, subject_identifier); + return session.JsonRpcClient.async_session_logout_subject_identifier(session.opaque_ref, subjectIdentifier); } #endregion @@ -573,39 +584,39 @@ public Dictionary get_other_config() return get_other_config(this, opaque_ref); } - public static Dictionary get_other_config(Session session, string _self) + public static Dictionary get_other_config(Session session, string self) { - return session.JsonRpcClient.session_get_other_config(session.opaque_ref, _self ?? ""); + return session.JsonRpcClient.session_get_other_config(session.opaque_ref, self ?? ""); } - public void set_other_config(Dictionary _other_config) + public void set_other_config(Dictionary otherConfig) { - set_other_config(this, opaque_ref, _other_config); + set_other_config(this, opaque_ref, otherConfig); } - public static void set_other_config(Session session, string _self, Dictionary _other_config) + public static void set_other_config(Session session, string self, Dictionary otherConfig) { - session.JsonRpcClient.session_set_other_config(session.opaque_ref, _self ?? "", _other_config); + session.JsonRpcClient.session_set_other_config(session.opaque_ref, self ?? "", otherConfig); } - public void add_to_other_config(string _key, string _value) + public void add_to_other_config(string key, string value) { - add_to_other_config(this, opaque_ref, _key, _value); + add_to_other_config(this, opaque_ref, key, value); } - public static void add_to_other_config(Session session, string _self, string _key, string _value) + public static void add_to_other_config(Session session, string self, string key, string value) { - session.JsonRpcClient.session_add_to_other_config(session.opaque_ref, _self ?? "", _key ?? "", _value ?? ""); + session.JsonRpcClient.session_add_to_other_config(session.opaque_ref, self ?? "", key ?? "", value ?? ""); } - public void remove_from_other_config(string _key) + public void remove_from_other_config(string key) { - remove_from_other_config(this, opaque_ref, _key); + remove_from_other_config(this, opaque_ref, key); } - public static void remove_from_other_config(Session session, string _self, string _key) + public static void remove_from_other_config(Session session, string self, string key) { - session.JsonRpcClient.session_remove_from_other_config(session.opaque_ref, _self ?? "", _key ?? ""); + session.JsonRpcClient.session_remove_from_other_config(session.opaque_ref, self ?? "", key ?? ""); } #endregion diff --git a/ocaml/sdk-gen/csharp/autogen/src/XenObject.cs b/ocaml/sdk-gen/csharp/autogen/src/XenObject.cs index 3d37279977..10f238a2b0 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/XenObject.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/XenObject.cs @@ -42,15 +42,7 @@ public abstract partial class XenObject : IXenObject where S : XenObject /// public abstract void UpdateFrom(S record); - /// - /// Save any changed fields to the server. - /// This method is usually invoked on a thread pool thread. - /// - /// - /// - /// Changes are sent to the server if the field in "this" - /// is different from serverObject. Can be the object in the cache, or another reference - /// object that we want to save changes to. + [Obsolete("Use the calls setting individual fields of the API object instead.")] public abstract string SaveChanges(Session session, string serverOpaqueRef, S serverObject); public string opaque_ref { get; set; } diff --git a/ocaml/sdk-gen/csharp/autogen/src/XenServer.csproj b/ocaml/sdk-gen/csharp/autogen/src/XenServer.csproj index 8f36aba76f..22acc1de24 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/XenServer.csproj +++ b/ocaml/sdk-gen/csharp/autogen/src/XenServer.csproj @@ -1,7 +1,7 @@  0.0.0 - netstandard2.0;net45 + net80;netstandard2.0;net45 Library XenAPI True @@ -18,6 +18,7 @@ packageIcon.png git README-NuGet.md + true @@ -26,6 +27,7 @@ true + 8981 diff --git a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml index 14b6af5e22..45ee61f46c 100644 --- a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml +++ b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml @@ -353,6 +353,8 @@ and gen_class out_chan cls = print ";\n\ \ }\n\n\ + \ [Obsolete(\"Use the calls setting individual fields of the API \ + object instead.\")]\n\ \ public override string SaveChanges(Session session, string \ opaqueRef, %s server)\n\ \ {\n\ diff --git a/ocaml/sdk-gen/go/dune b/ocaml/sdk-gen/go/dune index 64717b85c6..f8f6999dd0 100644 --- a/ocaml/sdk-gen/go/dune +++ b/ocaml/sdk-gen/go/dune @@ -5,6 +5,7 @@ (libraries CommonFunctions mustache + unix xapi-datamodel xapi-stdext-unix gen_go_helper)) diff --git a/ocaml/sdk-gen/go/gen_go_binding.ml b/ocaml/sdk-gen/go/gen_go_binding.ml index eb7bc73a96..bfa541732a 100644 --- a/ocaml/sdk-gen/go/gen_go_binding.ml +++ b/ocaml/sdk-gen/go/gen_go_binding.ml @@ -105,6 +105,7 @@ let render_converts destdir = let json : Mustache.Json.t = of_json params in render_template template json () ) + |> List.sort_uniq compare |> String.concat "" in let rendered = diff --git a/ocaml/sdk-gen/java/autogen/xen-api/pom.xml b/ocaml/sdk-gen/java/autogen/xen-api/pom.xml index c3a6cabdfd..5dc18e7ec6 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/pom.xml +++ b/ocaml/sdk-gen/java/autogen/xen-api/pom.xml @@ -74,12 +74,12 @@ vcc-releases VCC Release Repository - http://oss.sonatype.org/content/repositories/java-net-releases/ + https://oss.sonatype.org/content/repositories/java-net-releases/ vcc-snapshots VCC Snapshot Repository - http://oss.sonatype.org/content/repositories/java-net-snapshots/ + https://oss.sonatype.org/content/repositories/java-net-snapshots/ diff --git a/ocaml/sdk-gen/java/dune b/ocaml/sdk-gen/java/dune index 31fd56640a..49abc099b4 100644 --- a/ocaml/sdk-gen/java/dune +++ b/ocaml/sdk-gen/java/dune @@ -6,6 +6,7 @@ CommonFunctions mustache str + unix xapi-datamodel xapi-stdext-unix)) diff --git a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs index a1dc4ecf96..52cb8e21e5 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs @@ -32,6 +32,9 @@ using System.IO; using System.Management.Automation; using System.Net; +#if NET8_0_OR_GREATER +using System.Net.Http; +#endif using System.Net.Security; using System.Runtime.InteropServices; using System.Security; @@ -159,7 +162,7 @@ protected override void ProcessRecord() } ServicePointManager.ServerCertificateValidationCallback = ValidateServerCertificate; - ServicePointManager.SecurityProtocol = SecurityProtocolType.Tls | SecurityProtocolType.Tls11 | SecurityProtocolType.Tls12; + ServicePointManager.SecurityProtocol = SecurityProtocolType.Tls12; if (Url == null || Url.Length == 0) { @@ -209,7 +212,7 @@ protected override void ProcessRecord() throw; } } - catch (WebException e) + catch (Exception e) { var inner = e.InnerException?.InnerException ?? //.NET case e.InnerException; //.NET Framework case @@ -271,8 +274,13 @@ private bool ValidateServerCertificate(object sender, X509Certificate certificat bool ignoreChanged = Force || NoWarnCertificates || (bool)GetVariableValue("NoWarnCertificates", false); bool ignoreNew = Force || NoWarnNewCertificates || (bool)GetVariableValue("NoWarnNewCertificates", false); - HttpWebRequest webreq = (HttpWebRequest)sender; - string hostname = webreq.Address.Host; +#if NET8_0_OR_GREATER + 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; +#endif string fingerprint = CommonCmdletFunctions.FingerprintPrettyString(certificate.GetCertHashString()); bool trusted = VerifyInAllStores(new X509Certificate2(certificate)); diff --git a/ocaml/sdk-gen/powershell/autogen/src/XenServerPowerShell.csproj b/ocaml/sdk-gen/powershell/autogen/src/XenServerPowerShell.csproj index 1fb6483bd3..35c2fc8fa4 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/XenServerPowerShell.csproj +++ b/ocaml/sdk-gen/powershell/autogen/src/XenServerPowerShell.csproj @@ -1,7 +1,7 @@ 0.0.0 - net8.0;net6.0;net45 + net8.0;net45 Library True @@ -12,14 +12,8 @@ - - - - - False - $(MSBuildProgramFiles32)\Reference Assemblies\Microsoft\WindowsPowerShell\3.0\System.Management.Automation.dll - + diff --git a/ocaml/squeezed/src/dune b/ocaml/squeezed/src/dune index bb73a91f39..4e9fe64309 100644 --- a/ocaml/squeezed/src/dune +++ b/ocaml/squeezed/src/dune @@ -8,10 +8,10 @@ xapi-stdext-unix xapi_version astring - rpclib.core squeeze threads.posix + unix xenctrl xenstore xenstore.unix diff --git a/ocaml/tapctl/dune b/ocaml/tapctl/dune index 903e35a63d..b4b23f9951 100644 --- a/ocaml/tapctl/dune +++ b/ocaml/tapctl/dune @@ -10,6 +10,7 @@ rpclib.json threads.posix forkexec + unix xapi-stdext-unix xapi-stdext-threads ) diff --git a/ocaml/tests/bench/bechamel_simple_cli.ml b/ocaml/tests/bench/bechamel_simple_cli.ml index e40399cf04..bcbd574f7f 100644 --- a/ocaml/tests/bench/bechamel_simple_cli.ml +++ b/ocaml/tests/bench/bechamel_simple_cli.ml @@ -1,3 +1,17 @@ +(* + * 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 Bechamel open Toolkit @@ -83,11 +97,19 @@ let thread_workload ~before ~run ~after = a few times. Bechamel has both an iteration count and time limit, so this won't be a problem for slower benchmarks. *) -let limit = 10_000_000 +let default_limit = 10_000_000 -let benchmark ~instances tests = - let cfg = Benchmark.cfg ~limit ~quota:(Time.second 10.0) () in - Benchmark.all cfg instances tests +let benchmark ~instances cfg tests = + let n = List.length tests in + tests + |> List.to_seq + |> Seq.mapi (fun i test -> + let name = Test.Elt.name test in + Format.eprintf "Running benchmark %u/%u %s ...@?" (i + 1) n name ; + let results = Benchmark.run cfg instances test in + Format.eprintf "@." ; (name, results) + ) + |> Hashtbl.of_seq let analyze ~instances raw_results = let ols ~bootstrap = @@ -108,14 +130,13 @@ open Notty_unix let img (window, results) = Bechamel_notty.Multiple.image_of_ols_results ~rect:window ~predictor:Measure.run results - |> eol let not_workload measure = not (Measure.label measure = skip_label) -let run_and_print instances tests = - let results, _ = +let run_and_print cfg instances tests = + let results, raw_results = tests - |> benchmark ~instances + |> benchmark ~instances cfg |> analyze ~instances:(List.filter not_workload instances) in let window = @@ -127,27 +148,132 @@ let run_and_print instances tests = in img (window, results) |> eol |> output_image ; results - |> Hashtbl.iter @@ fun label results -> - if label = Measure.label Instance.monotonic_clock then - let units = Bechamel_notty.Unit.unit_of_label label in - results - |> Hashtbl.iter @@ fun name ols -> - Format.printf "%s (%s):@, %a@." name units Analyze.OLS.pp ols + |> Hashtbl.iter (fun label results -> + if label = Measure.label Instance.monotonic_clock then + let units = Bechamel_notty.Unit.unit_of_label label in + results + |> Hashtbl.iter @@ fun name ols -> + Format.printf "%s (%s):@, %a@." name units Analyze.OLS.pp ols + ) ; + (results, raw_results) -let cli ?(always = []) ?(workloads = []) tests = +let cli ~always ~workloads cfg tests store = let instances = always @ Instance.[monotonic_clock; minor_allocated; major_allocated] @ always in List.iter (fun i -> Bechamel_notty.Unit.add i (Measure.unit i)) instances ; - Format.printf "@,Running benchmarks (no workloads)@." ; - run_and_print instances tests ; - + Format.eprintf "@,Running benchmarks (no workloads)@." ; + let _, raw_results = run_and_print cfg instances tests in if workloads <> [] then ( - Format.printf "@,Running benchmarks (workloads)@." ; + Format.eprintf "@,Running benchmarks (workloads)@." ; List.iter (fun i -> Bechamel_notty.Unit.add i (Measure.unit i)) workloads ; (* workloads come first, so that we unpause them in time *) let instances = workloads @ instances @ workloads in - run_and_print instances tests - ) + let _, _ = run_and_print cfg instances tests in + () + ) ; + store + |> Option.iter @@ fun dir -> + let epoch = Unix.gettimeofday () in + raw_results + |> Hashtbl.iter @@ fun label results -> + let label = String.map (function '/' -> '_' | c -> c) label in + let dir = Filename.concat dir (Float.to_string epoch) in + let () = + try Unix.mkdir dir 0o700 + with Unix.Unix_error (Unix.EEXIST, _, _) -> () + in + + let file = Filename.concat dir (label ^ ".dat") in + Out_channel.with_open_text file @@ fun out -> + let label = Measure.label Instance.monotonic_clock in + results.Benchmark.lr + |> Array.iter @@ fun measurement -> + let repeat = Measurement_raw.run measurement in + let avg = Measurement_raw.get ~label measurement /. repeat in + (* ministat wants to compare individual measurements, but all we have is a sum. *) + Printf.fprintf out "%.16g\n" avg + +open Cmdliner + +let cli ?(always = []) ?(workloads = []) tests = + let tests = List.concat_map Test.elements tests in + let cmd = + let test_names = tests |> List.map (fun t -> (Test.Elt.name t, t)) in + let filtered = + let doc = + Printf.sprintf "Choose the benchmarks to run. $(docv) must be %s" + Arg.(doc_alts_enum test_names) + in + Arg.( + value + & pos_all (enum test_names) tests + & info [] ~absent:"all" ~doc ~docv:"BENCHMARK" + ) + and cfg = + let open Term.Syntax in + let+ limit = + Arg.( + value + & opt int default_limit + & info ["limit"] ~doc:"Maximum number of samples" ~docv:"SAMPLES" + ) + and+ quota = + Arg.( + value + & opt float 10.0 (* 1s is too short to reach high batch sizes *) + & info ["quota"] ~doc:"Maximum time per benchmark" ~docv:"SECONDS" + ) + and+ kde = + Arg.( + value + & opt (some int) None + & info ["kde"] ~doc:"Additional samples for Kernel Density Estimation" + ~docv:"SAMPLES" + ) + and+ stabilize = + Arg.( + value + & opt bool false + & info ["stabilize"] ~doc:"Stabilize the GC between measurements" + (* this actually makes measurements more noisy, not less + (although there'll be the ocasional outlier). + When stabilization is disabled we can instead get more measurements within the same amount of time, + which ultimately increases accuracy. + core_bench also has this disabled by default + *) + ) + and+ compaction = + Arg.( + value + & opt bool false + (* avoid large differences between runs (since we no longer stabilize the GC) *) + & info ["compaction"] ~doc:"Enable GC compaction" + ) + and+ start = + Arg.( + value + & opt int 5 (* small batches can have higher overhead: skip them *) + & info ["start"] ~doc:"Starting iteration count" ~docv:"COUNT" + ) + in + Benchmark.cfg ~limit + ~quota:Time.(second quota) + ~kde ~stabilize ~compaction ~start () + and store = + Arg.( + value + & opt (some dir) None + & info ["output-dir"; "d"] + ~doc: + "directory to save the raw results to. The output can be used by \ + ministat" + ~docv:"DIRECTORY" + ) + in + let info = Cmd.info "benchmark" ~doc:"Run benchmarks" in + Cmd.v info Term.(const (cli ~always ~workloads) $ cfg $ filtered $ store) + in + exit (Cmd.eval cmd) diff --git a/ocaml/tests/bench/bench_cached_reads.ml b/ocaml/tests/bench/bench_cached_reads.ml index e81a8991cb..bcba2ed6cf 100644 --- a/ocaml/tests/bench/bench_cached_reads.ml +++ b/ocaml/tests/bench/bench_cached_reads.ml @@ -8,7 +8,6 @@ let mutex_workload = Bechamel_simple_cli.thread_workload ~before:ignore ~after:ignore ~run let benchmarks = - Test.make_grouped ~name:"Cached reads" - [Test.make ~name:"Pool_role.is_master" (Staged.stage Pool_role.is_master)] + [Test.make ~name:"Pool_role.is_master" (Staged.stage Pool_role.is_master)] let () = Bechamel_simple_cli.cli ~workloads:[mutex_workload] benchmarks diff --git a/ocaml/tests/bench/bench_pool_field.ml b/ocaml/tests/bench/bench_pool_field.ml new file mode 100644 index 0000000000..bd34693a92 --- /dev/null +++ b/ocaml/tests/bench/bench_pool_field.ml @@ -0,0 +1,142 @@ +(* + * 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 Bechamel + +let () = + Suite_init.harness_init () ; + Printexc.record_backtrace true ; + Debug.set_level Syslog.Emerg ; + Xapi_event.register_hooks () + +let date = "20250102T03:04:05Z" + +let json_dict = + [ + ("fingerprint_sha256", String.make 64 'd') + ; ("not_before", date) + ; ("not_after", date) + ; ("subject", String.make 100 'x') + ; ("san", String.make 50 'y') + ] + +let json_str = + Rpc.Dict (List.map (fun (k, v) -> (k, Rpc.rpc_of_string v)) json_dict) + |> Jsonrpc.to_string + +let __context = Test_common.make_test_database () + +let host = Test_common.make_host ~__context () + +let pool = Test_common.make_pool ~__context ~master:host () + +let () = + Db.Pool.set_license_server ~__context ~self:pool + ~value:[("jsontest", json_str)] ; + let open Xapi_database in + Db_ref.update_database + (Context.database_of __context) + (Db_cache_types.Database.register_callback "redo_log" + Redo_log.database_callback + ) + +let vm = Test_common.make_vm ~__context ~name_label:"test" () + +let get_all () : API.pool_t list = + Db.Pool.get_all_records ~__context |> List.map snd + +let all = get_all () + +let serialize () : Rpc.t list = all |> List.map API.rpc_of_pool_t + +let serialized = serialize () + +let deserialize () : API.pool_t list = serialized |> List.map API.pool_t_of_rpc + +let str_sexpr_json = SExpr.(string_of (String json_str)) + +let sexpr_of_json_string () = SExpr.(string_of (String json_str)) + +let str_of_sexpr_json () = SExpr.mkstring str_sexpr_json + +let date_of_iso8601 () = Clock.Date.of_iso8601 date + +let local_session_hook () = + Xapi_local_session.local_session_hook ~__context ~session_id:Ref.null + +let atomic = Atomic.make 0 + +let atomic_inc () = Atomic.incr atomic + +let mutex = Mutex.create () + +let locked_ref = ref 0 + +let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute + +let inc_locked () = incr locked_ref + +let inc_with_mutex () = with_lock mutex inc_locked + +let noop () = Sys.opaque_identity () + +let db_lock_uncontended () : unit = Xapi_database.Db_lock.with_lock noop + +let event = + let open Event_types in + { + id= "id" + ; ts= "1000" + ; ty= "test" + ; op= `add + ; reference= "test" + ; snapshot= Some (Rpc.Dict []) + } + +let test_rpc_of_event () = Event_types.rpc_of_event event + +let counter = Atomic.make 0 + +let test_set_vm_nvram () : unit = + let c = Atomic.fetch_and_add counter 1 mod 0x7F in + (* use different value each iteration, otherwise it becomes a noop *) + Db.VM.set_NVRAM ~__context ~self:vm + ~value:[("test", String.make 32768 (Char.chr @@ c))] + +let test_db_pool_write () = + let c = Atomic.fetch_and_add counter 1 mod 0x7F in + Db.Pool.set_tags ~__context ~self:pool ~value:[String.make 16 (Char.chr @@ c)] + +let test_db_pool_read () = Db.Pool.get_tags ~__context ~self:pool + +let benchmarks = + [ + Test.make ~name:"local_session_hook" (Staged.stage local_session_hook) + ; Test.make ~name:"Date.of_iso8601" (Staged.stage date_of_iso8601) + ; Test.make ~name:"sexpr_of_json_string" (Staged.stage sexpr_of_json_string) + ; Test.make ~name:"str_of_sexp_json" (Staged.stage str_of_sexpr_json) + ; Test.make ~name:"Db.Pool.get_all_records" (Staged.stage get_all) + ; Test.make ~name:"pool_t -> Rpc.t" (Staged.stage serialize) + ; Test.make ~name:"Rpc.t -> pool_t" (Staged.stage deserialize) + ; Test.make ~name:"Atomic.incr" (Staged.stage atomic_inc) + ; Test.make ~name:"Mutex+incr" (Staged.stage inc_with_mutex) + ; Test.make ~name:"Db_lock.with_lock uncontended" + (Staged.stage db_lock_uncontended) + ; Test.make ~name:"rpc_of_event" (Staged.stage test_rpc_of_event) + ; Test.make ~name:"Db.Pool.set_tags" (Staged.stage test_db_pool_write) + ; Test.make ~name:"Db.Pool.get_tags" (Staged.stage test_db_pool_read) + ; Test.make ~name:"Db.VM.set_NVRAM" (Staged.stage test_set_vm_nvram) + ] + +let () = Bechamel_simple_cli.cli benchmarks diff --git a/ocaml/tests/bench/bench_throttle2.ml b/ocaml/tests/bench/bench_throttle2.ml index 50582eff4c..b4f6117342 100644 --- a/ocaml/tests/bench/bench_throttle2.ml +++ b/ocaml/tests/bench/bench_throttle2.ml @@ -66,21 +66,20 @@ let run_tasks'' n (__context, tasks) = Thread.join t let benchmarks = - Test.make_grouped ~name:"Task latency" - [ - Test.make_indexed_with_resource ~name:"task complete+wait latency" - ~args:[1; 10; 100] Test.multiple ~allocate:allocate_tasks - ~free:free_tasks (fun n -> Staged.stage (run_tasks n) - ) - ; Test.make_indexed_with_resource ~name:"task complete+wait all latency" - ~args:[1; 10; 100] Test.multiple ~allocate:allocate_tasks - ~free:free_tasks (fun n -> Staged.stage (run_tasks' n) - ) - ; Test.make_indexed_with_resource - ~name:"task complete+wait all latency (thread)" ~args:[1; 10; 100] - Test.multiple ~allocate:allocate_tasks ~free:free_tasks (fun n -> - Staged.stage (run_tasks'' n) - ) - ] + [ + Test.make_indexed_with_resource ~name:"task complete+wait latency" + ~args:[1; 10; 100] Test.multiple ~allocate:allocate_tasks ~free:free_tasks + (fun n -> Staged.stage (run_tasks n) + ) + ; Test.make_indexed_with_resource ~name:"task complete+wait all latency" + ~args:[1; 10; 100] Test.multiple ~allocate:allocate_tasks ~free:free_tasks + (fun n -> Staged.stage (run_tasks' n) + ) + ; Test.make_indexed_with_resource + ~name:"task complete+wait all latency (thread)" ~args:[1; 10; 100] + Test.multiple ~allocate:allocate_tasks ~free:free_tasks (fun n -> + Staged.stage (run_tasks'' n) + ) + ] let () = Bechamel_simple_cli.cli benchmarks diff --git a/ocaml/tests/bench/bench_tracing.ml b/ocaml/tests/bench/bench_tracing.ml index eebe6e6aef..8db30cfc22 100644 --- a/ocaml/tests/bench/bench_tracing.ml +++ b/ocaml/tests/bench/bench_tracing.ml @@ -25,7 +25,7 @@ let export_thread = (* need to ensure this isn't running outside the benchmarked section, or bechamel might fail with 'Failed to stabilize GC' *) - let after _ = Tracing_export.flush_and_exit () in + let after _ = Tracing_export.flush_and_exit ~max_wait:0. () in Bechamel_simple_cli.thread_workload ~before:Tracing_export.main ~after ~run:ignore @@ -52,7 +52,7 @@ let allocate () = let free t = Tracing.TracerProvider.destroy ~uuid ; - Tracing_export.flush_and_exit () ; + Tracing_export.flush_and_exit ~max_wait:0. () ; Thread.join t let test_tracing_on ?(overflow = false) ~name f = @@ -64,24 +64,23 @@ let test_tracing_on ?(overflow = false) ~name f = allocate () and free t = if overflow then ( - Tracing.Spans.set_max_spans Bechamel_simple_cli.limit ; - Tracing.Spans.set_max_traces Bechamel_simple_cli.limit + Tracing.Spans.set_max_spans Bechamel_simple_cli.default_limit ; + Tracing.Spans.set_max_traces Bechamel_simple_cli.default_limit ) ; free t in Test.make_with_resource ~name ~allocate ~free Test.uniq f let benchmarks = - Tracing.Spans.set_max_spans Bechamel_simple_cli.limit ; - Tracing.Spans.set_max_traces Bechamel_simple_cli.limit ; - Test.make_grouped ~name:"tracing" - [ - Test.make ~name:"overhead(off)" (Staged.stage trace_test_off) - ; test_tracing_on ~name:"overhead(on, no span)" (Staged.stage trace_test_off) - ; test_tracing_on ~name:"overhead(on, create span)" - (Staged.stage trace_test_span) - ; test_tracing_on ~overflow:true ~name:"max span overflow" - (Staged.stage trace_test_span) - ] + Tracing.Spans.set_max_spans Bechamel_simple_cli.default_limit ; + Tracing.Spans.set_max_traces Bechamel_simple_cli.default_limit ; + [ + Test.make ~name:"overhead(off)" (Staged.stage trace_test_off) + ; test_tracing_on ~name:"overhead(on, no span)" (Staged.stage trace_test_off) + ; test_tracing_on ~name:"overhead(on, create span)" + (Staged.stage trace_test_span) + ; test_tracing_on ~overflow:true ~name:"max span overflow" + (Staged.stage trace_test_span) + ] let () = Bechamel_simple_cli.cli ~always:[export_thread] ~workloads benchmarks diff --git a/ocaml/tests/bench/bench_uuid.ml b/ocaml/tests/bench/bench_uuid.ml index f13118e48d..53e817211a 100644 --- a/ocaml/tests/bench/bench_uuid.ml +++ b/ocaml/tests/bench/bench_uuid.ml @@ -1,10 +1,9 @@ open Bechamel let benchmarks = - Test.make_grouped ~name:"uuidx creation" - [ - Test.make ~name:"Uuidx.make_uuid_urnd" (Staged.stage Uuidx.make_uuid_urnd) - ; Test.make ~name:"Uuidx.make" (Staged.stage Uuidx.make) - ] + [ + Test.make ~name:"Uuidx.make_uuid_urnd" (Staged.stage Uuidx.make_uuid_urnd) + ; Test.make ~name:"Uuidx.make" (Staged.stage Uuidx.make) + ] let () = Bechamel_simple_cli.cli benchmarks diff --git a/ocaml/tests/bench/bench_vdi_allowed_operations.ml b/ocaml/tests/bench/bench_vdi_allowed_operations.ml index 9400490fde..5b13084370 100644 --- a/ocaml/tests/bench/bench_vdi_allowed_operations.ml +++ b/ocaml/tests/bench/bench_vdi_allowed_operations.ml @@ -50,10 +50,9 @@ let test_vdi_update_allowed_operations (__context, vm_disks) = Xapi_vdi.update_allowed_operations ~__context ~self:vdi_ref let benchmarks = - Test.make_grouped ~name:"update_allowed_operations" - [ - Test.make_with_resource ~name:"VDI" ~allocate ~free:ignore Test.uniq - (Staged.stage test_vdi_update_allowed_operations) - ] + [ + Test.make_with_resource ~name:"VDI" ~allocate ~free:ignore Test.uniq + (Staged.stage test_vdi_update_allowed_operations) + ] let () = Bechamel_simple_cli.cli benchmarks diff --git a/ocaml/tests/bench/dune b/ocaml/tests/bench/dune index 61f9278775..a61bafa186 100644 --- a/ocaml/tests/bench/dune +++ b/ocaml/tests/bench/dune @@ -4,18 +4,29 @@ bench_uuid bench_throttle2 bench_cached_reads - bench_vdi_allowed_operations) + bench_vdi_allowed_operations + bench_pool_field) (libraries + dune-build-info tracing bechamel bechamel-notty + clock + cmdliner notty.unix tracing_export threads.posix + rpclib.core + rpclib.json + sexpr fmt notty uuid xapi_aux tests_common log - xapi_internal)) + unix + xapi_database + xapi_datamodel + xapi_internal + xapi-stdext-threads)) diff --git a/ocaml/tests/binpack_test.ml b/ocaml/tests/binpack_test.ml index 27ab15e9f3..4544d7ffcb 100644 --- a/ocaml/tests/binpack_test.ml +++ b/ocaml/tests/binpack_test.ml @@ -45,10 +45,7 @@ let check_plan config dead_hosts plan = let memory_remaining = account config.hosts config.vms plan in (* List.iter (fun mem -> Printf.printf "%Ld\n" mem) free; *) (* No host should be overcommitted: *) - if - List.fold_left ( || ) false - (List.map (fun x -> x < 0L) (List.map snd memory_remaining)) - then + if List.exists (fun (_, x) -> x < 0L) memory_remaining then raise BadPlan ; (* All failed VMs should be restarted: *) let failed_vms = get_failed_vms config dead_hosts in diff --git a/ocaml/tests/common/dune b/ocaml/tests/common/dune index 20ec22dcbb..55741b8e67 100644 --- a/ocaml/tests/common/dune +++ b/ocaml/tests/common/dune @@ -12,6 +12,7 @@ rpclib.xml threads.posix uuid + unix xapi_aux xapi-consts xapi_database diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index 3ff9bea238..09f6a3b465 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -43,6 +43,7 @@ let default_cpu_info = ("cpu_count", "0") ; ("socket_count", "0") ; ("threads_per_core", "0") + ; ("nr_nodes", "0") ; ("vendor", "Abacus") ; ("speed", "") ; ("modelname", "") @@ -79,6 +80,7 @@ let make_localhost ~__context ?(features = Features.all_features) () = cpu_count= 1 ; socket_count= 1 ; threads_per_core= 1 + ; nr_nodes= 1 ; vendor= "" ; speed= "" ; modelname= "" @@ -170,13 +172,18 @@ let make_host ~__context ?(uuid = make_uuid ()) ?(name_label = "host") ?(external_auth_service_name = "") ?(external_auth_configuration = []) ?(license_params = []) ?(edition = "free") ?(license_server = []) ?(local_cache_sr = Ref.null) ?(chipset_info = []) ?(ssl_legacy = false) - ?(last_software_update = Date.epoch) ?(last_update_hash = "") () = + ?(last_software_update = Date.epoch) ?(last_update_hash = "") + ?(ssh_enabled = true) ?(ssh_enabled_timeout = 0L) ?(ssh_expiry = Date.epoch) + ?(console_idle_timeout = 0L) ?(ssh_auto_mode = false) ?(secure_boot = false) + () = let host = Xapi_host.create ~__context ~uuid ~name_label ~name_description ~hostname ~address ~external_auth_type ~external_auth_service_name ~external_auth_configuration ~license_params ~edition ~license_server ~local_cache_sr ~chipset_info ~ssl_legacy ~last_software_update - ~last_update_hash + ~last_update_hash ~ssh_enabled ~ssh_enabled_timeout ~ssh_expiry + ~console_idle_timeout ~ssh_auto_mode ~secure_boot + ~software_version:(Xapi_globs.software_version ()) in Db.Host.set_cpu_info ~__context ~self:host ~value:default_cpu_info ; host @@ -215,7 +222,9 @@ let make_host2 ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) ~last_software_update:(Xapi_host.get_servertime ~__context ~host:ref) ~recommended_guidances:[] ~latest_synced_updates_applied:`unknown ~pending_guidances_recommended:[] ~pending_guidances_full:[] - ~last_update_hash:"" ; + ~last_update_hash:"" ~ssh_enabled:true ~ssh_enabled_timeout:0L + ~ssh_expiry:Date.epoch ~console_idle_timeout:0L ~ssh_auto_mode:false + ~secure_boot:false ; ref let make_pif ~__context ~network ~host ?(device = "eth0") diff --git a/ocaml/tests/dune b/ocaml/tests/dune index c4b590c6cb..f829e72c88 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -7,7 +7,7 @@ test_cluster_host test_cluster test_pusb test_network_sriov test_client test_valid_ref_list suite_alcotest_server test_vm_placement test_vm_helpers test_repository test_repository_helpers - test_ref test_xapi_helpers test_vm_group test_host_driver_helpers + test_ref test_xapi_helpers test_vm_group test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer test_pool_periodic_update_sync test_pkg_mgr test_tar_ext test_pool_repository)) (libraries @@ -15,7 +15,7 @@ angstrom astring cstruct - + digestif fmt http_lib httpsvr @@ -31,6 +31,7 @@ tests_common threads.posix uuid + unix xapi-backtrace xapi-consts xapi-datamodel @@ -50,7 +51,6 @@ xapi_xenopsd xapi_cli_server xapi_database - xapi_host_driver_helpers xapi_internal xml-light2 ) @@ -72,25 +72,25 @@ http_lib xapi-log clock + unix xapi-types xapi_internal xapi_internal_server ) ) - (tests (names test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_bounded_psq test_auth_cache test_clustering test_pusb test_daemon_manager test_repository test_repository_helpers test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_pkg_mgr - test_xapi_helpers test_tar_ext test_pool_repository test_host_driver_helpers) + test_xapi_helpers test_tar_ext test_pool_repository) (package xapi) (modes exe) (modules test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_bounded_psq test_auth_cache test_event test_clustering test_cluster_host test_cluster test_pusb test_daemon_manager test_repository test_repository_helpers test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_pkg_mgr - test_xapi_helpers test_tar_ext test_pool_repository test_host_driver_helpers) + test_xapi_helpers test_tar_ext test_pool_repository) (libraries alcotest bos @@ -104,6 +104,7 @@ rresult tests_common threads.posix + unix uuid xapi-client xapi-consts @@ -121,13 +122,13 @@ xapi-types xapi_cli_server xapi_database - xapi_host_driver_helpers xapi_internal xml-light2 yojson ) (preprocess (per_module ((pps ppx_deriving_rpc) Test_cluster_host))) ) + (test (name test_storage_smapiv1_wrapper) (modes exe) @@ -171,27 +172,6 @@ (action (run ./check-no-xenctrl %{x})) ) -(rule - (alias runtest) - (package xapi) - (targets - .note.XenServer - .note.Linux - .note.gnu.build-id - .note.XenServerTwo - ) - (deps - (:asm - test_data/xenserver.s - test_data/xenserver_two_notes.s - test_data/linux.s - test_data/buildid.s - ) - (:script test_data/gen_notes.sh) - ) - (action (bash "%{script} %{asm}")) -) - (env (_ (env-vars (XAPI_TEST 1)))) ; disassemble, but without sources diff --git a/ocaml/tests/suite_alcotest.ml b/ocaml/tests/suite_alcotest.ml index 7c425e3963..9c776b375c 100644 --- a/ocaml/tests/suite_alcotest.ml +++ b/ocaml/tests/suite_alcotest.ml @@ -70,4 +70,5 @@ let () = @ Test_session.tests @ Test_xapi_cmd_result.tests @ Test_extauth_plugin_ADwinbind.tests + @ Test_tracked_user_agents.tests ) diff --git a/ocaml/tests/test_certificates.ml b/ocaml/tests/test_certificates.ml index 96017d3156..dcd018e099 100644 --- a/ocaml/tests/test_certificates.ml +++ b/ocaml/tests/test_certificates.ml @@ -13,7 +13,7 @@ let pp_hash_test = (fun (hashable, expected) -> let test_hash () = let digest = - Cstruct.of_string hashable |> Mirage_crypto.Hash.digest `SHA256 + Digestif.SHA256.(digest_string hashable |> to_raw_string) in Alcotest.(check string) "fingerprints must match" expected diff --git a/ocaml/tests/test_cluster.ml b/ocaml/tests/test_cluster.ml index d24e36fe72..9c945776cd 100644 --- a/ocaml/tests/test_cluster.ml +++ b/ocaml/tests/test_cluster.ml @@ -34,9 +34,11 @@ let test_clusterd_rpc ~__context call = | "Observer.init" | "Observer.set_trace_log_dir" | "Observer.set_export_interval" + | "Observer.set_export_chunk_size" | "Observer.set_host_id" | "Observer.set_max_traces" | "Observer.set_max_spans" + | "Observer.set_max_depth" | "Observer.set_max_file_size" | "Observer.set_compress_tracing_files" ) , _ ) -> diff --git a/ocaml/tests/test_clustering.ml b/ocaml/tests/test_clustering.ml index 9be97c5fdb..edd33cb602 100644 --- a/ocaml/tests/test_clustering.ml +++ b/ocaml/tests/test_clustering.ml @@ -581,11 +581,21 @@ let test_disallow_unplug_during_cluster_host_create () = let key = Context.get_task_id __context |> Ref.string_of in Db.Cluster.add_to_current_operations ~__context ~self:cluster ~key ~value in - let check_disallow_unplug_false_fails self msg = + let check_disallow_unplug_false_fails self op msg = + let op_ref, _ = + List.hd (Db.Cluster.get_current_operations ~__context ~self:cluster) + in Alcotest.check_raises msg Api_errors.( Server_error - (other_operation_in_progress, ["Cluster"; Ref.string_of cluster]) + ( other_operation_in_progress + , [ + "Cluster" + ; Ref.string_of cluster + ; API.cluster_operation_to_string op + ; op_ref + ] + ) ) (fun () -> Xapi_pif.set_disallow_unplug ~__context ~self ~value:false) in @@ -598,14 +608,14 @@ let test_disallow_unplug_during_cluster_host_create () = let test_with_current op = Xapi_pif.set_disallow_unplug ~__context ~self:pIF ~value:true ; add_op op ; - check_disallow_unplug_false_fails pIF + check_disallow_unplug_false_fails pIF op "disallow_unplug cannot be set to false during cluster_host creation or \ enable on same PIF" ; let other_pif = T.make_pif ~__context ~network ~host () in check_successful_disallow_unplug true other_pif "Should always be able to set disallow_unplug:true regardless of \ clustering operations" ; - check_disallow_unplug_false_fails other_pif + check_disallow_unplug_false_fails other_pif op "disallow_unplug cannot be set to false during cluster_host creation or \ enable on any PIF" ; let key = Context.get_task_id __context |> Ref.string_of in diff --git a/ocaml/tests/test_data/buildid.s b/ocaml/tests/test_data/buildid.s deleted file mode 100644 index 75f7776698..0000000000 --- a/ocaml/tests/test_data/buildid.s +++ /dev/null @@ -1,9 +0,0 @@ -.section ".note.gnu.build-id", "a" - .p2align 2 - .long 1f - 0f # name size (not including padding) - .long 3f - 2f # desc size (not including padding) - .long 0x1 # type -0: .asciz "gnu.build-id" # name -1: .p2align 2 -2: .long 0x000000 # desc -3: .p2align 2 diff --git a/ocaml/tests/test_data/gen_notes.sh b/ocaml/tests/test_data/gen_notes.sh deleted file mode 100755 index 9b173bd31d..0000000000 --- a/ocaml/tests/test_data/gen_notes.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/bash -# -# 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. - -elf_file=test_data/xenserver_elf_file -as "$@" -o $elf_file - -sections=$(readelf -n $elf_file | grep -Po "(?<=Displaying notes found in: ).*") -for dep in $sections; do - objcopy "$elf_file" "$dep" --only-section="$dep" -O binary -done - diff --git a/ocaml/tests/test_data/linux.s b/ocaml/tests/test_data/linux.s deleted file mode 100644 index ca106e94af..0000000000 --- a/ocaml/tests/test_data/linux.s +++ /dev/null @@ -1,9 +0,0 @@ -.section ".note.Linux", "a" - .p2align 2 - .long 1f - 0f # name size (not including padding) - .long 3f - 2f # desc size (not including padding) - .long 0x257 # type -0: .asciz "Linux" # name -1: .p2align 2 -2: .asciz "4.19.0+1" # desc -3: .p2align 2 diff --git a/ocaml/tests/test_data/xenserver.s b/ocaml/tests/test_data/xenserver.s deleted file mode 100644 index f44575ce5e..0000000000 --- a/ocaml/tests/test_data/xenserver.s +++ /dev/null @@ -1,9 +0,0 @@ -.section ".note.XenServer", "a" - .p2align 2 - .long 1f - 0f # name size (not including padding) - .long 3f - 2f # desc size (not including padding) - .long 0x1 # type -0: .asciz "XenServer" # name -1: .p2align 2 -2: .asciz "v2.1.3+0.1fix" # desc -3: .p2align 2 diff --git a/ocaml/tests/test_data/xenserver_two_notes.s b/ocaml/tests/test_data/xenserver_two_notes.s deleted file mode 100644 index cbde4916dd..0000000000 --- a/ocaml/tests/test_data/xenserver_two_notes.s +++ /dev/null @@ -1,20 +0,0 @@ -.section ".note.XenServerTwo", "a" - .p2align 2 - .long 1f - 0f # name size (not including padding) - .long 3f - 2f # desc size (not including padding) - .long 0x2 # type -0: .asciz "XenServer" # name -1: .p2align 2 -2: .asciz "Built on December 25th" # desc -3: .p2align 2 - -.section ".note.XenServerTwo", "a" - .p2align 2 - .long 1f - 0f # name size (not including padding) - .long 3f - 2f # desc size (not including padding) - .long 0x1 # type -0: .asciz "XenServer" # name -1: .p2align 2 -2: .asciz "2.0.0-rc.2" # desc -3: .p2align 2 - diff --git a/ocaml/tests/test_event.ml b/ocaml/tests/test_event.ml index 821bb3bb52..6ae77c6240 100644 --- a/ocaml/tests/test_event.ml +++ b/ocaml/tests/test_event.ml @@ -117,7 +117,7 @@ let event_next_test () = let __context, _ = event_setup_common () in let () = Xapi_event.register ~__context ~classes:["pool"] in let wait_hdl = Delay.make () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let key = "event_next_test" in ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key with _ -> () @@ -146,7 +146,7 @@ let event_next_test () = let wait_for_pool_key __context key = let token = ref "" in let finished = ref false in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in while not !finished do let events = Xapi_event.from ~__context ~classes:["pool"] ~token:!token ~timeout:10. @@ -160,7 +160,7 @@ let wait_for_pool_key __context key = let event_from_test () = let __context, _ = event_setup_common () in let wait_hdl = Delay.make () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let key = "event_from_test" in ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key with _ -> () @@ -180,7 +180,7 @@ let event_from_test () = let event_from_parallel_test () = let __context, _ = event_setup_common () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let key = "event_next_test" in ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key with _ -> () diff --git a/ocaml/tests/test_extauth_plugin_ADwinbind.ml b/ocaml/tests/test_extauth_plugin_ADwinbind.ml index 5fe5bfc91c..6b3e58e3b3 100644 --- a/ocaml/tests/test_extauth_plugin_ADwinbind.ml +++ b/ocaml/tests/test_extauth_plugin_ADwinbind.ml @@ -219,6 +219,27 @@ let test_parse_wbinfo_uid_info = ; gecos= {|ladmin|} } ) + (* XSI-1901: output of customer environment, has `:` in the gecos, + other fields does not likely contain it *) + ; ( {|HVS\udaadmin:*:3000000:3000000:ADMIN: Dalsem, Ulric:/home/HVS/udaadmin:/bin/bash|} + , Ok + { + user_name= {|HVS\udaadmin|} + ; uid= 3000000 + ; gid= 3000000 + ; gecos= {|ADMIN: Dalsem, Ulric|} + } + ) + (* Multiple `:` in gecos *) + ; ( {|HVS\udaadmin:*:3000000:3000000:ADMIN: Dalsem, Ulric, POOL OP: udaadmin:/home/HVS/udaadmin:/bin/bash|} + , Ok + { + user_name= {|HVS\udaadmin|} + ; uid= 3000000 + ; gid= 3000000 + ; gecos= {|ADMIN: Dalsem, Ulric, POOL OP: udaadmin|} + } + ) ; ( {|CONNAPP\locked:*:3000004:3000174::/home/CONNAPP/locked:/bin/bash|} , Ok {user_name= {|CONNAPP\locked|}; uid= 3000004; gid= 3000174; gecos= ""} @@ -517,17 +538,17 @@ let test_add_ipv4_localhost_to_hosts = localhost4.localdomain4" ] , [ - "127.0.0.1 localhost localhost.localdomain localhost4 \ - localhost4.localdomain4 hostname hostname.domain" + "127.0.0.1 hostname.domain hostname localhost \ + localhost.localdomain localhost4 localhost4.localdomain4" ] ) ; ( ["127.0.0.1 localhost hostname hostname.domain localhost.localdomain"] - , ["127.0.0.1 localhost localhost.localdomain hostname hostname.domain"] + , ["127.0.0.1 hostname.domain hostname localhost localhost.localdomain"] ) ; ( ["192.168.0.1 some_host"] - , ["127.0.0.1 hostname hostname.domain"; "192.168.0.1 some_host"] + , ["127.0.0.1 hostname.domain hostname"; "192.168.0.1 some_host"] ) - ; ([], ["127.0.0.1 hostname hostname.domain"]) + ; ([], ["127.0.0.1 hostname.domain hostname"]) ] in matrix |> List.map @@ fun (inp, exp) -> ("", `Quick, check inp exp) @@ -549,18 +570,18 @@ let test_add_ipv4_and_ipv6_localhost_to_hosts = [ ( ["127.0.0.1 localhost"] , [ - "::1 hostname hostname.domain" - ; "127.0.0.1 localhost hostname hostname.domain" + "::1 hostname.domain hostname" + ; "127.0.0.1 hostname.domain hostname localhost" ] ) ; ( ["127.0.0.1 localhost"; "::1 localhost"] , [ - "127.0.0.1 localhost hostname hostname.domain" - ; "::1 localhost hostname hostname.domain" + "127.0.0.1 hostname.domain hostname localhost" + ; "::1 hostname.domain hostname localhost" ] ) ; ( [] - , ["127.0.0.1 hostname hostname.domain"; "::1 hostname hostname.domain"] + , ["127.0.0.1 hostname.domain hostname"; "::1 hostname.domain hostname"] ) ] in diff --git a/ocaml/tests/test_ha_vm_failover.ml b/ocaml/tests/test_ha_vm_failover.ml index fe915563e1..7fa1c62ceb 100644 --- a/ocaml/tests/test_ha_vm_failover.ml +++ b/ocaml/tests/test_ha_vm_failover.ml @@ -250,7 +250,7 @@ let setup ~__context {master; slaves; ha_host_failures_to_tolerate; cluster} = let host = List.nth (Db.Host.get_all ~__context) i in Test_common.make_cluster_host ~__context ~host () |> ignore done ; - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Db.Pool.set_master ~__context ~self:pool ~value:master_ref ; Db.Pool.set_ha_enabled ~__context ~self:pool ~value:true ; Db.Pool.set_ha_host_failures_to_tolerate ~__context ~self:pool diff --git a/ocaml/tests/test_helpers.ml b/ocaml/tests/test_helpers.ml index b856bb363e..678c6444a0 100644 --- a/ocaml/tests/test_helpers.ml +++ b/ocaml/tests/test_helpers.ml @@ -466,6 +466,146 @@ module RunInParallel = Generic.MakeStateless (struct ] end) +module Version = struct + let test_compare_int_list () = + let test_cases = + [ + ("Equal Lists", [1; 2; 3], [1; 2; 3], 0) + ; ("Empty Lists", [], [], 0) + ; ("'a' is smaller (first element)", [1; 10; 100], [2; 0; 0], -1) + ; ("'a' is smaller (later element)", [1; 2; 3], [1; 2; 4], -1) + ; ("'a' is greater (first element)", [5; 1; 1], [2; 10; 10], 1) + ; ("'a' is greater (later element)", [1; 3; 3], [1; 2; 4], 1) + ; ("Lists with negative numbers", [0; -5; 10], [0; -2; -10], -1) + ; ("Single element lists (equal)", [42], [42], 0) + ; ("Single element lists (unequal)", [42], [43], -1) + ; ("Different number of element in lists", [25; 27], [25; 27; 1], -1) + ] + in + let test_compare (description, list1, list2, expected) = + let actual = Helpers.compare_int_lists list1 list2 in + let description = Printf.sprintf "compate_int_lists: %s" description in + Alcotest.(check int) description expected actual + in + List.iter test_compare test_cases + + let test_version_numbers_of_string () = + let test_cases = + [ + ( "Standard major.minor.patch version, e.g. xapi build version stored \ + in the database" + , "25.30.0" + , [25; 30; 0] + ) + ; ( "Dev build version, e.g. xapi build version stored in the database" + , "25.30.0.6.gb239bd75a" + , [25; 30; 0; 6] + ) + ; ( "Version with a patch identifier e.g. xen versions stored in the \ + database" + , "25.15.0-13" + , [25; 15; 0; 13] + ) + ; ("Default version", "0.0.0", [0; 0; 0]) + ; ("Xen Debug build version", "4.17.5-20-d", [4; 17; 5; 20]) + ; ("Xen dev build version", "4.17.5-20.abcd", [4; 17; 5; 20]) + ] + in + let test_version_numbers (description, version_string, expected) = + let actual = Helpers.Checks.version_numbers_of_string version_string in + let description = + Printf.sprintf "version_numbers_of_string: %s" description + in + Alcotest.(check @@ list int) description expected actual + in + List.iter test_version_numbers test_cases + + let test_compare_versions () = + let sw_vers_a = + Xapi_globs.[(_platform_version, "2.4.0"); (_xen_version, "4.14.0-13")] + in + let sw_vers_b = Xapi_globs.[(_xen_version, "4.13.0-13")] in + let test_cases = + Xapi_globs. + [ + ( "Software versions 'b' are missing platform version" + , _platform_version + , sw_vers_a + , sw_vers_b + , 1 + ) + ; ( "Software versions 'a' are missing platform version" + , _platform_version + , sw_vers_b + , sw_vers_a + , -1 + ) + ; ( "xen version exists in both (`a` is greater)" + , _xen_version + , sw_vers_a + , sw_vers_b + , 1 + ) + ; ( "xapi build version is missing from both (equal)" + , _xapi_build_version + , sw_vers_a + , sw_vers_b + , 0 + ) + ] + in + let test_compare (description, key, value_a, value_b, expected) = + let actual = + Helpers.Checks.compare_versions ~version_key:key value_a value_b + in + let description = Printf.sprintf "compare_versions: %s" description in + Alcotest.(check int) description expected actual + in + List.iter test_compare test_cases + + let test_compare_all_versions_migration () = + let current = + Xapi_globs.[(_platform_version, "8.1.0"); (_xen_version, "4.13.0-15")] + in + let newer = + Xapi_globs.[(_platform_version, "8.2.0"); (_xen_version, "4.13.0-15")] + in + let mixed = + Xapi_globs.[(_platform_version, "8.2.0"); (_xen_version, "4.12.0-15")] + in + let test_cases = + [ + ("Newer is greater or equal than Current", newer, current, true) + ; ("Current is greater or equal than Current", current, current, true) + ; ("Current is not greater or equal than Newer", current, newer, false) + ; ("Mixed is not greater or equal then Current", mixed, current, false) + ; ("Current is not greater or equal than Mixed", current, mixed, false) + ] + in + let test_compare (description, vers_a, vers_b, expected) = + let actual = + Helpers.Checks.Migration.compare_all_versions + ~is_greater_or_equal:vers_a ~than:vers_b + in + let description = Printf.sprintf "compare_all_versions: %s" description in + Alcotest.(check bool) description expected actual + in + List.iter test_compare test_cases + + let test = + [ + ("Compare int list", `Quick, test_compare_int_list) + ; ("Version numbers from string", `Quick, test_version_numbers_of_string) + ; ("Compare versions", `Quick, test_compare_versions) + ; ( "Compare all versions for migration" + , `Quick + , test_compare_all_versions_migration + ) + ] + + let tests = [("Version compare tests", test)] +end + let tests = make_suite "helpers_" [ @@ -476,3 +616,4 @@ let tests = ; ("assert_is_valid_cidr", CIDRCheckers.tests) ; ("run_in_parallel", RunInParallel.tests) ] + @ Version.tests diff --git a/ocaml/tests/test_host.ml b/ocaml/tests/test_host.ml index edca58ac03..beb5588e66 100644 --- a/ocaml/tests/test_host.ml +++ b/ocaml/tests/test_host.ml @@ -24,13 +24,16 @@ let add_host __context name = ~license_params:[] ~edition:"" ~license_server:[] ~local_cache_sr:Ref.null ~chipset_info:[] ~ssl_legacy:false ~last_software_update:Clock.Date.epoch ~last_update_hash:"" + ~ssh_enabled:true ~ssh_enabled_timeout:0L ~ssh_expiry:Clock.Date.epoch + ~console_idle_timeout:0L ~ssh_auto_mode:false ~secure_boot:false + ~software_version:(Xapi_globs.software_version ()) ) (* Creates an unlicensed pool with the maximum number of hosts *) let setup_test () = (* Create an unlicensed pool *) let __context = make_test_database () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Db.Pool.set_restrictions ~__context ~self:pool ~value:(Features.to_assoc_list []) ; (* Add hosts until we're at the maximum unlicensed pool size *) @@ -55,7 +58,7 @@ let test_host_join_restriction () = ) (fun () -> ignore (add_host __context "badhost")) ; (* License the pool *) - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Db.Pool.set_restrictions ~__context ~self:pool ~value:(Features.to_assoc_list [Features.Pool_size]) ; (* Adding hosts should now work *) diff --git a/ocaml/tests/test_host_driver_helpers.ml b/ocaml/tests/test_host_driver_helpers.ml deleted file mode 100644 index bb1a49050b..0000000000 --- a/ocaml/tests/test_host_driver_helpers.ml +++ /dev/null @@ -1,89 +0,0 @@ -(* - 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. - *) - -open Xapi_host_driver_helpers - -let note = - Alcotest.testable - (Fmt.of_to_string (fun n -> - Printf.sprintf "{typ=%d; name=%s; desc=%s}" (Int32.to_int n.typ) n.name - n.desc - ) - ) - ( = ) - -let versions = - [ - (".note.XenServer", Some "v2.1.3+0.1fix") - ; (".note.XenServerTwo", Some "2.0.0-rc.2") - ; (".note.Linux", None) - ; (".note.gnu.build-id", None) - ] - -let get_version_test = - List.map - (fun (filename, expected) -> - let test_version () = - let parsed_ver = Result.to_option (get_version filename) in - Printf.printf "%s\n" filename ; - Alcotest.(check (option string)) - "ELF notes should be parsed properly" expected parsed_ver - in - ( Printf.sprintf {|Validation of ELF note parsing: "%s"|} filename - , `Quick - , test_version - ) - ) - versions - -let notes = - [ - (".note.XenServer", [{typ= 1l; name= "XenServer"; desc= "v2.1.3+0.1fix"}]) - ; ( ".note.XenServerTwo" - , [ - {typ= 2l; name= "XenServer"; desc= "Built on December 25th"} - ; {typ= 1l; name= "XenServer"; desc= "2.0.0-rc.2"} - ] - ) - ; (".note.Linux", [{typ= 599l; name= "Linux"; desc= "4.19.0+1"}]) - ; ( ".note.gnu.build-id" - , [{typ= 1l; name= "gnu.build-id"; desc= "\x00\x00\x00"}] - ) - ] - -let note_parsing_test = - List.map - (fun (filename, expected) -> - let test_note () = - let parsed = - match get_notes filename with Ok res -> res | Error e -> failwith e - in - Printf.printf "%s\n" filename ; - Alcotest.(check (list note)) - "ELF notes should be parsed properly" expected parsed - in - ( Printf.sprintf {|Validation of ELF note parsing: "%s"|} filename - , `Quick - , test_note - ) - ) - notes - -let () = - Suite_init.harness_init () ; - Alcotest.run "Test Host Driver Helpers suite" - [ - ("Test_host_driver_helpers.get_note", note_parsing_test) - ; ("Test_host_driver_helpers.get_version", get_version_test) - ] diff --git a/ocaml/tests/test_host_helpers.ml b/ocaml/tests/test_host_helpers.ml index d8ea5a25d0..1b782c5a4d 100644 --- a/ocaml/tests/test_host_helpers.ml +++ b/ocaml/tests/test_host_helpers.ml @@ -149,7 +149,7 @@ let test_rpu_suppression () = let __context, calls, host1, host2, watcher, token = setup_test_oc_watcher () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Db.Pool.add_to_other_config ~__context ~self:pool ~key:Xapi_globs.rolling_upgrade_in_progress ~value:"true" ; Db.Host.set_multipathing ~__context ~self:host1 ~value:false ; diff --git a/ocaml/tests/test_observer.ml b/ocaml/tests/test_observer.ml index 2e2f8e6aa2..07e026e1ac 100644 --- a/ocaml/tests/test_observer.ml +++ b/ocaml/tests/test_observer.ml @@ -98,6 +98,7 @@ module TracerProvider = struct ; "xs.host.name" ; "xs.host.uuid" ; "xs.observer.name" + ; "xs.observer.uuid" ; "service.name" ] @@ -301,10 +302,12 @@ let verify_json_fields_and_values ~json = , `Assoc [ ("xs.pool.uuid", `String _) + ; ("xs.observer.uuid", `String _) ; ("xs.observer.name", `String "test-observer") ; ("xs.host.uuid", `String _) ; ("xs.host.name", `String _) ; ("service.name", `String _) + ; ("span.depth", `String _) ] ) ; ("annotations", `List _) diff --git a/ocaml/tests/test_platformdata.ml b/ocaml/tests/test_platformdata.ml index 36611a5cd5..f5d591a750 100644 --- a/ocaml/tests/test_platformdata.ml +++ b/ocaml/tests/test_platformdata.ml @@ -97,7 +97,7 @@ module Licensing = struct let test_nested_virt_licensing (platform, should_raise) () = let __context = Test_common.make_test_database () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let test_checks = if should_raise then Alcotest.check_raises diff --git a/ocaml/tests/test_repository_helpers.ml b/ocaml/tests/test_repository_helpers.ml index c05e7c8a63..d6c8421afd 100644 --- a/ocaml/tests/test_repository_helpers.ml +++ b/ocaml/tests/test_repository_helpers.ml @@ -253,6 +253,46 @@ module AssertUrlIsValid = Generic.MakeStateless (struct ] end) +module AssertUrlIsNotBlocked = Generic.MakeStateless (struct + module Io = struct + type input_t = string * string list + + type output_t = (unit, exn) result + + let string_of_input_t = Fmt.(str "%a" Dump.(pair string (list string))) + + let string_of_output_t = + Fmt.(str "%a" Dump.(result ~ok:(any "()") ~error:exn)) + end + + let transform (url, url_blocklist) = + Xapi_globs.repository_url_blocklist := url_blocklist ; + try Ok (assert_url_is_not_blocked ~url) with e -> Error e + + let tests = + `QuickAndAutoDocumented + [ + (* no blocklist *) + (("https://test.com", []), Ok ()) + ; (* Not match in blocklist *) + ( ("https://test.com", ["http://blocked.com"; "http://also/blocked.com"]) + , Ok () + ) + ; (* match in blocklist *) + ( ( "http://blocked.com" + , ["http://blocked.com"; "http://also/blocked.com"] + ) + , Error + Api_errors.(Server_error (blocked_repo_url, ["http://blocked.com"])) + ) + ; (* match keyword in blocklist *) + ( ("http://blocked.com", ["private"; "blocked"]) + , Error + Api_errors.(Server_error (blocked_repo_url, ["http://blocked.com"])) + ) + ] +end) + module WriteYumConfig = Generic.MakeStateless (struct module Io = struct (* ( (source_url, binary_url), (need_gpg_check, gpgkey_path) ) *) @@ -4780,6 +4820,7 @@ let tests = [ ("update_of_json", UpdateOfJsonTest.tests) ; ("assert_url_is_valid", AssertUrlIsValid.tests) + ; ("assert_url_is_not_blocked", AssertUrlIsNotBlocked.tests) ; ("write_yum_config", WriteYumConfig.tests) ; ("eval_guidance_for_one_update", EvalGuidanceForOneUpdate.tests) ; ("get_update_in_json", GetUpdateInJson.tests) diff --git a/ocaml/tests/test_tracked_user_agents.ml b/ocaml/tests/test_tracked_user_agents.ml new file mode 100644 index 0000000000..96d0b9450c --- /dev/null +++ b/ocaml/tests/test_tracked_user_agents.ml @@ -0,0 +1,102 @@ +(* + * 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. + *) + +let make_ctx ~user_agent ~client_ip = + let open Context in + let additional_headers = + client_ip + |> Option.fold ~none:[] ~some:(fun x -> + [("STUNNEL_PROXY", Printf.sprintf "TCP6 %s another_ip 443 80" x)] + ) + in + let rq = {Http.Request.empty with user_agent; additional_headers} in + (* it doesn't matter which fd is used to here, we are just satisying the + type system. we use stderr because then we don't need to worry about + closing it *) + make ~origin:(Http (rq, Unix.stderr)) "text_ctx" + +let test_tracked_user_agents ~agents ~expected () = + Xapi_tracked_user_agents.reset () ; + List.iter + (fun user_agent -> + let __context = + make_ctx ~user_agent:(Some user_agent) ~client_ip:(Some "1.2.3.4") + in + Xapi_tracked_user_agents.track ~__context + ) + agents ; + let compare ua1 ua2 = String.compare (fst ua1) (fst ua2) in + Alcotest.(check (list (pair string string))) + "new user agents are equal to expected" + (List.sort compare expected) + (Xapi_tracked_user_agents.get () |> List.sort compare) + +let tests = + [ + ( "tracked_user_agents_base" + , [ + ( "test_tracked_user_agents_base" + , `Quick + , test_tracked_user_agents + ~agents:["XenCenter/2025.2.0.8315"] + ~expected:[("XenCenter", "2025.2.0.8315")] + ) + ; ( "test_tracked_user_agents_version_last_seen" + , `Quick + , test_tracked_user_agents + ~agents: + [ + "XenCenter/2025.2.0.8315" + ; "XenAPI/2.15" + ; "Mozilla/5.0 (Windows NT 10.0; Win64; x64)" + ; "XenCenter/2025.2.0.8316" + ] + ~expected: + [ + ("XenCenter", "2025.2.0.8316") + ; ("XenAPI", "2.15") + ; ("Mozilla", "5.0") + ] + ) + ; ( "test_tracked_user_agents_no_version" + , `Quick + , test_tracked_user_agents ~agents:["XenCenter"] + ~expected:[("XenCenter", "")] + ) + ; ( "test_tracked_user_agents_no_slash" + , `Quick + , test_tracked_user_agents + ~agents:["XenCenter 2025.2.0.8315"] + ~expected:[("XenCenter", "")] + ) + ; ( "test_tracked_user_agents_exceeding_maxstrlen" + , `Quick + , test_tracked_user_agents + ~agents: + [ + "XenCenter/2025.2.0.8315.11111111111111111111111111111111111111111" + ] + ~expected:[] + ) + ; ( "test_tracked_user_agents_exceeding_max_num" + , `Quick + , test_tracked_user_agents + ~agents:(List.init 130 (Printf.sprintf "Agent%d/1.0")) + ~expected: + (List.init 128 (fun i -> (Printf.sprintf "Agent%d" (i + 2), "1.0")) + ) + ) + ] + ) + ] diff --git a/ocaml/tests/test_vdi_cbt.ml b/ocaml/tests/test_vdi_cbt.ml index 54ae411ac9..4f86dc737b 100644 --- a/ocaml/tests/test_vdi_cbt.ml +++ b/ocaml/tests/test_vdi_cbt.ml @@ -142,7 +142,7 @@ let test_cbt_enable_disable () = let test_set_metadata_of_pool_doesnt_allow_cbt_metadata_vdi () = let __context = Test_common.make_test_database () in let self = Test_common.make_vdi ~__context ~_type:`cbt_metadata () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Alcotest.check_raises "VDI.set_metadata_of_pool should throw VDI_INCOMPATIBLE_TYPE for a \ cbt_metadata VDI" diff --git a/ocaml/tests/test_xapi_xenops.ml b/ocaml/tests/test_xapi_xenops.ml index 551c7d0d90..e1f1bf048e 100644 --- a/ocaml/tests/test_xapi_xenops.ml +++ b/ocaml/tests/test_xapi_xenops.ml @@ -62,8 +62,8 @@ let test_xapi_restart_inner () = in let flags = [ - (Xapi_globs.cpu_info_vendor_key, "AuthenticAMD") - ; (Xapi_globs.cpu_info_features_key, "deadbeef-deadbeef") + (Constants.cpu_info_vendor_key, "AuthenticAMD") + ; (Constants.cpu_info_features_key, "deadbeef-deadbeef") ] in let add_flags vm = diff --git a/ocaml/tests/test_xenopsd_metadata.ml b/ocaml/tests/test_xenopsd_metadata.ml index c052de228f..14362e73b6 100644 --- a/ocaml/tests/test_xenopsd_metadata.ml +++ b/ocaml/tests/test_xenopsd_metadata.ml @@ -38,8 +38,8 @@ let load_vm_config __context conf = in let flags = [ - (Xapi_globs.cpu_info_vendor_key, "AuthenticAMD") - ; (Xapi_globs.cpu_info_features_key, "deadbeef-deadbeef") + (Constants.cpu_info_vendor_key, "AuthenticAMD") + ; (Constants.cpu_info_features_key, "deadbeef-deadbeef") ] in Db.VM.set_last_boot_CPU_flags ~__context ~self ~value:flags ; diff --git a/ocaml/util/dune b/ocaml/util/dune index 488cf4f444..5d015689f9 100644 --- a/ocaml/util/dune +++ b/ocaml/util/dune @@ -9,17 +9,10 @@ ; avoid rebuilding everything when the implementation (of e.g. date) changes ; accessing version information is not performance critical: ; we don't want it inlined - (flags (:standard -opaque)) + (flags (:standard -opaque -w -58)) (libraries dune-build-info xapi-inventory ) (wrapped false) ) - -(library - (name xapi_host_driver_helpers) - (modules xapi_host_driver_helpers) - (libraries yojson angstrom xapi-stdext-unix) - (wrapped false) -) diff --git a/ocaml/util/xapi_host_driver_helpers.ml b/ocaml/util/xapi_host_driver_helpers.ml deleted file mode 100644 index 4910ed8d11..0000000000 --- a/ocaml/util/xapi_host_driver_helpers.ml +++ /dev/null @@ -1,131 +0,0 @@ -(* - 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 J = Yojson -open Angstrom - -let int n = Int32.to_int n - -let ( // ) = Filename.concat - -(** Read a (small) file into a string *) -let read path = Xapi_stdext_unix.Unixext.string_of_file path - -type note = {typ: int32; name: string; desc: string} - -module JSON = struct - let note l = - let l = - List.map - (fun d -> - `Assoc - [ - ("type", `Int (int d.typ)) - ; ("name", `String d.name) - ; ("desc", `String d.desc) - ] - ) - l - in - `List l - - let emit json = J.pretty_to_channel stdout json -end - -(** return the smallest k >= n such that k is divisible by 4 *) -let align4 n = - let ( & ) = Int.logand in - n + (-n & 3) - -(** advance the cursor to position n *) -let advance_to n = - let* pos in - advance (max 0 (n - pos)) - -(** align the cursor to a multiple of 4 *) -let align = - let* pos in - advance_to (align4 pos) - -(** parse an ELF note entry; it assumes that name and desc are null - terminated strings. This should be always true for name but desc - depends on the entry. We don't capture the terminating zero for - strings. *) -let note = - let* name_length = LE.any_int32 in - let* desc_length = LE.any_int32 in - let* typ = LE.any_int32 in - let* name = take (int name_length - 1) in - (* skip over terminating null and re-align cursor *) - let* _ = char '\000' in - let* () = align in - let* desc = take (int desc_length - 1) in - (* skip over terminating null and re-align cursor *) - let* _ = char '\000' in - let* () = align in - return {typ; name; desc} - -(** parser for a sequence of note entries *) -let notes = many note - -(** parse a sequence of note entries from a string *) -let parse str = - let consume = Consume.Prefix in - parse_string ~consume notes str - -let get_version path = - let version = - read path - |> parse - |> Result.map - @@ List.filter_map (fun note -> - match (note.typ, note.name) with - | 1l, "XenServer" -> - Some note.desc - | _ -> - None - ) - in - match version with - | Ok (v :: _) -> - Ok v - | _ -> - Error - (Format.sprintf - "Failed to parse %s, didn't find a XenServer driver version notes \ - section" - path - ) - -let get_notes path = - let version = read path |> parse in - match version with - | Ok (_ :: _) as v -> - v - | _ -> - Error - (Format.sprintf "Failed to parse %s, didn't find a notes section" path) - -let dump_notes prefix = - let notes_dir = prefix // "notes" in - try - let lst = - Sys.readdir notes_dir - |> Array.to_list - |> List.map (fun n -> read (notes_dir // n)) - |> List.filter_map (fun note_str -> Result.to_option (parse note_str)) - |> List.map (fun note -> (prefix, JSON.note note)) - in - JSON.emit (`Assoc lst) - with _ -> () diff --git a/ocaml/util/xapi_host_driver_helpers.mli b/ocaml/util/xapi_host_driver_helpers.mli deleted file mode 100644 index 6528d6bec9..0000000000 --- a/ocaml/util/xapi_host_driver_helpers.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* - 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. - *) - -type note = {typ: int32; name: string; desc: string} - -(* Parse an ELF notes section, returning the specially-encoded driver version. - - The kernel does not reveal the location from where it loaded an active - driver. Hence the name is not sufficient to observe the currently active - version. For this, XS uses ELF notes, with the kernel presenting a particular - note section in `/sys/module//notes/.note.XenServer` *) -val get_version : string -> (string, string) result - -val get_notes : string -> (note list, string) result - -(* Dumps JSON-formatted parsed ELF notes of a driver *) -val dump_notes : string -> unit diff --git a/ocaml/vhd-tool/cli/dune b/ocaml/vhd-tool/cli/dune index 5dea7468c1..095b9edaf9 100644 --- a/ocaml/vhd-tool/cli/dune +++ b/ocaml/vhd-tool/cli/dune @@ -13,6 +13,7 @@ ssl tapctl threads.posix + unix uri vhd-format vhd-format-lwt diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 7aa9d0de70..9092e4e03e 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -25,6 +25,7 @@ sha ssl tar + unix uri uuidm vhd-format diff --git a/ocaml/vncproxy/dune b/ocaml/vncproxy/dune index 97b8962833..53316e7831 100644 --- a/ocaml/vncproxy/dune +++ b/ocaml/vncproxy/dune @@ -7,6 +7,7 @@ http_lib stunnel + unix xapi-client xapi-consts xapi-types diff --git a/ocaml/wsproxy/cli/dune b/ocaml/wsproxy/cli/dune index 4d6e72bfe7..5946052b1a 100644 --- a/ocaml/wsproxy/cli/dune +++ b/ocaml/wsproxy/cli/dune @@ -14,6 +14,7 @@ lwt lwt.unix re + unix uuid wslib ) diff --git a/ocaml/wsproxy/src/dune b/ocaml/wsproxy/src/dune index 8513c2998c..69ac8801a2 100644 --- a/ocaml/wsproxy/src/dune +++ b/ocaml/wsproxy/src/dune @@ -1,5 +1,5 @@ (library (name wslib) (modes best) - (libraries base64 lwt lwt.unix) + (libraries base64 lwt lwt.unix unix) ) diff --git a/ocaml/xapi-aux/dune b/ocaml/xapi-aux/dune index 60e27cf5b3..8eebb6edc4 100644 --- a/ocaml/xapi-aux/dune +++ b/ocaml/xapi-aux/dune @@ -11,6 +11,7 @@ ipaddr.unix tar threads.posix + unix xapi-consts xapi-idl.network xapi-inventory diff --git a/ocaml/xapi-aux/kerberos_encryption_types.ml b/ocaml/xapi-aux/kerberos_encryption_types.ml index 8bb6300467..d88c0905b7 100644 --- a/ocaml/xapi-aux/kerberos_encryption_types.ml +++ b/ocaml/xapi-aux/kerberos_encryption_types.ml @@ -15,18 +15,18 @@ (* Kerberos support several different encrytion types * winbind support it as strong, legacy and all * details, https://www.samba.org/samba/docs/current/man-html/smb.conf.5.html - * *) + *) module Winbind = struct type t = Strong | Legacy | All (* - * [X] 0x00000001 DES-CBC-CRC - * [X] 0x00000002 DES-CBC-MD5 - * [X] 0x00000004 RC4-HMAC - * [X] 0x00000008 AES128-CTS-HMAC-SHA1-96 - * [X] 0x00000010 AES256-CTS-HMAC-SHA1-96 - * *) + * [X] 0x00000001 DES-CBC-CRC + * [X] 0x00000002 DES-CBC-MD5 + * [X] 0x00000004 RC4-HMAC + * [X] 0x00000008 AES128-CTS-HMAC-SHA1-96 + * [X] 0x00000010 AES256-CTS-HMAC-SHA1-96 + *) let des_cbc_crc = 0x1 diff --git a/ocaml/xapi-aux/networking_info.ml b/ocaml/xapi-aux/networking_info.ml index 52de3fb12f..928ad45322 100644 --- a/ocaml/xapi-aux/networking_info.ml +++ b/ocaml/xapi-aux/networking_info.ml @@ -55,11 +55,11 @@ let dns_names () = ) |> Astring.String.uniquify -let ipaddr_to_cstruct = function +let ipaddr_to_octets = function | Ipaddr.V4 addr -> - Cstruct.of_string (Ipaddr.V4.to_octets addr) + Ipaddr.V4.to_octets addr | Ipaddr.V6 addr -> - Cstruct.of_string (Ipaddr.V6.to_octets addr) + Ipaddr.V6.to_octets addr let get_management_ip_addrs ~dbg = let iface = Inventory.lookup Inventory._management_interface in @@ -99,8 +99,7 @@ let get_management_ip_addrs ~dbg = let get_management_ip_addr ~dbg = match get_management_ip_addrs ~dbg with | Ok (preferred, _) -> - List.nth_opt preferred 0 - |> Option.map (fun addr -> (Ipaddr.to_string addr, ipaddr_to_cstruct addr)) + List.nth_opt preferred 0 |> Option.map Ipaddr.to_string | Error _ -> None @@ -113,7 +112,7 @@ let get_host_certificate_subjects ~dbg = | Ok (preferred, others) -> let ips = List.(rev_append (rev preferred) others) in Option.fold ~none:(Error IP_missing) - ~some:(fun ip -> Ok (List.map ipaddr_to_cstruct ips, ip)) + ~some:(fun ip -> Ok (List.map ipaddr_to_octets ips, ip)) (List.nth_opt ips 0) in let dns_names = dns_names () in diff --git a/ocaml/xapi-aux/networking_info.mli b/ocaml/xapi-aux/networking_info.mli index ced93d30dd..4c8418443a 100644 --- a/ocaml/xapi-aux/networking_info.mli +++ b/ocaml/xapi-aux/networking_info.mli @@ -24,13 +24,12 @@ val management_ip_error_to_string : management_ip_error -> string (** [management_ip_error err] returns a string representation of [err], useful only for logging. *) -val get_management_ip_addr : dbg:string -> (string * Cstruct.t) option +val get_management_ip_addr : dbg:string -> string option (** [get_management_ip_addr ~dbg] returns the preferred IP of the management - network, or None. The address is returned in two formats: a human-readable - string and its bytes representation. *) + network, or None. The address is returned in a human-readable string *) val get_host_certificate_subjects : dbg:string - -> (string * string list * Cstruct.t list, management_ip_error) Result.t + -> (string * string list * string list, management_ip_error) Result.t (** [get_host_certificate_subjects ~dbg] returns the main, dns names and ip addresses that identify the host in secure connections. *) diff --git a/ocaml/xapi-cli-protocol/dune b/ocaml/xapi-cli-protocol/dune index 72cc617c98..b6fab5f447 100644 --- a/ocaml/xapi-cli-protocol/dune +++ b/ocaml/xapi-cli-protocol/dune @@ -3,6 +3,7 @@ (public_name xapi-cli-protocol) (libraries threads + unix xapi-stdext-unix ) (wrapped false) diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 389b880a26..39e0c8ce51 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -101,6 +101,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; "sr-uuid" ; "network-uuid" ; "pool-uuid" + ; "public" ] ; help= "Create a binary blob to be associated with an API object" ; implementation= No_fd Cli_operations.blob_create @@ -127,14 +128,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) - ; (* "host-introduce", - { - reqd=["name"; "address"; "remote-port"; "remote-username"; "remote-password"]; - optn=["description"]; - help="Introduce a remote host"; - implementation=No_fd Cli_operations.host_introduce - };*) - ( "pool-enable-binary-storage" + ; ( "pool-enable-binary-storage" , { reqd= [] ; optn= [] @@ -535,6 +529,18 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "pool-get-cpu-features" + , { + reqd= [] + ; optn= [] + ; help= + {|Prints a hexadecimal representation of the pool's physical-CPU + features for PV and HVM VMs. These are combinations of all the + hosts' policies and are used when starting new VMs in a pool.|} + ; implementation= No_fd Cli_operations.pool_get_cpu_features + ; flags= [] + } + ) ; ( "host-is-in-emergency-mode" , { reqd= [] @@ -573,8 +579,10 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "host-disable" , { reqd= [] - ; optn= [] - ; help= "Disable the XE host." + ; optn= ["auto-enable"] + ; help= + "Disable the XE host. Setting auto-enable=false will keep the host \ + persistently disabled until manually re-enabled with Host.enable." ; implementation= No_fd Cli_operations.host_disable ; flags= [Host_selectors] } @@ -816,7 +824,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "host-emergency-ha-disable" , { reqd= [] - ; optn= ["force"] + ; optn= ["force"; "soft"] ; help= "Disable HA on the local host. Only to be used to recover a pool \ with a broken HA setup." @@ -958,8 +966,9 @@ let rec cmdtable_data : (string * cmd_spec) list = ; optn= ["args:"] ; help= "Calls the function within the plugin on the given host with \ - optional arguments." - ; implementation= No_fd Cli_operations.host_call_plugin + optional arguments. The syntax args:key:file=/path/file.ext passes \ + the content of /path/file.ext under key to the plugin." + ; implementation= With_fd Cli_operations.host_call_plugin ; flags= [] } ) @@ -1017,8 +1026,10 @@ let rec cmdtable_data : (string * cmd_spec) list = reqd= [] ; optn= ["uuid"] ; help= - "Prints a hexadecimal representation of the host's physical-CPU \ - features." + {|Prints a hexadecimal representation of the host's physical-CPU + features for PV and HVM VMs. features_{hvm,pv} are "maximum" + featuresets the host will accept during migrations, and + features_{hvm,pv}_host will be used to start new VMs.|} ; implementation= No_fd Cli_operations.host_get_cpu_features ; flags= [] } @@ -1775,6 +1786,8 @@ let rec cmdtable_data : (string * cmd_spec) list = ; "host-password" ; "type" ; "remote-config" + ; "dry-run" + ; "metadata" ; "url" ; "vdi:" ] @@ -1788,7 +1801,8 @@ let rec cmdtable_data : (string * cmd_spec) list = VDIs will be imported into the Pool's default SR unless an override \ is provided. If the force option is given then any disk data \ checksum failures will be ignored. If the parameter 'url' is \ - specified, xapi will attempt to import from that URL." + specified, xapi will attempt to import from that URL. Only metadata \ + will be imported if 'metadata' is true" ; implementation= With_fd Cli_operations.vm_import ; flags= [Standard] } @@ -1802,6 +1816,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; "compress" ; "metadata" ; "excluded-device-types" + ; "include-snapshots" ] ; help= "Export a VM to ." ; implementation= With_fd Cli_operations.vm_export @@ -1841,6 +1856,21 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "vm-call-host-plugin" + , { + reqd= ["vm-uuid"; "plugin"; "fn"] + ; optn= ["args:"] + ; help= + "Calls function fn within the plugin on the host where the VM is \ + running with arguments (args:key=value). To pass a \"value\" string \ + with special characters in it (e.g. new line), an alternative \ + syntax args:key:file=local_file can be used in place, where the \ + content of local_file will be retrieved and assigned to \"key\" as \ + a whole." + ; implementation= With_fd Cli_operations.vm_call_host_plugin + ; flags= [] + } + ) ; ( "snapshot-export-to-template" , { reqd= ["filename"; "snapshot-uuid"] @@ -2114,7 +2144,7 @@ let rec cmdtable_data : (string * cmd_spec) list = "Create a VBD. Appropriate values for the device field are listed in \ the parameter 'allowed-VBD-devices' on the VM. If no VDI is \ specified, an empty VBD will be created. The type parameter can be \ - 'Disk' or 'CD', and the mode is 'RO' or 'RW'." + 'Disk', 'CD' or 'Floppy', and the mode is 'RO' or 'RW'." ; implementation= No_fd Cli_operations.vbd_create ; flags= [] } @@ -2377,6 +2407,7 @@ let rec cmdtable_data : (string * cmd_spec) list = "name-description" ; "sharable" ; "read-only" + ; "managed" ; "other-config:" ; "xenstore-data:" ; "sm-config:" @@ -2735,6 +2766,15 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "vm-sysprep" + , { + reqd= ["filename"] + ; optn= ["timeout"] + ; help= "Pass and execute sysprep configuration file" + ; implementation= With_fd Cli_operations.vm_sysprep + ; flags= [Vm_selectors] + } + ) ; ( "diagnostic-vm-status" , { reqd= ["uuid"] @@ -2746,17 +2786,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [Standard] } ) - ; (* - "diagnostic-event-deltas", - { - reqd=["class"]; - optn=[]; - help="Print the changes that are happening to all objects of class specified."; - implementation=With_fd Cli_operations.diagnostic_event_deltas; - flags=[]; - }; -*) - ( "diagnostic-license-status" + ; ( "diagnostic-license-status" , { reqd= [] ; optn= [] @@ -2865,7 +2895,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "host-evacuate" , { reqd= [] - ; optn= ["network-uuid"] + ; optn= ["network-uuid"; "batch-size"] ; help= "Migrate all VMs off a host." ; implementation= No_fd Cli_operations.host_evacuate ; flags= [Host_selectors] @@ -2892,6 +2922,19 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [Neverforward] } ) + ; ( "host-update-firewalld-service-status" + , { + reqd= [] + ; optn= [] + ; help= + "Update firewalld services status based the corresponding xapi \ + services status." + ; implementation= + No_fd_local_session + Cli_operations.host_update_firewalld_service_status + ; flags= [Neverforward] + } + ) ; ( "diagnostic-compact" , { reqd= [] @@ -2976,35 +3019,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) - ; (* - "alert-create", - { - reqd=["message"]; - optn=["alert-level"]; - help="Create a new alert."; - implementation=No_fd Cli_operations.alert_create; - flags=[]; - }; - "alert-destroy", - { - reqd=["uuid"]; - optn=[]; - help="Destroy an Alert."; - implementation=No_fd Cli_operations.alert_destroy; - flags=[]; - }; -*) - (* - "host-fence", - { - reqd=["host-uuid"]; - optn=[]; - help="Fence a host"; - implementation=No_fd_local_session Cli_operations.host_fence; - flags=[]; - }; -*) - ( "pool-vlan-create" + ; ( "pool-vlan-create" , { reqd= ["pif-uuid"; "vlan"; "network-uuid"] ; optn= [] @@ -3165,28 +3180,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [Hidden; Neverforward] } ) - ; (* - "host-ha-query", - { - reqd=[]; - optn=[]; - help="Query the HA configuration of the local host."; - implementation=No_fd_local_session Cli_operations.host_ha_query; - flags=[Neverforward]; - }; - -*) - (* - "subject-list", - { - reqd=[]; - optn=[]; - help="Returns a list of subject names that can access the pool"; - implementation=No_fd Cli_operations.subject_list; - flags=[] - }; -*) - ( "subject-add" + ; ( "subject-add" , { reqd= ["subject-name"] ; optn= [] @@ -3232,17 +3226,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) - ; (* RBAC 2.0 only - "role-create", - { - reqd=["id";"name"]; - optn=[]; - help="Add a role to the pool"; - implementation=No_fd Cli_operations.role_create; - flags=[] - }; - *) - ( "session-subject-identifier-list" + ; ( "session-subject-identifier-list" , { reqd= [] ; optn= [] @@ -3815,7 +3799,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "vtpm-create" , { reqd= ["vm-uuid"] - ; optn= [] + ; optn= ["is-unique"] ; help= "Create a VTPM associated with a VM." ; implementation= No_fd Cli_operations.VTPM.create ; flags= [] @@ -4078,6 +4062,26 @@ let rio_help printer minimal cmd = let cmds = List.sort (fun (name1, _) (name2, _) -> compare name1 name2) cmds in + let help = + Printf.sprintf + {|Usage: + %s + [ -s ] XenServer host + [ -p ] XenServer port number + [ -u -pw | -pwf ] + User authentication (password or file) + [ --nossl ] Disable SSL/TLS + [ --debug ] Enable debug output + [ --debug-on-fail ] Enable debug output only on failure + [ --traceparent ] Distributed tracing context + [ ... ] Command-specific options + +To get help on a specific command: + %s help + +|} + cmd.argv0 cmd.argv0 + in if List.mem_assoc "all" cmd.params && List.assoc "all" cmd.params = "true" then let cmds = List.map fst cmds in @@ -4087,20 +4091,9 @@ let rio_help printer minimal cmd = let vm_cmds, other = List.partition (fun n -> Astring.String.is_prefix ~affix:"vm-" n) other in - let h = - "Usage: " - ^ cmd.argv0 - ^ " [-s server] [-pw passwd] [-p port] [-u user] [-pwf \ - password-file]\n" - in - let h = h ^ " [command specific arguments]\n\n" in - let h = - h - ^ "To get help on a specific command: " - ^ cmd.argv0 - ^ " help \n\n" - in - let h = h ^ "Full command list\n-----------------" in + let h = help ^ {|Full command list +----------------- +|} in if minimal then printer (Cli_printer.PList cmds) else ( @@ -4117,25 +4110,16 @@ let rio_help printer minimal cmd = in let cmds = List.map fst cmds in let h = - "Usage: " - ^ cmd.argv0 - ^ " [-s server] [-pw passwd] [-p port] [-u user] [-pwf \ - password-file]\n" - in - let h = h ^ " [command specific arguments]\n\n" in - let h = - h - ^ "To get help on a specific command: " - ^ cmd.argv0 - ^ " help \n" - in - let h = - h - ^ "To get a full listing of commands: " - ^ cmd.argv0 - ^ " help --all\n\n" + help + ^ Printf.sprintf + {|To get a full listing of commands: + %s help --all + +Common command list +------------------- +|} + cmd.argv0 in - let h = h ^ "Common command list\n-------------------" in if minimal then printer (Cli_printer.PList cmds) else ( diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 431cc76fa8..eb6a0eb3a8 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -195,14 +195,15 @@ let get_file_or_fail fd desc filename = | Some chunks -> chunks -let diagnostic_timing_stats printer rpc session_id _params = +let diagnostic_timing_stats printer rpc session_id params = + let counts = get_bool_param params "counts" in let table_of_host host = [ ("host-uuid", Client.Host.get_uuid ~rpc ~session_id ~self:host) ; ("host-name-label", Client.Host.get_name_label ~rpc ~session_id ~self:host) ] @ - try Client.Host.get_diagnostic_timing_stats ~rpc ~session_id ~host + try Client.Host.get_diagnostic_timing_stats ~rpc ~session_id ~host ~counts with e -> [("Error", Api_errors.to_string e)] in let all = List.map table_of_host (Client.Host.get_all ~rpc ~session_id) in @@ -2240,6 +2241,9 @@ let print_assert_exception e = "VM requires access to SR: " ^ Cli_util.ref_convert (get_arg 2 params) | Api_errors.Server_error (code, _) when code = Api_errors.host_disabled -> "Host disabled (use 'xe host-enable' to re-enable)" + | Api_errors.Server_error (code, _) + when code = Api_errors.host_disabled_indefinitely -> + "Host disabled indefinitely (use 'xe host-enable' to re-enable)" | Api_errors.Server_error (code, _) when code = Api_errors.host_not_live -> "Host down" | Api_errors.Server_error (code, _) @@ -3490,31 +3494,44 @@ let vm_memory_target_wait printer rpc session_id params = params [] ) +(** This implements the key:file=/path/to/file.txt syntax. The value for + key is the content of a file requested from the client *) +let args_file fd ((k, v) as p) = + match Astring.String.cut ~sep:":" k with + | Some (key, "file") -> ( + match get_client_file fd v with + | Some s -> + (key, s) + | None -> + marshal fd + (Command (PrintStderr (Printf.sprintf "Failed to read file %s\n" v))) ; + raise (ExitWithError 1) + ) + | _ -> + p + let vm_call_plugin fd printer rpc session_id params = let vm_uuid = List.assoc "vm-uuid" params in let vm = Client.VM.get_by_uuid ~rpc ~session_id ~uuid:vm_uuid in let plugin = List.assoc "plugin" params in let fn = List.assoc "fn" params in let args = read_map_params "args" params in - (* Syntax interpretation: args:key:file=filename equals args:key=filename_content *) - let convert ((k, v) as p) = - match Astring.String.cut ~sep:":" k with - | Some (key, "file") -> ( - match get_client_file fd v with - | Some s -> - (key, s) - | None -> - marshal fd - (Command (PrintStderr (Printf.sprintf "Failed to read file %s\n" v))) ; - raise (ExitWithError 1) - ) - | _ -> - p - in - let args = List.map convert args in + let args = List.map (args_file fd) args in let result = Client.VM.call_plugin ~rpc ~session_id ~vm ~plugin ~fn ~args in printer (Cli_printer.PList [result]) +let vm_call_host_plugin fd printer rpc session_id params = + let vm_uuid = List.assoc "vm-uuid" params in + let vm = Client.VM.get_by_uuid ~rpc ~session_id ~uuid:vm_uuid in + let plugin = List.assoc "plugin" params in + let fn = List.assoc "fn" params in + let args = read_map_params "args" params in + let args = List.map (args_file fd) args in + let result = + Client.VM.call_host_plugin ~rpc ~session_id ~vm ~plugin ~fn ~args + in + printer (Cli_printer.PList [result]) + let data_source_to_kvs ds = [ ("name_label", ds.API.data_source_name_label) @@ -3575,6 +3592,34 @@ let vm_data_source_forget printer rpc session_id params = params ["data-source"] ) +let vm_sysprep fd printer rpc session_id params = + let filename = List.assoc "filename" params in + let timeout = + match List.assoc "timeout" params |> float_of_string with + | exception _ -> + 3.0 *. 60.0 (* default in the CLI, no default in the API *) + | s when s < 0.0 -> + 0.0 + | s -> + s + in + let unattend = + match get_client_file fd filename with + | Some xml -> + xml |> SecretString.of_string + | None -> + marshal fd (Command (PrintStderr "Failed to read file.\n")) ; + raise (ExitWithError 1) + in + ignore + (do_vm_op printer rpc session_id + (fun vm -> + Client.VM.sysprep ~rpc ~session_id ~self:(vm.getref ()) ~unattend + ~timeout + ) + params ["filename"; "timeout"] + ) + (* APIs to collect SR level RRDs *) let sr_data_source_list printer rpc session_id params = ignore @@ -5297,9 +5342,8 @@ let with_license_server_changes printer rpc session_id params hosts f = ) hosts ) ; - let now = Unix.gettimeofday () in try f rpc session_id with - | Api_errors.Server_error (name, _) as e + | Api_errors.Server_error (name, [_; msg]) when name = Api_errors.license_checkout_error -> (* Put back original license_server_details *) List.iter @@ -5308,28 +5352,8 @@ let with_license_server_changes printer rpc session_id params hosts f = ~value:license_server ) current_license_servers ; - let alerts = - Client.Message.get_since ~rpc ~session_id - ~since:(Date.of_unix_time (now -. 1.)) - in - let print_if_checkout_error (ref, msg) = - if - false - || msg.API.message_name = fst Api_messages.v6_rejected - || msg.API.message_name = fst Api_messages.v6_comm_error - || msg.API.message_name - = fst Api_messages.v6_license_server_version_obsolete - then ( - Client.Message.destroy ~rpc ~session_id ~self:ref ; - printer (Cli_printer.PStderr (msg.API.message_body ^ "\n")) - ) - in - if alerts = [] then - raise e - else ( - List.iter print_if_checkout_error alerts ; - raise (ExitWithError 1) - ) + printer (Cli_printer.PStderr (msg ^ "\n")) ; + raise (ExitWithError 1) | Api_errors.Server_error (name, _) as e when name = Api_errors.invalid_edition -> let host = get_host_from_session rpc session_id in @@ -5368,13 +5392,21 @@ let host_evacuate _printer rpc session_id params = Client.Network.get_by_uuid ~rpc ~session_id ~uuid ) in + let evacuate_batch_size = + match List.assoc_opt "batch-size" params with + | Some x -> + Scanf.sscanf x "%Lu%!" Fun.id + | None -> + 0L + in ignore (do_host_op rpc session_id ~multiple:false (fun _ host -> Client.Host.evacuate ~rpc ~session_id ~host:(host.getref ()) ~network - ~evacuate_batch_size:0L + ~evacuate_batch_size ) - params ["network-uuid"] + params + ["network-uuid"; "batch-size"] ) let host_get_vms_which_prevent_evacuation printer rpc session_id params = @@ -5419,6 +5451,9 @@ let host_retrieve_wlb_evacuate_recommendations printer rpc session_id params = let host_shutdown_agent _printer rpc session_id _params = ignore (Client.Host.shutdown_agent ~rpc ~session_id) +let host_update_firewalld_service_status _printer rpc session_id _params = + ignore (Client.Host.update_firewalld_service_status ~rpc ~session_id) + let vdi_import fd _printer rpc session_id params = let filename = List.assoc "filename" params in let vdi = @@ -6537,12 +6572,14 @@ let bond_set_mode _printer rpc session_id params = Client.Bond.set_mode ~rpc ~session_id ~self:bond ~value:mode let host_disable _printer rpc session_id params = + let auto_enable = get_bool_param ~default:true params "auto-enable" in ignore (do_host_op rpc session_id (fun _ host -> Client.Host.disable ~rpc ~session_id ~host:(host.getref ()) + ~auto_enable ) - params [] + params ["auto-enable"] ) let host_sync_data _printer rpc session_id params = @@ -6798,6 +6835,28 @@ let pool_get_guest_secureboot_readiness printer rpc session_id params = (Record_util.pool_guest_secureboot_readiness_to_string result) ) +let cpu_info_features_of feature_keys cpu_info = + let ( let* ) = Option.bind in + List.filter_map + (fun key -> + let* features = List.assoc_opt key cpu_info in + Some (key, features) + ) + feature_keys + +let pool_get_cpu_features printer rpc session_id params = + let pool = get_pool_with_default rpc session_id params "uuid" in + let cpu_info = Client.Pool.get_cpu_info ~rpc ~session_id ~self:pool in + + let feature_keys = + [ + Constants.cpu_info_features_pv_host_key + ; Constants.cpu_info_features_hvm_host_key + ] + in + let features = cpu_info_features_of feature_keys cpu_info in + printer (Cli_printer.PTable [features]) + let pool_sync_bundle fd _printer rpc session_id params = let filename_opt = List.assoc_opt "filename" params in match filename_opt with @@ -6907,12 +6966,13 @@ let host_set_hostname_live _printer rpc session_id params = let hostname = List.assoc "host-name" params in Client.Host.set_hostname_live ~rpc ~session_id ~host ~hostname -let host_call_plugin printer rpc session_id params = +let host_call_plugin fd 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 plugin = List.assoc "plugin" params in let fn = List.assoc "fn" params in let args = read_map_params "args" params in + let args = List.map (args_file fd) args in let result = Client.Host.call_plugin ~rpc ~session_id ~host ~plugin ~fn ~args in @@ -6966,8 +7026,17 @@ let host_get_cpu_features printer rpc session_id params = get_host_from_session rpc session_id in let cpu_info = Client.Host.get_cpu_info ~rpc ~session_id ~self:host in - let features = List.assoc "features" cpu_info in - printer (Cli_printer.PMsg features) + + let feature_keys = + [ + Constants.cpu_info_features_pv_key + ; Constants.cpu_info_features_hvm_key + ; Constants.cpu_info_features_pv_host_key + ; Constants.cpu_info_features_hvm_host_key + ] + in + let features = cpu_info_features_of feature_keys cpu_info in + printer (Cli_printer.PTable [features]) let host_enable_display printer rpc session_id params = let host = @@ -7215,59 +7284,11 @@ let host_send_debug_keys _printer rpc session_id params = let keys = List.assoc "keys" params in Client.Host.send_debug_keys ~rpc ~session_id ~host ~keys -(* - let host_introduce printer rpc session_id params = - let name = List.assoc "name" params in - let descr = if List.mem_assoc "description" params then List.assoc "description" params else "" in - let address = List.assoc "address" params in - let port = List.assoc "remote-port" params in - let remote_username = List.assoc "remote-username" params in - let remote_password = List.assoc "remote-password" params in - ignore(Client.Credential.create_with_password ~rpc ~session_id name descr address (Int64.of_string port) remote_username remote_password) - *) - let task_cancel _printer rpc session_id params = let uuid = List.assoc "uuid" params in let task = Client.Task.get_by_uuid ~rpc ~session_id ~uuid in Client.Task.cancel ~rpc ~session_id ~task -(* - let alert_create printer rpc session_id params = - let string_to_alert_level s = - match s with - | "info" -> `Info - | "warning" | "warn" -> `Warn - | "error" -> `Error - | _ -> `Info - in - let message = List.assoc "message" params in - let level = if List.mem_assoc "level" params then List.assoc "level" params else "info" in - let level = string_to_alert_level level in - let alert = Client.Alert.create ~rpc ~session_id message [] level in - let uuid = Client.Alert.get_uuid ~rpc ~session_id alert in - printer (Cli_printer.PList [uuid]) - - let alert_destroy printer rpc session_id params = - let uuid = List.assoc "uuid" params in - let alert = Client.Alert.get_by_uuid ~rpc ~session_id uuid in - Client.Alert.destroy ~rpc ~session_id alert - *) - -(* - let subject_list printer rpc session_id params = -(* we get all subjects from the pool *) - let subjects = Client.Subject.get_all_records ~rpc ~session_id in - let table_of_subject (subject,record) = - [ "subject-uuid", record.API.subject_uuid; - "subject-identifier", record.API.subject_subject_identifier; -(* "subject-name", Client.Subject.get_subject_name ~rpc ~session_id subject;*) - ] @ - record.API.subject_other_config - in - let all = List.map table_of_subject subjects in - printer (Cli_printer.PTable all) - *) - let subject_add printer rpc session_id params = let subject_name = List.assoc "subject-name" params in (* let's try to resolve the subject_name to a subject_id using the external directory *) @@ -7358,13 +7379,6 @@ let audit_log_get fd _printer rpc session_id params = download_file_with_task fd rpc session_id filename Constants.audit_log_uri query label label -(* RBAC 2.0 only - let role_create printer rpc session_id params = - (*let id = List.assoc "id" params in*) - let name = List.assoc "name" params in - ignore (Client.Role.create ~rpc ~session_id ~name ~description:"" ~permissions:[] ~is_basic:false ~is_complete:false) -*) - let session_subject_identifier_list printer rpc session_id _params = let subject_identifiers = Client.Session.get_all_subject_identifiers ~rpc ~session_id @@ -8096,7 +8110,9 @@ module VTPM = struct let create printer rpc session_id params = let vm_uuid = List.assoc "vm-uuid" params in let vM = Client.VM.get_by_uuid ~rpc ~session_id ~uuid:vm_uuid in - let is_unique = get_bool_param params "is_unique" in + let is_unique = + get_bool_param params "is_unique" || get_bool_param params "is-unique" + in let ref = Client.VTPM.create ~rpc ~session_id ~vM ~is_unique in let uuid = Client.VTPM.get_uuid ~rpc ~session_id ~self:ref in printer (Cli_printer.PList [uuid]) diff --git a/ocaml/xapi-cli-server/cli_util.ml b/ocaml/xapi-cli-server/cli_util.ml index 75c4f30360..b71c9f1f3a 100644 --- a/ocaml/xapi-cli-server/cli_util.ml +++ b/ocaml/xapi-cli-server/cli_util.ml @@ -91,7 +91,7 @@ let track callback rpc (session_id : API.ref_session) task = | _ -> false in - finished := List.fold_left ( || ) false (List.map matches events) + finished := List.exists matches events done with | Api_errors.Server_error (code, _) diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index 48984b7450..fb2a713dcf 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -26,6 +26,7 @@ uri tar threads.posix + unix xapi-backtrace xapi-consts xapi_version diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index d28b6b5f76..a11b30decb 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -75,6 +75,7 @@ let vm_operation_table = ; (`csvm, "csvm") ; (`call_plugin, "call_plugin") ; (`create_vtpm, "create_vtpm") + ; (`sysprep, "sysprep") ] (* Intentional shadowing - data_souces_op, assertoperationinvalid, diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index da839d1e3f..ee68f272eb 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -20,6 +20,8 @@ let nullref = Ref.string_of Ref.null let nid = "" +let inconsistent = "" + let unknown_time = "" let string_of_float f = Printf.sprintf "%.3f" f @@ -204,6 +206,37 @@ let get_pbds_host rpc session_id pbds = let get_sr_host rpc session_id record = get_pbds_host rpc session_id record.API.sR_PBDs +(** Get consistent field from all hosts, or return a default value if the field + is not the same on all hosts. *) +let get_consistent_field_or_default ~rpc ~session_id ~getter ~transform ~default + = + match Client.Host.get_all ~rpc ~session_id with + | [] -> + default + | hosts -> ( + let result = + List.fold_left + (fun acc host -> + match acc with + | `Inconsistent -> + `Inconsistent + | `NotSet -> + `Value (getter ~rpc ~session_id ~self:host |> transform) + | `Value v -> + let current = getter ~rpc ~session_id ~self:host |> transform in + if v = current then `Value v else `Inconsistent + ) + `NotSet hosts + in + match result with + | `Value v -> + v + | `Inconsistent -> + default + | `NotSet -> + default + ) + let bond_record rpc session_id bond = let _ref = ref bond in let empty_record = @@ -1515,6 +1548,53 @@ let pool_record rpc session_id pool = ) ~get_map:(fun () -> (x ()).API.pool_license_server) () + ; make_field ~name:"ssh-enabled" + ~get:(fun () -> + get_consistent_field_or_default ~rpc ~session_id + ~getter:Client.Host.get_ssh_enabled ~transform:string_of_bool + ~default:inconsistent + ) + () + ; make_field ~name:"ssh-enabled-timeout" + ~get:(fun () -> + get_consistent_field_or_default ~rpc ~session_id + ~getter:Client.Host.get_ssh_enabled_timeout + ~transform:Int64.to_string ~default:inconsistent + ) + ~set:(fun value -> + Client.Pool.set_ssh_enabled_timeout ~rpc ~session_id ~self:pool + ~value:(safe_i64_of_string "ssh-enabled-timeout" value) + ) + () + ; make_field ~name:"ssh-expiry" + ~get:(fun () -> + get_consistent_field_or_default ~rpc ~session_id + ~getter:Client.Host.get_ssh_expiry ~transform:Date.to_rfc3339 + ~default:inconsistent + ) + () + ; make_field ~name:"console-idle-timeout" + ~get:(fun () -> + get_consistent_field_or_default ~rpc ~session_id + ~getter:Client.Host.get_console_idle_timeout + ~transform:Int64.to_string ~default:inconsistent + ) + ~set:(fun value -> + Client.Pool.set_console_idle_timeout ~rpc ~session_id ~self:pool + ~value:(safe_i64_of_string "console-idle-timeout" value) + ) + () + ; make_field ~name:"ssh-auto-mode" + ~get:(fun () -> + get_consistent_field_or_default ~rpc ~session_id + ~getter:Client.Host.get_ssh_auto_mode ~transform:string_of_bool + ~default:inconsistent + ) + ~set:(fun value -> + Client.Pool.set_ssh_auto_mode ~rpc ~session_id ~self:pool + ~value:(safe_bool_of_string "ssh-auto-mode" value) + ) + () ] } @@ -3286,6 +3366,36 @@ let host_record rpc session_id host = ; make_field ~name:"last-update-hash" ~get:(fun () -> (x ()).API.host_last_update_hash) () + ; make_field ~name:"ssh-enabled" + ~get:(fun () -> string_of_bool (x ()).API.host_ssh_enabled) + () + ; make_field ~name:"ssh-enabled-timeout" + ~get:(fun () -> Int64.to_string (x ()).API.host_ssh_enabled_timeout) + ~set:(fun value -> + Client.Host.set_ssh_enabled_timeout ~rpc ~session_id ~self:host + ~value:(safe_i64_of_string "ssh-enabled-timeout" value) + ) + () + ; make_field ~name:"ssh-expiry" + ~get:(fun () -> Date.to_rfc3339 (x ()).API.host_ssh_expiry) + () + ; make_field ~name:"console-idle-timeout" + ~get:(fun () -> Int64.to_string (x ()).API.host_console_idle_timeout) + ~set:(fun value -> + Client.Host.set_console_idle_timeout ~rpc ~session_id ~self:host + ~value:(safe_i64_of_string "console-idle-timeout" value) + ) + () + ; make_field ~name:"ssh-auto-mode" + ~get:(fun () -> string_of_bool (x ()).API.host_ssh_auto_mode) + ~set:(fun value -> + Client.Host.set_ssh_auto_mode ~rpc ~session_id ~self:host + ~value:(safe_bool_of_string "ssh-auto-mode" value) + ) + () + ; make_field ~name:"secure-boot" + ~get:(fun () -> string_of_bool (x ()).API.host_secure_boot) + () ] } diff --git a/ocaml/xapi-cli-server/xapi_cli.ml b/ocaml/xapi-cli-server/xapi_cli.ml index 72057550ff..8bb009285d 100644 --- a/ocaml/xapi-cli-server/xapi_cli.ml +++ b/ocaml/xapi-cli-server/xapi_cli.ml @@ -125,7 +125,7 @@ module TraceHelper = struct include Tracing.Propagator.Make (struct include Tracing_propagator.Propagator.Http - let name_span req = req.Http.Request.uri + let name_span req = req.Http.Request.path end) let inject_span_into_req (span : Tracing.Span.t option) = diff --git a/ocaml/xapi-client/dune b/ocaml/xapi-client/dune index 57faa74500..e57195b20d 100644 --- a/ocaml/xapi-client/dune +++ b/ocaml/xapi-client/dune @@ -16,6 +16,7 @@ mtime mtime.clock.os (re_export rpclib.core) + unix xapi-consts xapi-log xapi-types diff --git a/ocaml/xapi-client/tasks.ml b/ocaml/xapi-client/tasks.ml index c62f681d60..a9da21890e 100644 --- a/ocaml/xapi-client/tasks.ml +++ b/ocaml/xapi-client/tasks.ml @@ -23,7 +23,7 @@ module TaskSet = Set.Make (struct end) (* Return once none of the tasks have a `pending status. *) -let wait_for_all_inner ~rpc ~session_id ~all_timeout ~tasks = +let wait_for_all_inner ~rpc ~session_id ~all_timeout ~tasks ~callback = let classes = List.map (fun task -> Printf.sprintf "task/%s" (Ref.string_of task)) tasks in @@ -36,7 +36,12 @@ let wait_for_all_inner ~rpc ~session_id ~all_timeout ~tasks = in let timer = Mtime_clock.counter () in let timeout = 5.0 in - let rec wait ~token ~task_set = + let get_new_classes task_set = + TaskSet.fold + (fun task l -> Printf.sprintf "task/%s" (Ref.string_of task) :: l) + task_set [] + in + let rec wait ~token ~task_set ~completed_task_count ~classes = if TaskSet.is_empty task_set then true else @@ -58,24 +63,39 @@ let wait_for_all_inner ~rpc ~session_id ~all_timeout ~tasks = List.map Event_helper.record_of_event event_from.events in (* If any records indicate that a task is no longer pending, remove that task from the set. *) - let pending_task_set = + let pending_task_set, completed_task_count, classes = List.fold_left - (fun task_set' record -> + (fun (task_set', completed_task_count, _) record -> match record with | Event_helper.Task (t, Some t_rec) -> if TaskSet.mem t task_set' && t_rec.API.task_status <> `pending then - TaskSet.remove t task_set' + let new_task_set = TaskSet.remove t task_set' in + let completed_task_count = completed_task_count + 1 in + + (* Call the callback function, wait for new tasks if any *) + let tasks_to_add = callback completed_task_count t in + let new_task_set = + List.fold_left + (fun task_set task -> TaskSet.add task task_set) + new_task_set tasks_to_add + in + ( new_task_set + , completed_task_count + , get_new_classes new_task_set + ) else - task_set' + (task_set', completed_task_count, classes) | _ -> - task_set' + (task_set', completed_task_count, classes) ) - task_set records + (task_set, completed_task_count, classes) + records in wait ~token:event_from.Event_types.token ~task_set:pending_task_set + ~completed_task_count ~classes in let token = "" in let task_set = @@ -83,17 +103,27 @@ let wait_for_all_inner ~rpc ~session_id ~all_timeout ~tasks = (fun task_set' task -> TaskSet.add task task_set') TaskSet.empty tasks in - wait ~token ~task_set + wait ~token ~task_set ~completed_task_count:0 ~classes let wait_for_all ~rpc ~session_id ~tasks = - wait_for_all_inner ~rpc ~session_id ~all_timeout:None ~tasks |> ignore + wait_for_all_inner ~rpc ~session_id ~all_timeout:None ~tasks + ~callback:(fun _ _ -> [] + ) + |> ignore + +let wait_for_all_with_callback ~rpc ~session_id ~tasks ~callback = + wait_for_all_inner ~rpc ~session_id ~all_timeout:None ~tasks ~callback + |> ignore let with_tasks_destroy ~rpc ~session_id ~timeout ~tasks = let wait_or_cancel () = D.info "Waiting for %d tasks, timeout: %.3fs" (List.length tasks) timeout ; if not - (wait_for_all_inner ~rpc ~session_id ~all_timeout:(Some timeout) ~tasks) + (wait_for_all_inner ~rpc ~session_id ~all_timeout:(Some timeout) ~tasks + ~callback:(fun _ _ -> [] + ) + ) then ( D.info "Canceling tasks" ; List.iter @@ -104,6 +134,8 @@ let with_tasks_destroy ~rpc ~session_id ~timeout ~tasks = tasks ; (* cancel is not immediate, give it a reasonable chance to take effect *) wait_for_all_inner ~rpc ~session_id ~all_timeout:(Some 60.) ~tasks + ~callback:(fun _ _ -> [] + ) |> ignore ; false ) else diff --git a/ocaml/xapi-client/tasks.mli b/ocaml/xapi-client/tasks.mli index 8989b01716..a396c569ae 100644 --- a/ocaml/xapi-client/tasks.mli +++ b/ocaml/xapi-client/tasks.mli @@ -12,6 +12,8 @@ * GNU Lesser General Public License for more details. *) +module TaskSet : Set.S with type elt = API.ref_task + val wait_for_all : rpc:(Rpc.call -> Rpc.response) -> session_id:API.ref_session @@ -20,6 +22,27 @@ val wait_for_all : (** [wait_for_all ~rpc ~session_id ~tasks] returns when all of [tasks] are in some non-pending state. *) +val wait_for_all_with_callback : + rpc:(Rpc.call -> Rpc.response) + -> session_id:API.ref_session + -> tasks:API.ref_task list + -> callback:(int -> API.ref_task -> API.ref_task list) + -> unit +(** [wait_for_all_with_callback ~rpc ~session_id ~tasks ~callback] returns when + all of [tasks] are in some non-pending state. When one of the [tasks] is + completed, [callback overall_completed_task_count] is invoked, which returns + a list of tasks that need to be added to [tasks] and waited on as well. + + This allows, for example, to implement a system where tasks are processed + in batches of *constant* size X, with new tasks being started as soon as at + least one slot in the batch is freed, instead of waiting for the whole batch + to finish (and potentially being slowed down by a single worst performer). + + The callback could instead just perform some side-effect (set the progress + of the overall task representing progress of individual units, for example) + and return an empty list. + *) + val with_tasks_destroy : rpc:(Rpc.call -> Rpc.response) -> session_id:API.ref_session diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 906e22bf25..2a1b9b58b7 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -113,6 +113,8 @@ let host_disabled = add_error "HOST_DISABLED" let host_disabled_until_reboot = add_error "HOST_DISABLED_UNTIL_REBOOT" +let host_disabled_indefinitely = add_error "HOST_DISABLED_INDEFINITELY" + let host_not_disabled = add_error "HOST_NOT_DISABLED" let host_not_live = add_error "HOST_NOT_LIVE" @@ -440,14 +442,7 @@ let vm_old_pv_drivers = add_error "VM_OLD_PV_DRIVERS" let vm_lacks_feature = add_error "VM_LACKS_FEATURE" -let vm_lacks_feature_shutdown = add_error "VM_LACKS_FEATURE_SHUTDOWN" - -let vm_lacks_feature_suspend = add_error "VM_LACKS_FEATURE_SUSPEND" - -let vm_lacks_feature_vcpu_hotplug = add_error "VM_LACKS_FEATURE_VCPU_HOTPLUG" - -let vm_lacks_feature_static_ip_setting = - add_error "VM_LACKS_FEATURE_STATIC_IP_SETTING" +let vm_non_suspendable = add_error "VM_NON_SUSPENDABLE" let vm_cannot_delete_default_template = add_error "VM_CANNOT_DELETE_DEFAULT_TEMPLATE" @@ -757,6 +752,12 @@ let pool_joining_host_ca_certificates_conflict = let pool_joining_sm_features_incompatible = add_error "POOL_JOINING_SM_FEATURES_INCOMPATIBLE" +let pool_joining_pool_cannot_enable_clustering_on_vlan_network = + add_error "POOL_JOINING_POOL_CANNOT_ENABLE_CLUSTERING_ON_VLAN_NETWORK" + +let pool_joining_host_must_have_only_one_IP_on_clustering_network = + add_error "POOL_JOINING_HOST_MUST_HAVE_ONLY_ONE_IP_ON_CLUSTERING_NETWORK" + (*workload balancing*) let wlb_not_initialized = add_error "WLB_NOT_INITIALIZED" @@ -1317,6 +1318,8 @@ let configure_repositories_in_progress = let invalid_base_url = add_error "INVALID_BASE_URL" +let blocked_repo_url = add_error "BLOCKED_REPO_URL" + let invalid_gpgkey_path = add_error "INVALID_GPGKEY_PATH" let repository_already_exists = add_error "REPOSITORY_ALREADY_EXISTS" @@ -1420,7 +1423,18 @@ let enable_ssh_partially_failed = add_error "ENABLE_SSH_PARTIALLY_FAILED" let disable_ssh_partially_failed = add_error "DISABLE_SSH_PARTIALLY_FAILED" +let set_ssh_timeout_partially_failed = + add_error "SET_SSH_TIMEOUT_PARTIALLY_FAILED" + +let set_console_timeout_partially_failed = + add_error "SET_CONSOLE_TIMEOUT_PARTIALLY_FAILED" + +let set_ssh_auto_mode_partially_failed = + add_error "SET_SSH_AUTO_MODE_PARTIALLY_FAILED" + let host_driver_no_hardware = add_error "HOST_DRIVER_NO_HARDWARE" let tls_verification_not_enabled_in_pool = add_error "TLS_VERIFICATION_NOT_ENABLED_IN_POOL" + +let sysprep = add_error "SYSPREP" diff --git a/ocaml/xapi-consts/constants.ml b/ocaml/xapi-consts/constants.ml index 3072a459c0..c2b77993be 100644 --- a/ocaml/xapi-consts/constants.ml +++ b/ocaml/xapi-consts/constants.ml @@ -177,6 +177,20 @@ let hvm_boot_params_order = "order" let hvm_default_boot_order = "cd" +(** Keys for different CPUID policies in {Host,Pool}.cpu_info *) + +let cpu_info_vendor_key = "vendor" + +let cpu_info_features_key = "features" + +let cpu_info_features_pv_key = "features_pv" + +let cpu_info_features_hvm_key = "features_hvm" + +let cpu_info_features_pv_host_key = "features_pv_host" + +let cpu_info_features_hvm_host_key = "features_hvm_host" + (* Key we put in VM.other_config when we upgrade a VM from Zurich/Geneva to Rio *) let vm_upgrade_time = "upgraded at" @@ -198,12 +212,29 @@ let ballooning_enabled = "ballooning.enabled" let redo_log_enabled = "redo_log.enabled" (* Valid cluster stack values *) -let ha_cluster_stack = "ha_cluster_stack" +module Ha_cluster_stack = struct + type t = Xhad | Corosync + + let key = "ha_cluster_stack" + + let to_string = function Xhad -> "xhad" | Corosync -> "corosync" -let default_smapiv3_cluster_stack = "corosync" + let of_string = function + | "xhad" -> + Some Xhad + | "corosync" -> + Some Corosync + | _ -> + None +end -(* Note: default without clustering is in !Xapi_globs.default_cluster_stack *) -let supported_smapiv3_cluster_stacks = ["corosync"] +let ha_cluster_stack = Ha_cluster_stack.key + +let default_cluster_stack = Ha_cluster_stack.(to_string Xhad) + +let default_smapiv3_cluster_stack = Ha_cluster_stack.(to_string Corosync) + +let supported_smapiv3_cluster_stacks = [default_smapiv3_cluster_stack] (* Set in the local db to cause us to emit an alert when we come up as a master after a transition or HA failover *) @@ -219,6 +250,11 @@ let master_scripts = "master_scripts" This will prevent anyone from re-enabling the host and starting VMs on it during shutdown. *) let host_disabled_until_reboot = "host_disabled_until_reboot" +(* This flag is set to false when the host is forcibly disabled in a + persistent way - it will not be re-enabled on startup (even after reboots) + until manually directed by the user *) +let host_auto_enable = "host_auto_enable" + (* Set when shutting down and rebooting. If we come up and finds no new crashdump and HA is enabled, we assume the host was fenced. *) let host_restarted_cleanly = "host_restarted_cleanly" @@ -422,3 +458,11 @@ let observer_components_all = let tgroups_enabled = ref false let when_tgroups_enabled f = if !tgroups_enabled then f () else () + +let default_ssh_enabled = true + +let default_ssh_enabled_timeout = 0L + +let default_console_idle_timeout = 0L + +let default_ssh_auto_mode = false diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index e4eebc4cd8..cb6345496d 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -18,6 +18,7 @@ rpclib.core rpclib-lwt rpclib.xml + unix uuidm uri xapi_guard @@ -44,6 +45,7 @@ mtime mtime.clock mtime.clock.os + unix uuidm uri xapi-backtrace diff --git a/ocaml/xapi-guard/src/dune b/ocaml/xapi-guard/src/dune index 7c48635b73..94a3ddd5cd 100644 --- a/ocaml/xapi-guard/src/dune +++ b/ocaml/xapi-guard/src/dune @@ -13,6 +13,7 @@ rpclib.core rpclib.json rpclib-lwt + unix uuidm xapi_guard xapi_guard_server diff --git a/ocaml/xapi-guard/test/xapi_guard_test.ml b/ocaml/xapi-guard/test/xapi_guard_test.ml index 475a96d3a2..2f048fe666 100644 --- a/ocaml/xapi-guard/test/xapi_guard_test.ml +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -86,8 +86,8 @@ let with_rpc f switch () = Server_interface.make_server_varstored push_nothing ~cache path vm_uuid in (* rpc simulates what varstored would do *) - let uri = Uri.make ~scheme:"file" ~path () |> Uri.to_string in - D.debug "Connecting to %s" uri ; + let uri = Uri.make ~scheme:"file" ~path () in + D.debug "Connecting to %s" (Uri.to_string uri) ; let rpc = make uri in Lwt.finalize (fun () -> diff --git a/ocaml/xapi-idl/cluster/cli-help.t b/ocaml/xapi-idl/cluster/cli-help.t new file mode 100644 index 0000000000..abe729544d --- /dev/null +++ b/ocaml/xapi-idl/cluster/cli-help.t @@ -0,0 +1,119 @@ + $ ./cluster_cli.exe --help=plain + NAME + cluster_cli - A CLI for the cluster API. This tool is not intended to + be used as an end user tool + + SYNOPSIS + cluster_cli [COMMAND] … + + COMMANDS + Observer.create [OPTION]… dbg uuid name_label dict endpoints bool + + Observer.destroy [OPTION]… dbg uuid + + Observer.init [OPTION]… dbg + + Observer.set_attributes [OPTION]… dbg uuid dict + + Observer.set_compress_tracing_files [OPTION]… dbg bool + + Observer.set_enabled [OPTION]… dbg uuid bool + + Observer.set_endpoints [OPTION]… dbg uuid endpoints + + Observer.set_export_chunk_size [OPTION]… dbg int + + Observer.set_export_interval [OPTION]… dbg float + + Observer.set_host_id [OPTION]… dbg string + + Observer.set_max_depth [OPTION]… dbg int + + Observer.set_max_file_size [OPTION]… dbg int + + Observer.set_max_spans [OPTION]… dbg int + + Observer.set_max_traces [OPTION]… dbg int + + Observer.set_trace_log_dir [OPTION]… dbg string + + UPDATES.get [OPTION]… dbg timeout + Get updates from corosync-notifyd, this blocking call will return + when there is an update from corosync-notifyd or it is timed out + after timeout_p seconds + + create [OPTION]… dbg init_config + Creates the cluster. The call takes the initial config of the + initial host to add to the cluster. This will be the address on + which the rings will be created. + + declare-changed-addrs [OPTION]… dbg changed_members + Declare that one or more hosts in the cluster have changed + address. Only use this command if unable to rejoin the cluster + using `enable` because the IPv4 addresses of all nodes this node + previously saw are now invalid. If any one of these addresses + remains valid on an enabled node then this action is unnecessary. + + declare-dead [OPTION]… dbg dead_members + Declare that some hosts in the cluster are permanently dead. + Removes the hosts from the cluster. If the hosts do attempt to + rejoin the cluster in future, this may lead to fencing of other + hosts and/or data loss or data corruption. + + destroy [OPTION]… dbg + Destroys a created cluster + + diagnostics [OPTION]… dbg + Returns diagnostic information about the cluster + + disable [OPTION]… dbg + Stop the cluster on this host; leave the rest of the cluster + enabled. The cluster can be reenabled either by restarting the + host, or by calling the `enable` API call. + + enable [OPTION]… dbg init_config + Rejoins the cluster following a call to `disable`. The parameter + passed is the cluster config to use (optional fields set to None + unless updated) in case it changed while the host was disabled. + (Note that changing optional fields isn't yet supported, TODO) + + join [OPTION]… dbg token new_member tls_config existing_members + Adds a node to an initialised cluster. Takes the IPv4 address of + the new member and a list of the addresses of all the existing + members. + + leave [OPTION]… dbg + Causes this host to permanently leave the cluster, but leaves the + rest of the cluster enabled. This is not a temporary removal - if + the admin wants the hosts to rejoin the cluster again, he will + have to call `join` rather than `enable`. + + set-tls-verification [OPTION]… dbg server_pem_path + trusted_bundle_path cn enabled + Enable or disable TLS verification for xapi/clusterd + communication. The trusted_bundle_path is ignored when + verification is disabled and can be empty + + switch-cluster-stack [OPTION]… dbg cluster_stack + Switch cluster stack version to the target + + COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + cluster_cli exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + diff --git a/ocaml/xapi-idl/cluster/cluster_interface.ml b/ocaml/xapi-idl/cluster/cluster_interface.ml index a39fc0a2ae..d537cf0f99 100644 --- a/ocaml/xapi-idl/cluster/cluster_interface.ml +++ b/ocaml/xapi-idl/cluster/cluster_interface.ml @@ -384,80 +384,5 @@ module LocalAPI (R : RPC) = struct (debug_info_p @-> timeout_p @-> returning result_p err) end - module Observer = struct - open TypeCombinators - - let endpoints_p = Param.mk ~name:"endpoints" (list Types.string) - - let bool_p = Param.mk ~name:"bool" Types.bool - - let uuid_p = Param.mk ~name:"uuid" Types.string - - let name_label_p = Param.mk ~name:"name_label" Types.string - - let dict_p = Param.mk ~name:"dict" dict - - let string_p = Param.mk ~name:"string" Types.string - - let int_p = Param.mk ~name:"int" Types.int - - let float_p = Param.mk ~name:"float" Types.float - - let create = - declare "Observer.create" [] - (debug_info_p - @-> uuid_p - @-> name_label_p - @-> dict_p - @-> endpoints_p - @-> bool_p - @-> returning unit_p err - ) - - let destroy = - declare "Observer.destroy" [] - (debug_info_p @-> uuid_p @-> returning unit_p err) - - let set_enabled = - declare "Observer.set_enabled" [] - (debug_info_p @-> uuid_p @-> bool_p @-> returning unit_p err) - - let set_attributes = - declare "Observer.set_attributes" [] - (debug_info_p @-> uuid_p @-> dict_p @-> returning unit_p err) - - let set_endpoints = - declare "Observer.set_endpoints" [] - (debug_info_p @-> uuid_p @-> endpoints_p @-> returning unit_p err) - - let init = declare "Observer.init" [] (debug_info_p @-> returning unit_p err) - - let set_trace_log_dir = - declare "Observer.set_trace_log_dir" [] - (debug_info_p @-> string_p @-> returning unit_p err) - - let set_export_interval = - declare "Observer.set_export_interval" [] - (debug_info_p @-> float_p @-> returning unit_p err) - - let set_host_id = - declare "Observer.set_host_id" [] - (debug_info_p @-> string_p @-> returning unit_p err) - - let set_max_traces = - declare "Observer.set_max_traces" [] - (debug_info_p @-> int_p @-> returning unit_p err) - - let set_max_spans = - declare "Observer.set_max_spans" [] - (debug_info_p @-> int_p @-> returning unit_p err) - - let set_max_file_size = - declare "Observer.set_max_file_size" [] - (debug_info_p @-> int_p @-> returning unit_p err) - - let set_compress_tracing_files = - declare "Observer.set_compress_tracing_files" [] - (debug_info_p @-> bool_p @-> returning unit_p err) - end + module Observer = Observer_helpers.ObserverAPI (R) end diff --git a/ocaml/xapi-idl/cluster/dune b/ocaml/xapi-idl/cluster/dune index 50777aeb2b..f1ec6e321d 100644 --- a/ocaml/xapi-idl/cluster/dune +++ b/ocaml/xapi-idl/cluster/dune @@ -27,8 +27,6 @@ xapi-idl xapi-idl.cluster)) -(rule - (alias runtest) - (deps (:x cluster_cli.exe)) +(cram (package xapi-idl) - (action (run %{x} --help=plain))) + (deps cluster_cli.exe)) diff --git a/ocaml/xapi-idl/example/cli-help.t b/ocaml/xapi-idl/example/cli-help.t new file mode 100644 index 0000000000..c38ea73040 --- /dev/null +++ b/ocaml/xapi-idl/example/cli-help.t @@ -0,0 +1,90 @@ + $ ./example.exe --help=plain + NAME + Example-service + + SYNOPSIS + Example-service [OPTION]… + + DESCRIPTION + This is an example service which demonstrates the configuration + mechanism. + + OPTIONS + --config=VAL (absent=/etc/example.exe.conf) + Location of configuration file + + --config-dir=VAL (absent=/etc/example.exe.conf.d) + Location of directory containing configuration file fragments + + --default-format=VAL (absent=vhd) + Default format for disk files + + --disable-logging-for=VAL + A space-separated list of debug modules to suppress logging from + + --inventory=VAL (absent=/etc/xensource-inventory) + Location of the inventory file + + --log=VAL (absent=syslog:daemon) + Where to write log messages + + --loglevel=VAL (absent=debug) + Log level + + --ls=VAL (absent=/bin/ls) + program used to list things + + --pidfile=VAL (absent=/var/run/example.exe.pid) + Filename to write process PID + + --queue-name=VAL (absent=org.xen.xapi.ffs) + Comma-separated list of queue names to listen on + + --search-path=VAL + Search path for resources + + --sh=VAL (absent=/bin/sh) + interpreter for arcane programming language + + --socket-path=VAL (absent=/var/xapi/socket) + Path of listening socket + + --sr-mount-path=VAL (absent=/mnt) + Default mountpoint for mounting remote filesystems + + --switch-path=VAL (absent=/var/run/message-switch/sock) + Unix domain socket path on localhost where the message switch is + listening + + --timeslice=VAL (absent=0.05) + timeslice in seconds + + --use-switch=VAL (absent=true) + true if the message switch is to be enabled + + COMMON OPTIONS + These options are common to all services. + + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + Example-service exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + + BUGS + Check bug reports at http://github.com/xapi-project/xen-api + + diff --git a/ocaml/xapi-idl/example/dune b/ocaml/xapi-idl/example/dune index cf27e69dcf..8fb2d217c8 100644 --- a/ocaml/xapi-idl/example/dune +++ b/ocaml/xapi-idl/example/dune @@ -3,14 +3,13 @@ (libraries astring rpclib.core + unix xapi-consts.xapi_version xapi-idl xapi-log ) (preprocess (pps ppx_deriving_rpc))) -(rule - (alias runtest) - (deps (:x example.exe)) +(cram (package xapi-idl) - (action (run %{x} --help=plain))) + (deps example.exe)) diff --git a/ocaml/xapi-idl/gpumon/cli-help.t b/ocaml/xapi-idl/gpumon/cli-help.t new file mode 100644 index 0000000000..afe309b014 --- /dev/null +++ b/ocaml/xapi-idl/gpumon/cli-help.t @@ -0,0 +1,58 @@ + $ ./gpumon_cli.exe --help=plain + NAME + gpumon_cli - A CLI for the GPU monitoring API. This allows scripting + of the gpumon daemon for testing and debugging. This tool is not + intended to be used as an end user tool + + SYNOPSIS + gpumon_cli [COMMAND] … + + COMMANDS + get_pgpu_metadata [OPTION]… debug_info pgpu_address + Gets the metadata for a pGPU, given its address (PCI bus ID). + + get_pgpu_vgpu_compatibility [OPTION]… debug_info + nvidia_pgpu_metadata nvidia_vgpu_metadata_list + Checks compatibility between a pGPU (on a host) and a list of + vGPUs (assigned to a VM). Note: A VM may use several vGPUs. The + use case is VM.suspend/VM.resume: before VM.resume + [nvidia_vgpu_metadata] of the suspended VM is checked against the + [nvidia_pgpu_metadata] on the host where the VM is resumed. + + get_pgpu_vm_compatibility [OPTION]… debug_info pgpu_address domid + nvidia_pgpu_metadata + Checks compatibility between a VM's vGPU(s) and another pGPU. + + get_vgpu_metadata [OPTION]… debug_info domid pgpu_address vgpu_uuid + Obtains metadata for all vGPUs running in a domain. + + nvml_attach [OPTION]… debug_info + Attach nVidia cards to Gpumon for metrics and compatibility + checking. + + nvml_detach [OPTION]… debug_info + Detach nVidia cards from Gpumon + + nvml_is_attached [OPTION]… debug_info + Return true if nVidia cards are currently attached. + + COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + gpumon_cli exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + diff --git a/ocaml/xapi-idl/gpumon/dune b/ocaml/xapi-idl/gpumon/dune index de10e06dae..269a6690ee 100644 --- a/ocaml/xapi-idl/gpumon/dune +++ b/ocaml/xapi-idl/gpumon/dune @@ -27,8 +27,6 @@ xapi-idl xapi-idl.gpumon)) -(rule - (alias runtest) - (deps (:x gpumon_cli.exe)) +(cram (package xapi-idl) - (action (run %{x} --help=plain))) + (deps gpumon_cli.exe)) diff --git a/ocaml/xapi-idl/guard/privileged/cli-help.t b/ocaml/xapi-idl/guard/privileged/cli-help.t new file mode 100644 index 0000000000..0e990ca949 --- /dev/null +++ b/ocaml/xapi-idl/guard/privileged/cli-help.t @@ -0,0 +1,53 @@ + $ ./xapiguard_cli.exe --help=plain + NAME + xapiguard_cli - A CLI for the deprivileged socket spawning API. This + allows scripting of the varstored and SWTPM deprivileging daemon for + testing and debugging. This tool is not intended to be used as an end + user tool + + SYNOPSIS + xapiguard_cli [COMMAND] … + + COMMANDS + varstore_create [OPTION]… dbg vm_uuid gid path + Create a deprivileged varstore socket that only accepts API calls + for a specific VM. The socket will be writable only to the + specified group. + + varstore_destroy [OPTION]… dbg gid path + Stop listening on varstore sockets for the specified group + + vtpm_create [OPTION]… dbg vm_uuid gid path + Create a deprivileged vtpm socket that only accepts API calls for + a specific VM. The socket will be writable only to the specified + group. + + vtpm_destroy [OPTION]… dbg gid path + Stop listening on vtpm sockets for the specified group + + vtpm_get_contents [OPTION]… dbg vtpm_uuid + Get vTPM contents blob + + vtpm_set_contents [OPTION]… dbg vtpm_uuid string + Set vTPM contents blob + + COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + xapiguard_cli exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + diff --git a/ocaml/xapi-idl/guard/privileged/dune b/ocaml/xapi-idl/guard/privileged/dune index cdb888692d..b5de6b38b8 100644 --- a/ocaml/xapi-idl/guard/privileged/dune +++ b/ocaml/xapi-idl/guard/privileged/dune @@ -18,7 +18,7 @@ (package varstored-guard) (libraries cmdliner - + rpclib.cmdliner rpclib.core rpclib.markdown @@ -26,8 +26,6 @@ xapi-idl.guard.privileged )) -(rule - (alias runtest) - (deps xapiguard_cli.exe) +(cram (package varstored-guard) - (action (run %{deps} --help=plain))) + (deps xapiguard_cli.exe)) diff --git a/ocaml/xapi-idl/guard/varstored/cli-help.t b/ocaml/xapi-idl/guard/varstored/cli-help.t new file mode 100644 index 0000000000..6f36f4bf5b --- /dev/null +++ b/ocaml/xapi-idl/guard/varstored/cli-help.t @@ -0,0 +1,49 @@ + $ ./varstored_cli.exe --help=plain + NAME + varstored_cli - debug CLI + + SYNOPSIS + varstored_cli [COMMAND] … + + COMMANDS + VM.get_NVRAM [--socket=SOCKET] [OPTION]… string string + Get the current VM's NVRAM contents + + VM.get_by_uuid [--socket=SOCKET] [OPTION]… string string + Dummy, for wire compatibility with XAPI + + VM.set_NVRAM_EFI_variables [--socket=SOCKET] [OPTION]… string string + string + Set the current VM's NVRAM contents + + message.create [--socket=SOCKET] [OPTION]… string string int64 + string string string + Send an alert when booting a UEFI guest fails + + session.login_with_password [--socket=SOCKET] [OPTION]… string + string string string + Dummy, for wire compatibility with XAPI + + session.logout [--socket=SOCKET] [OPTION]… string + Dummy, for wire compatibility with XAPI + + COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + varstored_cli exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + diff --git a/ocaml/xapi-idl/guard/varstored/dune b/ocaml/xapi-idl/guard/varstored/dune index abded2e1c1..6957b6c7a7 100644 --- a/ocaml/xapi-idl/guard/varstored/dune +++ b/ocaml/xapi-idl/guard/varstored/dune @@ -17,7 +17,7 @@ (modules varstored_cli) (libraries cmdliner - + rpclib.cmdliner rpclib.core rpclib.markdown @@ -25,8 +25,6 @@ xapi-idl.guard.varstored )) -(rule - (alias runtest) - (deps varstored_cli.exe) +(cram (package xapi-idl) - (action (run %{deps} --help=plain))) + (deps varstored_cli.exe)) diff --git a/ocaml/xapi-idl/lib/coverage/enabled.ml b/ocaml/xapi-idl/lib/coverage/enabled.ml index 461221db51..11ac510f2d 100644 --- a/ocaml/xapi-idl/lib/coverage/enabled.ml +++ b/ocaml/xapi-idl/lib/coverage/enabled.ml @@ -103,12 +103,12 @@ module Dispatcher = struct |> (* filter out ourselves *) List.filter (fun q -> self <> q) |> (* best-effort: collect and return all non-failed results, log - errors *) + errors *) List.rev_map (rpc_ignore_err ~t ~body) |> (* multiple return values converted to a single string, suitable - for use in a command like: mv $(message-cli call - org.xen.xapi.coverage.dispatch --timeout 60 --body 'dump - {jobid}') /tmp/coverage/ *) + for use in a command like: mv $(message-cli call + org.xen.xapi.coverage.dispatch --timeout 60 --body 'dump + {jobid}') /tmp/coverage/ *) String.concat " " |> ok ) diff --git a/ocaml/xapi-idl/lib/debug_info.ml b/ocaml/xapi-idl/lib/debug_info.ml index 5483d6bc45..e3845fa080 100644 --- a/ocaml/xapi-idl/lib/debug_info.ml +++ b/ocaml/xapi-idl/lib/debug_info.ml @@ -76,13 +76,14 @@ let to_log_string t = t.log (* Sets the logging context based on `dbg`. Also adds a new tracing span, linked to the parent span from `dbg`, if available. *) -let with_dbg ?(with_thread = false) ~module_name ~name ~dbg f = +let with_dbg ?attributes ?(with_thread = false) ?(module_name = "") ~name ~dbg f + = let di = of_string dbg in let f_with_trace () = let name = match module_name with "" -> name | _ -> module_name ^ "." ^ name in - Tracing.with_tracing ~parent:di.tracing ~name (fun span -> + Tracing.with_tracing ?attributes ~parent:di.tracing ~name (fun span -> match span with Some _ -> f {di with tracing= span} | None -> f di ) in diff --git a/ocaml/xapi-idl/lib/debug_info.mli b/ocaml/xapi-idl/lib/debug_info.mli index fa2f6ff5d6..2b0244ac94 100644 --- a/ocaml/xapi-idl/lib/debug_info.mli +++ b/ocaml/xapi-idl/lib/debug_info.mli @@ -23,8 +23,9 @@ val to_string : t -> string val to_log_string : t -> string val with_dbg : - ?with_thread:bool - -> module_name:string + ?attributes:(string * string) list + -> ?with_thread:bool + -> ?module_name:string -> name:string -> dbg:string -> (t -> 'a) diff --git a/ocaml/xapi-idl/lib/dune b/ocaml/xapi-idl/lib/dune index 8f0d7ca27d..d91ba09b2c 100644 --- a/ocaml/xapi-idl/lib/dune +++ b/ocaml/xapi-idl/lib/dune @@ -40,7 +40,7 @@ (wrapped false) (preprocess (per_module - ((pps ppx_deriving_rpc) Xcp_channel Xcp_channel_protocol TypeCombinators) + ((pps ppx_deriving_rpc) Xcp_channel Xcp_channel_protocol TypeCombinators Observer_helpers Observer_skeleton) ((pps ppx_sexp_conv ppx_deriving_rpc) Xcp_pci)))) (library @@ -56,6 +56,7 @@ sexplib0 tracing threads.posix + unix xapi-backtrace xapi-idl xapi-log diff --git a/ocaml/xapi-idl/lib/observer_helpers.ml b/ocaml/xapi-idl/lib/observer_helpers.ml new file mode 100644 index 0000000000..c2ea58bb8d --- /dev/null +++ b/ocaml/xapi-idl/lib/observer_helpers.ml @@ -0,0 +1,266 @@ +(* + * 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 Rpc +open Idl + +module D = Debug.Make (struct let name = "observer_interface" end) + +open D + +let service_name = "observer" + +let queue_name = Xcp_service.common_prefix ^ service_name + +let default_sockets_dir = "/var/lib/xcp" + +let default_path = Filename.concat default_sockets_dir service_name + +let uri () = "file:" ^ default_path + +module Errors = struct + type error = + | Internal_error of string + | Unimplemented of string + | Unknown_error + [@@default Unknown_error] [@@deriving rpcty] +end + +exception Observer_error of Errors.error + +let err = + let open Error in + { + def= Errors.error + ; raiser= + (fun e -> + let exn = Observer_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn + ) + ; matcher= + (function + | Observer_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + Some e + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + Some (Internal_error (Printexc.to_string exn)) + ) + } + +(** An uninterpreted string associated with the operation. *) +type debug_info = string [@@deriving rpcty] + +module ObserverAPI (R : RPC) = struct + open R + open TypeCombinators + + let description = + let open Interface in + { + name= "Observer" + ; namespace= None + ; description= + [ + "This interface is used to create, update and destroy Observers to \ + control the use of tracing in different xapi components" + ] + ; version= (1, 0, 0) + } + + let implementation = implement description + + let dbg_p = Param.mk ~name:"dbg" Types.string + + let unit_p = Param.mk ~name:"unit" Types.unit + + let endpoints_p = Param.mk ~name:"endpoints" (list Types.string) + + let bool_p = Param.mk ~name:"bool" Types.bool + + let uuid_p = Param.mk ~name:"uuid" Types.string + + let name_label_p = Param.mk ~name:"name_label" Types.string + + let dict_p = Param.mk ~name:"dict" dict + + let string_p = Param.mk ~name:"string" Types.string + + let int_p = Param.mk ~name:"int" Types.int + + let float_p = Param.mk ~name:"float" Types.float + + let create = + declare "Observer.create" [] + (dbg_p + @-> uuid_p + @-> name_label_p + @-> dict_p + @-> endpoints_p + @-> bool_p + @-> returning unit_p err + ) + + let destroy = + declare "Observer.destroy" [] (dbg_p @-> uuid_p @-> returning unit_p err) + + let set_enabled = + declare "Observer.set_enabled" [] + (dbg_p @-> uuid_p @-> bool_p @-> returning unit_p err) + + let set_attributes = + declare "Observer.set_attributes" [] + (dbg_p @-> uuid_p @-> dict_p @-> returning unit_p err) + + let set_endpoints = + declare "Observer.set_endpoints" [] + (dbg_p @-> uuid_p @-> endpoints_p @-> returning unit_p err) + + let init = declare "Observer.init" [] (dbg_p @-> returning unit_p err) + + let set_trace_log_dir = + declare "Observer.set_trace_log_dir" [] + (dbg_p @-> string_p @-> returning unit_p err) + + let set_export_interval = + declare "Observer.set_export_interval" [] + (dbg_p @-> float_p @-> returning unit_p err) + + let set_export_chunk_size = + declare "Observer.set_export_chunk_size" [] + (dbg_p @-> int_p @-> returning unit_p err) + + let set_max_spans = + declare "Observer.set_max_spans" [] + (dbg_p @-> int_p @-> returning unit_p err) + + let set_max_traces = + declare "Observer.set_max_traces" [] + (dbg_p @-> int_p @-> returning unit_p err) + + let set_max_depth = + declare "Observer.set_max_depth" [] + (dbg_p @-> int_p @-> returning unit_p err) + + let set_max_file_size = + declare "Observer.set_max_file_size" [] + (dbg_p @-> int_p @-> returning unit_p err) + + let set_host_id = + declare "Observer.set_host_id" [] + (dbg_p @-> string_p @-> returning unit_p err) + + let set_compress_tracing_files = + declare "Observer.set_compress_tracing_files" [] + (dbg_p @-> bool_p @-> returning unit_p err) +end + +module type Server_impl = sig + type context = unit + + val create : + context + -> dbg:debug_info + -> uuid:string + -> name_label:string + -> attributes:(string * string) list + -> endpoints:string list + -> enabled:bool + -> unit + + val destroy : context -> dbg:debug_info -> uuid:string -> unit + + val set_enabled : + context -> dbg:debug_info -> uuid:string -> enabled:bool -> unit + + val set_attributes : + context + -> dbg:debug_info + -> uuid:string + -> attributes:(string * string) list + -> unit + + val set_endpoints : + context -> dbg:debug_info -> uuid:string -> endpoints:string list -> unit + + val init : context -> dbg:debug_info -> unit + + val set_trace_log_dir : context -> dbg:debug_info -> dir:string -> unit + + val set_export_interval : context -> dbg:debug_info -> interval:float -> unit + + val set_export_chunk_size : context -> dbg:debug_info -> size:int -> unit + + val set_max_spans : context -> dbg:debug_info -> spans:int -> unit + + val set_max_traces : context -> dbg:debug_info -> traces:int -> unit + + val set_max_depth : context -> dbg:debug_info -> depth:int -> unit + + val set_max_file_size : context -> dbg:debug_info -> file_size:int -> unit + + val set_host_id : context -> dbg:debug_info -> host_id:string -> unit + + val set_compress_tracing_files : + context -> dbg:debug_info -> enabled:bool -> unit +end + +module Server (Impl : Server_impl) () = struct + module S = ObserverAPI (Idl.Exn.GenServer ()) + + let _ = + S.create (fun dbg uuid name_label attributes endpoints enabled -> + Impl.create () ~dbg ~uuid ~name_label ~attributes ~endpoints ~enabled + ) ; + S.destroy (fun dbg uuid -> Impl.destroy () ~dbg ~uuid) ; + S.set_enabled (fun dbg uuid enabled -> + Impl.set_enabled () ~dbg ~uuid ~enabled + ) ; + S.set_attributes (fun dbg uuid attributes -> + Impl.set_attributes () ~dbg ~uuid ~attributes + ) ; + S.set_endpoints (fun dbg uuid endpoints -> + Impl.set_endpoints () ~dbg ~uuid ~endpoints + ) ; + S.init (fun dbg -> Impl.init () ~dbg) ; + S.set_trace_log_dir (fun dbg dir -> Impl.set_trace_log_dir () ~dbg ~dir) ; + S.set_export_interval (fun dbg interval -> + Impl.set_export_interval () ~dbg ~interval + ) ; + S.set_export_chunk_size (fun dbg size -> + Impl.set_export_chunk_size () ~dbg ~size + ) ; + S.set_max_spans (fun dbg spans -> Impl.set_max_spans () ~dbg ~spans) ; + S.set_max_traces (fun dbg traces -> Impl.set_max_traces () ~dbg ~traces) ; + S.set_max_depth (fun dbg depth -> Impl.set_max_depth () ~dbg ~depth) ; + S.set_max_file_size (fun dbg file_size -> + Impl.set_max_file_size () ~dbg ~file_size + ) ; + S.set_host_id (fun dbg host_id -> Impl.set_host_id () ~dbg ~host_id) ; + S.set_compress_tracing_files (fun dbg enabled -> + Impl.set_compress_tracing_files () ~dbg ~enabled + ) + + (* Bind all *) + let process call = Idl.Exn.server S.implementation call +end + +module Client = ObserverAPI (Idl.Exn.GenClient (struct + let rpc call = + Xcp_client.( + retry_and_switch_rpc call ~use_switch:!use_switch ~queue_name + ~dststr:queue_name ~uri + ) +end)) diff --git a/ocaml/xapi-idl/lib/observer_helpers.mli b/ocaml/xapi-idl/lib/observer_helpers.mli new file mode 100644 index 0000000000..489310a084 --- /dev/null +++ b/ocaml/xapi-idl/lib/observer_helpers.mli @@ -0,0 +1,248 @@ +val queue_name : string + +val default_path : string + +module Errors : sig + type error = + | Internal_error of string + | Unimplemented of string + | Unknown_error + + val typ_of_error : error Rpc.Types.typ + + val error : error Rpc.Types.def +end + +exception Observer_error of Errors.error + +type debug_info = string + +(** ObserverAPI contains the declarations for the RPCs which are sent to + Observer modules when the corresponding function is called on the Observer + see ocaml/libs/tracing/ and ocaml/xapi/xapi_observer.ml *) +module ObserverAPI : functor (R : Idl.RPC) -> sig + val description : Idl.Interface.description + + val implementation : R.implementation + + val create : + ( debug_info + -> string + -> string + -> (string * string) list + -> string list + -> bool + -> (unit, Errors.error) R.comp + ) + R.res + (** [create dbg uuid name attributes endpoints enabled] notifies the + forwarder that an Observer with [uuid] has been created. The subsequent + parameters are the fields the Observer was created with. *) + + val destroy : (debug_info -> string -> (unit, Errors.error) R.comp) R.res + (** [destroy dbg uuid] notifies the forwarder that an Observer with [uuid] + has been destroyed. *) + + val set_enabled : + (debug_info -> string -> bool -> (unit, Errors.error) R.comp) R.res + (** [set_enabled dbg uuid enabled] notifies the fowarder that the Observer + with [uuid] has had its enabled field set to [enabled]. *) + + val set_attributes : + ( debug_info + -> string + -> (string * string) list + -> (unit, Errors.error) R.comp + ) + R.res + (** [set_attributes dbg uuid attributes] notifies the fowarder that the + Observer with [uuid] has had its attributes field set to [attributes]. *) + + val set_endpoints : + (debug_info -> string -> string list -> (unit, Errors.error) R.comp) R.res + (** [set_endpoints dbg uuid endpoints] notifies the fowarder that the Observer + with [uuid] has had its endpoints field set to [endpoints]. *) + + val init : (debug_info -> (unit, Errors.error) R.comp) R.res + (** [init dbg] notifies the forwarder that it should perform any tracing + initialisation. *) + + val set_trace_log_dir : + (debug_info -> string -> (unit, Errors.error) R.comp) R.res + (** [set_trace_log_dir dbg dir] notifies the fowarder that the trace_log_dir + has been set to [dir]. *) + + val set_export_interval : + (debug_info -> float -> (unit, Errors.error) R.comp) R.res + (** [set_export_interval dbg interval] notifies the fowarder that the interval + between trace exports has been set to [interval]. *) + + val set_export_chunk_size : + (debug_info -> int -> (unit, Errors.error) R.comp) R.res + (** [set_export_chunk_size dbg size] notifies the fowarder that the max size + of each chunk of finished spans exported has been set to [size]. *) + + val set_max_spans : (debug_info -> int -> (unit, Errors.error) R.comp) R.res + (** [set_max_spans dbg spans] notifies the fowarder that the max number of + spans has been set to [spans]. *) + + val set_max_traces : (debug_info -> int -> (unit, Errors.error) R.comp) R.res + (** [set_max_traces dbg traces] notifies the fowarder that the max number of + traces has been set to [traces]. *) + + val set_max_depth : (debug_info -> int -> (unit, Errors.error) R.comp) R.res + (** [set_max_depth dbg depth] notifies the fowarder that the max depth of + a span in a trace has been set to [depth]. *) + + val set_max_file_size : + (debug_info -> int -> (unit, Errors.error) R.comp) R.res + (** [set_max_file_size dbg file_size] notifies the fowarder that the max file + size has been set to [file_size]. *) + + val set_host_id : (debug_info -> string -> (unit, Errors.error) R.comp) R.res + (** [set_host_id dbg host_id] notifies the fowarder that the host to be traced + has been set to [host_id]. *) + + val set_compress_tracing_files : + (debug_info -> bool -> (unit, Errors.error) R.comp) R.res + (** [set_compress_tracing_files dbg enabled] notifies the fowarder that the + compression of tracing files has been set to [enabled]. *) +end + +(** A Server_impl module will define how the Server responds to ObserverAPI calls *) +module type Server_impl = sig + type context = unit + + val create : + context + -> dbg:debug_info + -> uuid:string + -> name_label:string + -> attributes:(string * string) list + -> endpoints:string list + -> enabled:bool + -> unit + + val destroy : context -> dbg:debug_info -> uuid:string -> unit + + val set_enabled : + context -> dbg:debug_info -> uuid:string -> enabled:bool -> unit + + val set_attributes : + context + -> dbg:debug_info + -> uuid:string + -> attributes:(string * string) list + -> unit + + val set_endpoints : + context -> dbg:debug_info -> uuid:string -> endpoints:string list -> unit + + val init : context -> dbg:debug_info -> unit + + val set_trace_log_dir : context -> dbg:debug_info -> dir:string -> unit + + val set_export_interval : context -> dbg:debug_info -> interval:float -> unit + + val set_export_chunk_size : context -> dbg:debug_info -> size:int -> unit + + val set_max_spans : context -> dbg:debug_info -> spans:int -> unit + + val set_max_traces : context -> dbg:debug_info -> traces:int -> unit + + val set_max_depth : context -> dbg:debug_info -> depth:int -> unit + + val set_max_file_size : context -> dbg:debug_info -> file_size:int -> unit + + val set_host_id : context -> dbg:debug_info -> host_id:string -> unit + + val set_compress_tracing_files : + context -> dbg:debug_info -> enabled:bool -> unit +end + +(** A Server for receiving ObserverAPI calls *) +module Server : functor (_ : Server_impl) () -> sig + module S : sig + val create : + ( debug_info + -> string + -> string + -> (string * string) list + -> string list + -> bool + -> unit + ) + -> unit + + val destroy : (debug_info -> string -> unit) -> unit + + val set_enabled : (debug_info -> string -> bool -> unit) -> unit + + val set_attributes : + (debug_info -> string -> (string * string) list -> unit) -> unit + + val set_endpoints : (debug_info -> string -> string list -> unit) -> unit + + val init : (debug_info -> unit) -> unit + + val set_trace_log_dir : (debug_info -> string -> unit) -> unit + + val set_export_interval : (debug_info -> float -> unit) -> unit + + val set_export_chunk_size : (debug_info -> int -> unit) -> unit + + val set_max_spans : (debug_info -> int -> unit) -> unit + + val set_max_traces : (debug_info -> int -> unit) -> unit + + val set_max_depth : (debug_info -> int -> unit) -> unit + + val set_max_file_size : (debug_info -> int -> unit) -> unit + + val set_host_id : (debug_info -> string -> unit) -> unit + + val set_compress_tracing_files : (debug_info -> bool -> unit) -> unit + end + + val process : Rpc.call -> Rpc.response +end + +(** A client for sending ObserverAPI calls to the above queue_name *) +module Client : sig + val create : + debug_info + -> string + -> string + -> (string * string) list + -> string list + -> bool + -> unit + + val destroy : debug_info -> string -> unit + + val set_enabled : debug_info -> string -> bool -> unit + + val set_attributes : debug_info -> string -> (string * string) list -> unit + + val set_endpoints : debug_info -> string -> string list -> unit + + val init : debug_info -> unit + + val set_trace_log_dir : debug_info -> string -> unit + + val set_export_interval : debug_info -> float -> unit + + val set_export_chunk_size : debug_info -> int -> unit + + val set_max_spans : debug_info -> int -> unit + + val set_max_traces : debug_info -> int -> unit + + val set_max_depth : debug_info -> int -> unit + + val set_max_file_size : debug_info -> int -> unit + + val set_host_id : debug_info -> string -> unit + + val set_compress_tracing_files : debug_info -> bool -> unit +end diff --git a/ocaml/xapi-idl/lib/observer_skeleton.ml b/ocaml/xapi-idl/lib/observer_skeleton.ml new file mode 100644 index 0000000000..59df66d246 --- /dev/null +++ b/ocaml/xapi-idl/lib/observer_skeleton.ml @@ -0,0 +1,52 @@ +(* + * 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. + *) +[@@@ocaml.warning "-27"] + +let unimplemented x = + raise Observer_helpers.(Observer_error (Errors.Unimplemented x)) + +module Observer = struct + type context = unit + + let create ctx ~dbg ~uuid ~name_label ~attributes ~endpoints ~enabled = + unimplemented __FUNCTION__ + + let destroy ctx ~dbg ~uuid = unimplemented __FUNCTION__ + + let set_enabled ctx ~dbg ~uuid ~enabled = unimplemented __FUNCTION__ + + let set_attributes ctx ~dbg ~uuid ~attributes = unimplemented __FUNCTION__ + + let set_endpoints ctx ~dbg ~uuid ~endpoints = unimplemented __FUNCTION__ + + let init ctx ~dbg = unimplemented __FUNCTION__ + + let set_trace_log_dir ctx ~dbg ~dir = unimplemented __FUNCTION__ + + let set_export_interval ctx ~dbg ~interval = unimplemented __FUNCTION__ + + let set_export_chunk_size ctx ~dbg ~size = unimplemented __FUNCTION__ + + let set_max_spans ctx ~dbg ~spans = unimplemented __FUNCTION__ + + let set_max_traces ctx ~dbg ~traces = unimplemented __FUNCTION__ + + let set_max_depth ctx ~dbg ~depth = unimplemented __FUNCTION__ + + let set_max_file_size ctx ~dbg ~file_size = unimplemented __FUNCTION__ + + let set_host_id ctx ~dbg ~host_id = unimplemented __FUNCTION__ + + let set_compress_tracing_files ctx ~dbg ~enabled = unimplemented __FUNCTION__ +end diff --git a/ocaml/xapi-idl/lib/observer_skeleton.mli b/ocaml/xapi-idl/lib/observer_skeleton.mli new file mode 100644 index 0000000000..2b914ada71 --- /dev/null +++ b/ocaml/xapi-idl/lib/observer_skeleton.mli @@ -0,0 +1,50 @@ +(** This module provides dummy implementations for each Observer function. + These are intended to be used to fill in the functions that the module will + not ever use, as they will raise an Unimplemented error if called *) +module Observer : sig + type context = unit + + val create : + context + -> dbg:string + -> uuid:string + -> name_label:string + -> attributes:(string * string) list + -> endpoints:string list + -> enabled:bool + -> unit + + val destroy : context -> dbg:string -> uuid:string -> unit + + val set_enabled : context -> dbg:string -> uuid:string -> enabled:bool -> unit + + val set_attributes : + context + -> dbg:string + -> uuid:string + -> attributes:(string * string) list + -> unit + + val set_endpoints : + context -> dbg:string -> uuid:string -> endpoints:string list -> unit + + val init : context -> dbg:string -> unit + + val set_trace_log_dir : context -> dbg:string -> dir:string -> unit + + val set_export_interval : context -> dbg:string -> interval:float -> unit + + val set_export_chunk_size : context -> dbg:string -> size:int -> unit + + val set_max_spans : context -> dbg:string -> spans:int -> unit + + val set_max_traces : context -> dbg:string -> traces:int -> unit + + val set_max_depth : context -> dbg:string -> depth:int -> unit + + val set_max_file_size : context -> dbg:string -> file_size:int -> unit + + val set_host_id : context -> dbg:string -> host_id:string -> unit + + val set_compress_tracing_files : context -> dbg:string -> enabled:bool -> unit +end diff --git a/ocaml/xapi-idl/lib/updates.ml b/ocaml/xapi-idl/lib/updates.ml index 93904f2b65..f6420da683 100644 --- a/ocaml/xapi-idl/lib/updates.ml +++ b/ocaml/xapi-idl/lib/updates.ml @@ -66,6 +66,7 @@ functor ) let inject_barrier id filterfn t = + let filterfn key _ = filterfn key in ( { map= t.map ; barriers= diff --git a/ocaml/xapi-idl/lib/updates.mli b/ocaml/xapi-idl/lib/updates.mli index a054c5581d..9b678a2883 100644 --- a/ocaml/xapi-idl/lib/updates.mli +++ b/ocaml/xapi-idl/lib/updates.mli @@ -64,7 +64,7 @@ module Updates : functor (Interface : INTERFACE) -> sig (* [inject_barrier n p t] Inject a barrier identified by [n] into [t]. The barrier will contain a snapshot of all current updates that match the predicate [p]. *) - val inject_barrier : int -> (Interface.Dynamic.id -> int -> bool) -> t -> unit + val inject_barrier : int -> (Interface.Dynamic.id -> bool) -> t -> unit (* Removes a barrier *) val remove_barrier : int -> t -> unit diff --git a/ocaml/xapi-idl/lib/xcp_client.ml b/ocaml/xapi-idl/lib/xcp_client.ml index 3ea0006b59..a7ebd1f996 100644 --- a/ocaml/xapi-idl/lib/xcp_client.ml +++ b/ocaml/xapi-idl/lib/xcp_client.ml @@ -38,10 +38,35 @@ let switch_rpc ?timeout queue_name string_of_call response_of_string = get_ok (Message_switch_unix.Protocol_unix.Client.connect ~switch:!switch_path ()) in - fun call -> + fun (call : Rpc.call) -> + let _span_parent = + call.params + |> List.find_map (function Rpc.Dict kv_list -> Some kv_list | _ -> None) + |> Fun.flip Option.bind + (List.find_map (function + | "debug_info", Rpc.String debug_info -> + let di = debug_info |> Debug_info.of_string in + di.tracing + | _ -> + None + ) + ) + in + let rpc_service = "message_switch" in + Tracing.with_tracing + ~attributes: + [ + ("rpc.system", "ocaml-rpc") + ; ("rpc.service", rpc_service) + ; ("server.address", queue_name) + ; ("rpc.method", call.name) + ] + ~parent:_span_parent + ~name:(rpc_service ^ "/" ^ call.name) + @@ fun _span_parent -> response_of_string (get_ok - (Message_switch_unix.Protocol_unix.Client.rpc ~t ?timeout + (Message_switch_unix.Protocol_unix.Client.rpc ?_span_parent ~t ?timeout ~queue:queue_name ~body:(string_of_call call) () ) ) @@ -165,3 +190,21 @@ let binary_rpc string_of_call response_of_string ?(srcstr = "unset") let json_binary_rpc = binary_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string + +let rec retry_econnrefused f = + try f () with + | Unix.Unix_error (Unix.ECONNREFUSED, "connect", _) -> + (* debug "Caught ECONNREFUSED; retrying in 5s"; *) + Thread.delay 5. ; retry_econnrefused f + | e -> + (* error "Caught %s: does the service need restarting?" + (Printexc.to_string e); *) + raise e + +let retry_and_switch_rpc call ~use_switch ~queue_name ~dststr ~uri = + retry_econnrefused (fun () -> + if use_switch then + json_switch_rpc queue_name call + else + xml_http_rpc ~srcstr:(get_user_agent ()) ~dststr uri call + ) diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index 817825c44f..8250842689 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -168,7 +168,7 @@ let setify = This needs to be as small as possible to reduce latency. Too small values reduce performance due to context switching overheads - + 4ms = 1/HZ in Dom0 seems like a good default, a better value will be written by a boot time service. *) @@ -357,7 +357,7 @@ let command_of ?(name = Sys.argv.(0)) ?(version = "unknown") ; `S _common_options ; `P "These options are common to all services." ; `S "BUGS" - ; `P "Check bug reports at http://github.com/xapi-project/xcp-idl" + ; `P "Check bug reports at http://github.com/xapi-project/xen-api" ] in Cmd.v diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index 93a2496617..87dc6df26e 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -4,7 +4,7 @@ (name test_lib) (modules idl_test_common) (libraries - (re_export alcotest) xapi-idl (re_export rpclib.core) rpclib.json rpclib.xml result) + (re_export alcotest) xapi-idl (re_export rpclib.core) rpclib.json rpclib.xml result unix) (wrapped false) ) @@ -13,6 +13,7 @@ (modules guard_interfaces_test) (libraries test_lib + unix xapi-idl.guard.privileged xapi-idl.guard.varstored ) @@ -52,6 +53,7 @@ rpclib.xml test_lib threads.posix + unix xapi-idl xapi-idl.cluster xapi-idl.rrd diff --git a/ocaml/xapi-idl/lib_test/updates_test.ml b/ocaml/xapi-idl/lib_test/updates_test.ml index 66c5f09450..790e72854c 100644 --- a/ocaml/xapi-idl/lib_test/updates_test.ml +++ b/ocaml/xapi-idl/lib_test/updates_test.ml @@ -84,7 +84,7 @@ let test_inject_barrier () = let u = M.empty scheduler in M.add update_a u ; M.add update_b u ; - M.inject_barrier 1 (fun _ _ -> true) u ; + M.inject_barrier 1 (fun _ -> true) u ; M.add update_a u ; M.add update_c u ; let barriers, updates, _id = M.get "dbg" None (Some 1) u in @@ -107,7 +107,7 @@ let test_remove_barrier () = let u = M.empty scheduler in M.add update_a u ; M.add update_b u ; - M.inject_barrier 1 (fun _ _ -> true) u ; + M.inject_barrier 1 (fun _ -> true) u ; M.add update_a u ; M.add update_c u ; M.remove_barrier 1 u ; @@ -125,7 +125,7 @@ let test_inject_barrier_rpc () = let u = M.empty scheduler in M.add update_a u ; M.add update_b u ; - M.inject_barrier 1 (fun _ _ -> true) u ; + M.inject_barrier 1 (fun _ -> true) u ; M.add update_a u ; M.add update_c u ; let barriers, updates, _id = M.get "dbg" None (Some 1) u in @@ -175,7 +175,7 @@ let test_filter () = let test_dump () = let u = M.empty scheduler in M.add update_a u ; - M.inject_barrier 1 (fun _ _ -> true) u ; + M.inject_barrier 1 (fun _ -> true) u ; let dump = M.Dump.make u in let dumped_rpc = M.Dump.rpc_of_dump dump in let expected_rpc = diff --git a/ocaml/xapi-idl/memory/cli-help.t b/ocaml/xapi-idl/memory/cli-help.t new file mode 100644 index 0000000000..ff85cda4f0 --- /dev/null +++ b/ocaml/xapi-idl/memory/cli-help.t @@ -0,0 +1,80 @@ + $ ./memory_cli.exe --help=plain + NAME + memory_cli - A CLI for the memory API. This allows scripting of the + squeeze daemon for testing and debugging. This tool is not intended to + be used as an end user tool + + SYNOPSIS + memory_cli [COMMAND] … + + COMMANDS + balance_memory [OPTION]… string + Forces a rebalance of the hosts memory. Blocks until the system is + in a stable state. + + delete_reservation [OPTION]… string string reservation_id + Deletes a reservation. Note that memory rebalancing is not done + synchronously after the operation has completed. + + get_diagnostics [OPTION]… string + Gets diagnostic information from the server + + get_domain_zero_policy [OPTION]… string + Gets the ballooning policy for domain zero. + + get_host_initial_free_memory [OPTION]… string + Gets the amount of initial free memory in a host + + get_host_reserved_memory [OPTION]… string + Gets the amount of reserved memory in a host. This is the lower + limit of memory that squeezed will ensure remains unused by any + domain or reservation. + + login [OPTION]… string string + Logs into the squeeze daemon. Any reservations previously made + with the specified service name not yet associated with a domain + will be removed. + + query_reservation_of_domain [OPTION]… string string int + Queries the reservation_id associated with a domain + + reserve_memory [OPTION]… string string int64 + [reserve_memory dbg session size] reserves memory for a domain. If + necessary, other domains will be ballooned down to ensure [size] + is available. The call returns a reservation_id that can later be + transferred to a domain. + + reserve_memory_range [OPTION]… string string int64 int64 + [reserve_memory_range dbg session min max] reserves memory for a + domain. If necessary, other domains will be ballooned down to + ensure enough memory is available. The amount of memory will be + between [min] and [max] according to the policy in operation. The + call returns a reservation_id and the actual memory amount that + can later be transferred to a domain. + + transfer_reservation_to_domain [OPTION]… string string + reservation_id int + Transfers a reservation to a domain. This is called when the + domain has been created for the VM for which the reservation was + initially made. + + COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + memory_cli exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + diff --git a/ocaml/xapi-idl/memory/dune b/ocaml/xapi-idl/memory/dune index f0f70e0a69..7df6724a29 100644 --- a/ocaml/xapi-idl/memory/dune +++ b/ocaml/xapi-idl/memory/dune @@ -25,8 +25,6 @@ xapi-idl.memory )) -(rule - (alias runtest) - (deps (:x memory_cli.exe)) +(cram (package xapi-idl) - (action (run %{x} --help=plain))) + (deps memory_cli.exe)) diff --git a/ocaml/xapi-idl/network/cli-help.t b/ocaml/xapi-idl/network/cli-help.t new file mode 100644 index 0000000000..0fda87d573 --- /dev/null +++ b/ocaml/xapi-idl/network/cli-help.t @@ -0,0 +1,159 @@ + $ ./network_cli.exe --help=plain + NAME + network_cli - A CLI for the network API. This allows scripting of the + xcp-networkd daemon for testing and debugging. This tool is not + intended to be used as an end user tool + + SYNOPSIS + network_cli [COMMAND] … + + COMMANDS + Network.Bridge.add_port [OPTION]… string bridge name interfaces + Add port + + Network.Bridge.create [OPTION]… string name + Create bridge + + Network.Bridge.destroy [OPTION]… string force name + Destroy bridge + + Network.Bridge.get_all [OPTION]… string + Get all bridges + + Network.Bridge.get_all_bonds [OPTION]… string from_cache + get all bonds + + Network.Bridge.get_all_ports [OPTION]… string from_cache + Get all ports + + Network.Bridge.get_interfaces [OPTION]… string name + Get interfaces + + Network.Bridge.get_kind [OPTION]… string + Get backend kind + + Network.Bridge.get_physical_interfaces [OPTION]… string name + Get physical interfaces + + Network.Bridge.make_config [OPTION]… string conservative config + Make bridge configuration + + Network.Bridge.remove_port [OPTION]… string bridge name + Remove port + + Network.Bridge.set_persistent [OPTION]… string name value + Make bridge to persistent or not + + Network.Interface.bring_down [OPTION]… string name + Bring PIF down + + Network.Interface.exists [OPTION]… string name + Check interface existence + + Network.Interface.get_all [OPTION]… string + Get list of all interface names + + Network.Interface.get_capabilities [OPTION]… string name + Get capabilities on the interface + + Network.Interface.get_dns [OPTION]… string name + Get DNS + + Network.Interface.get_interface_positions [OPTION]… string + Get list of interface names and their positions + + Network.Interface.get_ipv4_addr [OPTION]… string name + Get list of IPv4 addresses of the interface + + Network.Interface.get_ipv4_gateway [OPTION]… string name + Get IPv4 gateway + + Network.Interface.get_ipv6_addr [OPTION]… string name + Get IPv6 address + + Network.Interface.get_ipv6_gateway [OPTION]… string name + Get IPv6 gateway + + Network.Interface.get_mac [OPTION]… string name + Get Mac address of the interface + + Network.Interface.get_mtu [OPTION]… string name + Get MTU + + Network.Interface.get_pci_bus_path [OPTION]… string name + Get PCI bus path of the interface + + Network.Interface.has_vlan [OPTION]… string name vlan + Check whether interface has vlan + + Network.Interface.is_connected [OPTION]… string name + Check whether interface is connected + + Network.Interface.is_physical [OPTION]… string name + Check whether interface is physical + + Network.Interface.is_up [OPTION]… string name + Check whether the interface is up + + Network.Interface.make_config [OPTION]… string conservative config + Make interface configuration + + Network.Interface.set_ipv4_conf [OPTION]… string name ipv4 + Set IPv4 configuration + + Network.Interface.set_persistent [OPTION]… string name value + Make PIF to persistent or not + + Network.PVS_proxy.configure_site [OPTION]… string t + Configure site + + Network.PVS_proxy.remove_site [OPTION]… string string + Remove site + + Network.Sriov.disable [OPTION]… string name + Disable SR-IOV + + Network.Sriov.enable [OPTION]… string name + Enable SR-IOV + + Network.Sriov.make_vf_config [OPTION]… string address sriov_pci_t + Make SR-IOV vf config + + Network.clear_state [OPTION]… + Clear configuration state then lock the writing of the state to + disk + + Network.reset_state [OPTION]… + Reset configuration state + + Network.set_dns_interface [OPTION]… string name + Set dns interface + + Network.set_gateway_interface [OPTION]… string name + Set gateway interface + + Network.sync_state [OPTION]… + Allow for the config state to be written to disk then perform a + write + + COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + network_cli exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + + diff --git a/ocaml/xapi-idl/network/dune b/ocaml/xapi-idl/network/dune index a9a4869945..77b17709a7 100644 --- a/ocaml/xapi-idl/network/dune +++ b/ocaml/xapi-idl/network/dune @@ -8,9 +8,11 @@ rpclib.json rresult threads.posix + unix xapi-idl xapi-log ipaddr + macaddr ) (wrapped false) (preprocess (pps ppx_deriving_rpc))) @@ -21,7 +23,7 @@ (modules network_cli) (libraries cmdliner - + rpclib.cmdliner rpclib.core rpclib.markdown @@ -29,8 +31,6 @@ xapi-idl.network )) -(rule - (alias runtest) - (deps (:x network_cli.exe)) +(cram (package xapi-idl) - (action (run %{x} --help=plain))) + (deps network_cli.exe)) diff --git a/ocaml/xapi-idl/network/network_interface.ml b/ocaml/xapi-idl/network/network_interface.ml index 2f3368fc13..e604a8e485 100644 --- a/ocaml/xapi-idl/network/network_interface.ml +++ b/ocaml/xapi-idl/network/network_interface.ml @@ -81,6 +81,34 @@ module Unix = struct } end +module Macaddr = struct + include Macaddr + + let typ_of = + Rpc.Types.Abstract + { + aname= "macaddr" + ; test_data= [Macaddr.of_string_exn "ca:fe:ba:be:ee:ee"] + ; rpc_of= (fun t -> Rpc.String (Macaddr.to_octets t)) + ; of_rpc= + (function + | Rpc.String s -> + Macaddr.of_octets s + |> Result.map_error (fun (`Msg e) -> + `Msg (Printf.sprintf "typ_of_macaddr: %s" e) + ) + | r -> + Error + (`Msg + (Printf.sprintf + "typ_of_macaddr: expectd rpc string but got %s" + (Rpc.to_string r) + ) + ) + ) + } +end + (** {2 Types} *) type debug_info = string [@@deriving rpcty] @@ -91,6 +119,8 @@ type port = string [@@deriving rpcty] type bridge = string [@@deriving rpcty] +type mac_address = Macaddr.t [@@deriving rpcty] + (* rpcty cannot handle polymorphic variant, so change the definition to variant *) type dhcp_options = Set_gateway | Set_dns [@@deriving rpcty] @@ -158,7 +188,10 @@ type interface_config_t = { ; ipv6_conf: ipv6 [@default None6] ; ipv6_gateway: Unix.inet_addr option [@default None] ; ipv4_routes: ipv4_route_t list [@default []] - ; dns: Unix.inet_addr list * string list [@default [], []] + ; dns: (Unix.inet_addr list * string list) option [@default None] + (** the list + of nameservers and domains to persist in /etc/resolv.conf. Must be None when + using a DHCP mode *) ; mtu: int [@default 1500] ; ethtool_settings: (string * string) list [@default []] ; ethtool_offload: (string * string) list [@default [("lro", "off")]] @@ -184,11 +217,21 @@ type bridge_config_t = { } [@@deriving rpcty] +type ordered_iface = { + name: iface + ; position: int + ; mac: mac_address + ; pci: Xcp_pci.address + ; present: bool +} +[@@deriving rpcty] + type config_t = { interface_config: (iface * interface_config_t) list [@default []] ; bridge_config: (bridge * bridge_config_t) list [@default []] ; gateway_interface: iface option [@default None] ; dns_interface: iface option [@default None] + ; interface_order: ordered_iface list option [@default None] } [@@deriving rpcty] @@ -200,7 +243,7 @@ let default_interface = ; ipv6_conf= None6 ; ipv6_gateway= None ; ipv4_routes= [] - ; dns= ([], []) + ; dns= None ; mtu= 1500 ; ethtool_settings= [] ; ethtool_offload= [("lro", "off")] @@ -226,6 +269,7 @@ let default_config = ; bridge_config= [] ; gateway_interface= None ; dns_interface= None + ; interface_order= None } (** {2 Configuration manipulation} *) @@ -379,6 +423,18 @@ module Interface_API (R : RPC) = struct ["Get list of all interface names"] (debug_info_p @-> unit_p @-> returning iface_list_p err) + let get_interface_positions = + let module T = struct + type _iface_position_list_t = (iface * int) list [@@deriving rpcty] + end in + let iface_position_list_p = + Param.mk ~description:["interface postion list"] + T._iface_position_list_t + in + declare "Interface.get_interface_positions" + ["Get list of interface names and their positions"] + (debug_info_p @-> unit_p @-> returning iface_position_list_p err) + let exists = let result = Param.mk ~description:["existence"] Types.bool in declare "Interface.exists" diff --git a/ocaml/xapi-idl/rrd/cli-help.t b/ocaml/xapi-idl/rrd/cli-help.t new file mode 100644 index 0000000000..1a15779d7f --- /dev/null +++ b/ocaml/xapi-idl/rrd/cli-help.t @@ -0,0 +1,188 @@ + $ ./rrd_cli.exe --help=plain + NAME + rrd-cli - A CLI for the Db monitoring API. This allows scripting of + the Rrd daemon for testing and debugging. This tool is not intended to + be used as an end user tool + + SYNOPSIS + rrd-cli [COMMAND] … + + COMMANDS + Deprecated.load_rrd [OPTION]… uuid timescale + Deprecated call. + + HA.disable [OPTION]… + Disables the HA metrics. + + HA.enable_and_update [OPTION]… statefile_latencies heartbeat_latency + xapi_latency + Enables the gathering of HA metrics, a built-in function of + xcp-rrdd. + + Plugin.Local.deregister [OPTION]… uid + Deregisters a plugin by uid + + Plugin.Local.next_reading [OPTION]… uid + Returns the number of seconds until the next reading will be + taken. + + Plugin.Local.register [OPTION]… uid info protocol + [Plugin.Local.register uid info protocol] registers a plugin as a + source of a set of data-sources. [uid] is a unique identifier for + the plugin, often the name of the plugin. [info] is the RRD + frequency, and [protocol] specifies whether the plugin will be + using V1 or V2 of the protocol. + + Plugin.deregister [OPTION]… uid + Preserved for backwards compatibility. Deregesters a local plugin. + + Plugin.get_header [OPTION]… + Returns header string. This string should be copied exactly to the + start of the shared memory containing the data source + + Plugin.get_path [OPTION]… uid + Returns path in the local filesystem to place the data source file + + Plugin.next_reading [OPTION]… uid + Returns the time until the next reading. + + Plugin.register [OPTION]… uid frequency + Preserved for backwards compatibility. Equivalent to a Local + plugin registration with V1 protocol. + + add_host_ds [OPTION]… ds_name + Adds a host data source to the host RRD. This causes the data + source to be recorded if it wasn't a default data source. + + add_sr_ds [OPTION]… sr_uuid ds_name + Adds an SR data source to the SR RRD. This causes the data source + to be recorded if it wasn't a default data source. + + add_vm_ds [OPTION]… vm_uuid domid ds_name + Adds a VM data source to the VM RRD. This causes the data source + to be recorded if it wasn't a default data source. + + archive_rrd [OPTION]… vm_uuid + Sends the VM RRD either to local disk or the remote address if + specified, and removes it from memory. Called on VM + shutdown/suspend. + + archive_sr_rrd [OPTION]… sr_uuid + Saves the SR RRD to the local disk. Returns the path to the saved + RRD so it can be copied onto the SR before it is detached. + + backup_rrds [OPTION]… + Backs up RRD data to disk. This should be done periodically to + ensure that if the host crashes we don't lose too much data. + + forget_host_ds [OPTION]… ds_name + Forgets the recorded archives for the named data source. Note that + if the data source is marked as default, new data coming in will + cause the archive to be recreated. + + forget_sr_ds [OPTION]… sr_uuid ds_name + Forgets the recorded archives for the named SR data source. Note + that if the data source is marked as default, new data coming in + will cause the archive to be recreated. + + forget_vm_ds [OPTION]… vm_uuid ds_name + Forgets the recorded archives for the named VM data source. Note + that if the data source is marked as default, new data coming in + will cause the archive to be recreated. + + has_vm_rrd [OPTION]… vm_uuid + Returns `true` if xcp-rrdd has an RRD for the specified VM in + memory + + migrate_rrd [OPTION]… remote_address vm_uuid host_uuid + Migrate_push - used by the migrate code to push an RRD directly to + a remote host without going via the master. If the host is on a + different pool, you must pass both the remote_address and + session_id parameters. + + push_rrd_local [OPTION]… vm_uuid domid + Loads a VM RRD from local storage, associates it with the + specified domid, and starts recording all data sources related to + the VM to that RRD + + push_rrd_remote [OPTION]… vm_uuid remote_address + Loads a VM RRD from local storage and pushes it to a remote host + + push_sr_rrd [OPTION]… sr_uuid path + Loads the RRD from the path specified on the local disk. + Overwrites any RRD already in memory for the SR. Data sources will + subsequently be recorded to this RRD. + + query_host_ds [OPTION]… ds_name + Returns the current value of the named host data source. Note this + returns the raw data source value, not the smoothed last value of + the RRA. + + query_possible_host_dss [OPTION]… + Returns list of possible host DSs. This will include data sources + not currently being recorded into archives. + + query_possible_sr_dss [OPTION]… sr_uuid + Returns list of possible SR DSs. This will include data sources + not currently being recorded into archives. + + query_possible_vm_dss [OPTION]… vm_uuid + Returns list of possible VM DSs. This will include data sources + not currently being recorded into archives. + + query_sr_ds [OPTION]… sr_uuid ds_name + Returns the current value of the named VM data source. Note this + returns the raw data source value, not the smoothed last value of + the RRA. + + query_vm_ds [OPTION]… vm_uuid ds_name + Returns the current value of the named VM data source. Note this + returns the raw data source value, not the smoothed last value of + the RRA. + + remove_rrd [OPTION]… uuid + Removes a VM RRD from the local filesystem, if it exists. + + save_rrds [OPTION]… + Backs up RRD data to disk on localhost. This should be done + periodically to ensure that if the host crashes we don't lose too + much data. + + send_host_rrd_to_master [OPTION]… master_address + Called on host shutdown/reboot to send the Host RRD to the master + for backup. + + set_cache_sr [OPTION]… sr_uuid + Sets the uuid of the cache SR. If this is set, statistics about + the usage of the cache will be recorded into the host SR. + + unset_cache_sr [OPTION]… + Unsets the cache_sr. No futher data will be gathered about cache + usage, but existing archive data will not be deleted. + + update_use_min_max [OPTION]… value + Set the value of the `use_min_max` variable. If this is `true`, + when creating a new RRD, archives for the minimum and maximum + observed values will be created alongside the standard archive of + average values + + COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + rrd-cli exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + diff --git a/ocaml/xapi-idl/rrd/dune b/ocaml/xapi-idl/rrd/dune index f7b2a8e7b7..e0e8693c13 100644 --- a/ocaml/xapi-idl/rrd/dune +++ b/ocaml/xapi-idl/rrd/dune @@ -49,7 +49,7 @@ (modes exe) (libraries cmdliner - + rpclib.cmdliner rpclib.core rpclib.markdown @@ -57,9 +57,6 @@ xapi-idl.rrd )) -(rule - (alias runtest) - (deps (:x rrd_cli.exe)) +(cram (package xapi-tools) - (action (run %{x} --help=plain))) - + (deps rrd_cli.exe)) diff --git a/ocaml/xapi-idl/rrd/rrd_client.ml b/ocaml/xapi-idl/rrd/rrd_client.ml index abb12a118d..08a9b731f7 100644 --- a/ocaml/xapi-idl/rrd/rrd_client.ml +++ b/ocaml/xapi-idl/rrd/rrd_client.ml @@ -13,26 +13,12 @@ *) open Rrd_interface -open Xcp_client - -let rec retry_econnrefused f = - try f () with - | Unix.Unix_error (Unix.ECONNREFUSED, "connect", _) -> - (* debug "Caught ECONNREFUSED; retrying in 5s"; *) - Thread.delay 5. ; retry_econnrefused f - | e -> - (* error "Caught %s: does the rrd service need restarting?" - (Printexc.to_string e); *) - raise e +(* TODO: use_switch=false as the message switch doesn't handle raw HTTP very well *) let rpc call = - retry_econnrefused (fun () -> - (* TODO: the message switch doesn't handle raw HTTP very well *) - if (* !use_switch *) false then - json_switch_rpc !queue_name call - else - xml_http_rpc ~srcstr:(get_user_agent ()) ~dststr:"rrd" Rrd_interface.uri - call + Xcp_client.( + retry_and_switch_rpc call ~use_switch:false ~queue_name:!queue_name + ~dststr:"rrd" ~uri ) module Client = RPC_API (Idl.Exn.GenClient (struct let rpc = rpc end)) diff --git a/ocaml/xapi-idl/rrd/rrd_interface.ml b/ocaml/xapi-idl/rrd/rrd_interface.ml index 1cfa1e39a2..066912eacf 100644 --- a/ocaml/xapi-idl/rrd/rrd_interface.ml +++ b/ocaml/xapi-idl/rrd/rrd_interface.ml @@ -412,18 +412,6 @@ module RPC_API (R : RPC) = struct ] (value_p @-> returning unit_p rrd_err) - let update_vm_memory_target = - let target_p = - Param.mk ~name:"target" ~description:["VM memory target"] Types.int64 - in - declare "update_vm_memory_target" - [ - "Sets the `memory_target` value for a VM. This is called by xapi when \ - it is told by" - ; "xenopsd that squeezed has changed the target for a VM." - ] - (domid_p @-> target_p @-> returning unit_p rrd_err) - let set_cache_sr = declare "set_cache_sr" [ diff --git a/ocaml/xapi-idl/storage/dune b/ocaml/xapi-idl/storage/dune index f8fabe1b08..0f1a487ff1 100644 --- a/ocaml/xapi-idl/storage/dune +++ b/ocaml/xapi-idl/storage/dune @@ -39,6 +39,7 @@ (libraries rpclib.core threads.posix + unix xapi-idl xapi-idl.storage.interface clock @@ -53,7 +54,7 @@ (libraries alcotest cmdliner - + unix xapi-idl xapi-idl.storage xapi-idl.storage.interface diff --git a/ocaml/xapi-idl/storage/storage_client.ml b/ocaml/xapi-idl/storage/storage_client.ml index b66636daf6..eeb0e76517 100644 --- a/ocaml/xapi-idl/storage/storage_client.ml +++ b/ocaml/xapi-idl/storage/storage_client.ml @@ -13,25 +13,11 @@ *) open Storage_interface -open Xcp_client -let rec retry_econnrefused f = - try f () with - | Unix.Unix_error (Unix.ECONNREFUSED, "connect", _) -> - (* debug "Caught ECONNREFUSED; retrying in 5s"; *) - Thread.delay 5. ; retry_econnrefused f - | e -> - (* error "Caught %s: does the storage service need restarting?" - (Printexc.to_string e); *) - raise e - -module Client = Storage_interface.StorageAPI (Idl.Exn.GenClient (struct +module Client = StorageAPI (Idl.Exn.GenClient (struct let rpc call = - retry_econnrefused (fun () -> - if !use_switch then - json_switch_rpc !queue_name call - else - xml_http_rpc ~srcstr:(get_user_agent ()) ~dststr:"storage" - Storage_interface.uri call + Xcp_client.( + retry_and_switch_rpc call ~use_switch:!use_switch ~queue_name:!queue_name + ~dststr:"storage" ~uri ) end)) diff --git a/ocaml/xapi-idl/storage/storage_interface.ml b/ocaml/xapi-idl/storage/storage_interface.ml index 28e3752d8c..eaabacc9e8 100644 --- a/ocaml/xapi-idl/storage/storage_interface.ml +++ b/ocaml/xapi-idl/storage/storage_interface.ml @@ -175,6 +175,9 @@ let parse_nbd_uri nbd = | _ -> fail () +let parse_nbd_uri_opt nbd = + try Some (parse_nbd_uri nbd) with Failure _e -> None + (** Separates the implementations of the given backend returned from the VDI.attach2 SMAPIv2 call based on their type *) let implementations_of_backend backend = @@ -192,6 +195,16 @@ let implementations_of_backend backend = ) ([], [], [], []) backend.implementations +let nbd_export_of_attach_info (backend : backend) = + let _, _, _, nbds = implementations_of_backend backend in + match nbds with + | [] -> + debug "%s no nbd uri found" __FUNCTION__ ; + None + | uri :: _ -> + debug "%s found nbd uri %s" __FUNCTION__ uri.uri ; + parse_nbd_uri_opt uri |> Option.map snd + (** Uniquely identifies the contents of a VDI *) type content_id = string [@@deriving rpcty] @@ -412,6 +425,8 @@ end exception Storage_error of Errors.error +let unimplemented x = raise (Storage_error (Errors.Unimplemented x)) + let () = (* register printer *) let sprintf = Printf.sprintf in @@ -1043,6 +1058,29 @@ module StorageAPI (R : RPC) = struct @-> returning result_p err ) + let operation_p = Param.mk ~name:"operation" Mirror.operation + + let mirror = + declare "DATA.mirror" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> vm_p + @-> url_p + @-> returning operation_p err + ) + + let stat = + let status_p = Param.mk ~name:"status" Mirror.status in + declare "DATA.stat" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> vm_p + @-> operation_p + @-> returning status_p err + ) + (** [import_activate dbg dp sr vdi vm] returns a server socket address to which a fd can be passed via SCM_RIGHTS for mirroring purposes.*) let import_activate = @@ -1110,7 +1148,7 @@ module StorageAPI (R : RPC) = struct (** Called on the receiving end @deprecated This function is deprecated, and is only here to keep backward compatibility with old xapis that call Remote.DATA.MIRROR.receive_start during SXM. - Use the receive_start2 function instead. + Use the receive_start3 function instead. *) let receive_start = let similar_p = Param.mk ~name:"similar" Mirror.similars in @@ -1124,12 +1162,30 @@ module StorageAPI (R : RPC) = struct @-> returning result err ) - (** Called on the receiving end to prepare for receipt of the storage. This - function should be used in conjunction with [receive_finalize2]*) + (** Called on the receiving end + @deprecated This function is deprecated, and is only here to keep backward + compatibility with old xapis that call Remote.DATA.MIRROR.receive_start2 during SXM. + Use the receive_start3 function instead. + *) let receive_start2 = let similar_p = Param.mk ~name:"similar" Mirror.similars in let result = Param.mk ~name:"result" Mirror.mirror_receive_result in declare "DATA.MIRROR.receive_start2" [] + (dbg_p + @-> sr_p + @-> VDI.vdi_info_p + @-> id_p + @-> similar_p + @-> vm_p + @-> returning result err + ) + + (** Called on the receiving end to prepare for receipt of the storage. This + function should be used in conjunction with [receive_finalize3]*) + let receive_start3 = + let similar_p = Param.mk ~name:"similar" Mirror.similars in + let result = Param.mk ~name:"result" Mirror.mirror_receive_result in + declare "DATA.MIRROR.receive_start3" [] (dbg_p @-> sr_p @-> VDI.vdi_info_p @@ -1144,18 +1200,27 @@ module StorageAPI (R : RPC) = struct (** Called on the receiving end @deprecated This function is deprecated, and is only here to keep backward compatibility with old xapis that call Remote.DATA.MIRROR.receive_finalize - during SXM. Use the receive_finalize2 function instead. + during SXM. Use the receive_finalize3 function instead. *) let receive_finalize = declare "DATA.MIRROR.receive_finalize" [] (dbg_p @-> id_p @-> returning unit_p err) - (** [receive_finalize2 dbg id] will stop the mirroring process and compose - the snapshot VDI with the mirror VDI. It also cleans up the storage resources - used by mirroring. It is called after the the source VM is paused. This fucntion - should be used in conjunction with [receive_start2] *) + (** Called on the receiving end + @deprecated This function is deprecated, and is only here to keep backward + compatibility with old xapis that call Remote.DATA.MIRROR.receive_finalize2 + during SXM. Use the receive_finalize3 function instead. + *) let receive_finalize2 = declare "DATA.MIRROR.receive_finalize2" [] + (dbg_p @-> id_p @-> returning unit_p err) + + (** [receive_finalize3 dbg id] will stop the mirroring process and compose + the snapshot VDI with the mirror VDI. It also cleans up the storage resources + used by mirroring. It is called after the the source VM is paused. This fucntion + should be used in conjunction with [receive_start3] *) + let receive_finalize3 = + declare "DATA.MIRROR.receive_finalize3" [] (dbg_p @-> id_p @-> sr_p @@ -1175,10 +1240,31 @@ module StorageAPI (R : RPC) = struct (dbg_p @-> id_p @-> returning unit_p err) (** [receive_cancel2 dbg mirror_id url verify_dest] cleans up the side effects - done by [receive_start2] on the destination host when the migration fails. *) + done by [receive_start3] on the destination host when the migration fails. *) let receive_cancel2 = declare "DATA.MIRROR.receive_cancel2" [] (dbg_p @-> id_p @-> url_p @-> verify_dest_p @-> returning unit_p err) + + let pre_deactivate_hook = + declare "DATA.MIRROR.pre_deactivate_hook" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> returning unit_p err) + + let has_mirror_failed = + let mirror_failed_p = + Param.mk ~name:"mirror_failed_p" ~description:[] Types.bool + in + declare "DATA.MIRROR.has_mirror_failed" [] + (dbg_p @-> id_p @-> sr_p @-> returning mirror_failed_p err) + + let list = + let result_p = + Param.mk ~name:"mirrors" TypeCombinators.(list (pair Mirror.(id, t))) + in + declare "DATA.MIRROR.list" [] (dbg_p @-> returning result_p err) + + let stat = + let result_p = Param.mk ~name:"result" Mirror.t in + declare "DATA.MIRROR.stat" [] (dbg_p @-> id_p @-> returning result_p err) end end @@ -1258,6 +1344,16 @@ module type MIRROR = sig -> dbg:debug_info -> sr:sr -> vdi_info:vdi_info + -> id:Mirror.id + -> similar:Mirror.similars + -> vm:vm + -> Mirror.mirror_receive_result + + val receive_start3 : + context + -> dbg:debug_info + -> sr:sr + -> vdi_info:vdi_info -> mirror_id:Mirror.id -> similar:Mirror.similars -> vm:vm @@ -1267,7 +1363,9 @@ module type MIRROR = sig val receive_finalize : context -> dbg:debug_info -> id:Mirror.id -> unit - val receive_finalize2 : + val receive_finalize2 : context -> dbg:debug_info -> id:Mirror.id -> unit + + val receive_finalize3 : context -> dbg:debug_info -> mirror_id:Mirror.id @@ -1285,6 +1383,16 @@ module type MIRROR = sig -> url:string -> verify_dest:bool -> unit + + val pre_deactivate_hook : + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> unit + + val has_mirror_failed : + context -> dbg:debug_info -> mirror_id:Mirror.id -> sr:Sr.t -> bool + + val list : context -> dbg:debug_info -> (Mirror.id * Mirror.t) list + + val stat : context -> dbg:debug_info -> id:Mirror.id -> Mirror.t end module type Server_impl = sig @@ -1543,6 +1651,24 @@ module type Server_impl = sig -> verify_dest:bool -> Task.id + val mirror : + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> vm:vm + -> dest:string + -> operation + + val stat : + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> vm:vm + -> key:operation + -> status + val import_activate : context -> dbg:debug_info @@ -1717,6 +1843,12 @@ module Server (Impl : Server_impl) () = struct S.DATA.copy (fun dbg sr vdi vm url dest verify_dest -> Impl.DATA.copy () ~dbg ~sr ~vdi ~vm ~url ~dest ~verify_dest ) ; + S.DATA.mirror (fun dbg sr vdi vm dest -> + Impl.DATA.mirror () ~dbg ~sr ~vdi ~vm ~dest + ) ; + S.DATA.stat (fun dbg sr vdi vm key -> + Impl.DATA.stat () ~dbg ~sr ~vdi ~vm ~key + ) ; S.DATA.MIRROR.send_start (fun dbg @@ -1741,9 +1873,12 @@ module Server (Impl : Server_impl) () = struct 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 + 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 similar vm url verify_dest -> - Impl.DATA.MIRROR.receive_start2 () ~dbg ~sr ~vdi_info ~mirror_id + Impl.DATA.MIRROR.receive_start3 () ~dbg ~sr ~vdi_info ~mirror_id ~similar ~vm ~url ~verify_dest ) ; S.DATA.MIRROR.receive_cancel (fun dbg id -> @@ -1755,10 +1890,21 @@ module Server (Impl : Server_impl) () = struct S.DATA.MIRROR.receive_finalize (fun dbg id -> Impl.DATA.MIRROR.receive_finalize () ~dbg ~id ) ; - S.DATA.MIRROR.receive_finalize2 (fun dbg mirror_id sr url verify_dest -> - Impl.DATA.MIRROR.receive_finalize2 () ~dbg ~mirror_id ~sr ~url + S.DATA.MIRROR.receive_finalize2 (fun dbg id -> + Impl.DATA.MIRROR.receive_finalize2 () ~dbg ~id + ) ; + S.DATA.MIRROR.receive_finalize3 (fun dbg mirror_id sr url verify_dest -> + Impl.DATA.MIRROR.receive_finalize3 () ~dbg ~mirror_id ~sr ~url ~verify_dest ) ; + S.DATA.MIRROR.pre_deactivate_hook (fun dbg dp sr vdi -> + Impl.DATA.MIRROR.pre_deactivate_hook () ~dbg ~dp ~sr ~vdi + ) ; + S.DATA.MIRROR.has_mirror_failed (fun dbg mirror_id sr -> + Impl.DATA.MIRROR.has_mirror_failed () ~dbg ~mirror_id ~sr + ) ; + S.DATA.MIRROR.list (fun dbg -> Impl.DATA.MIRROR.list () ~dbg) ; + S.DATA.MIRROR.stat (fun dbg id -> Impl.DATA.MIRROR.stat () ~dbg ~id) ; S.DATA.import_activate (fun dbg dp sr vdi vm -> Impl.DATA.import_activate () ~dbg ~dp ~sr ~vdi ~vm ) ; diff --git a/ocaml/xapi-idl/storage/storage_skeleton.ml b/ocaml/xapi-idl/storage/storage_skeleton.ml index 01f66eebb2..a2d2d04ab0 100644 --- a/ocaml/xapi-idl/storage/storage_skeleton.ml +++ b/ocaml/xapi-idl/storage/storage_skeleton.ml @@ -13,8 +13,6 @@ *) [@@@ocaml.warning "-27"] -let u x = raise Storage_interface.(Storage_error (Errors.Unimplemented x)) - type context = unit module UPDATES = struct @@ -27,174 +25,231 @@ module UPDATES = struct end module Query = struct - let query ctx ~dbg = u "Query.query" + let query ctx ~dbg = Storage_interface.unimplemented __FUNCTION__ - let diagnostics ctx ~dbg = u "Query.diagnostics" + let diagnostics ctx ~dbg = Storage_interface.unimplemented __FUNCTION__ end module DP = struct - let create ctx ~dbg ~id = u "DP.create" + let create ctx ~dbg ~id = Storage_interface.unimplemented __FUNCTION__ - let destroy ctx ~dbg ~dp ~allow_leak = u "DP.destroy" + let destroy ctx ~dbg ~dp ~allow_leak = + Storage_interface.unimplemented __FUNCTION__ - let destroy2 ctx ~dbg ~dp ~sr ~vdi ~vm ~allow_leak = u "DP.destroy2" + let destroy2 ctx ~dbg ~dp ~sr ~vdi ~vm ~allow_leak = + Storage_interface.unimplemented __FUNCTION__ - let attach_info ctx ~dbg ~sr ~vdi ~dp ~vm = u "DP.attach_info" + let attach_info ctx ~dbg ~sr ~vdi ~dp ~vm = + Storage_interface.unimplemented __FUNCTION__ - let diagnostics ctx () = u "DP.diagnostics" + let diagnostics ctx () = Storage_interface.unimplemented __FUNCTION__ - let stat_vdi ctx ~dbg ~sr ~vdi () = u "DP.stat_vdi" + let stat_vdi ctx ~dbg ~sr ~vdi () = + Storage_interface.unimplemented __FUNCTION__ end module SR = struct let create ctx ~dbg ~sr ~name_label ~name_description ~device_config ~physical_size = - u "SR.create" + Storage_interface.unimplemented __FUNCTION__ - let attach ctx ~dbg ~sr ~device_config = u "SR.attach" + let attach ctx ~dbg ~sr ~device_config = + Storage_interface.unimplemented __FUNCTION__ - let set_name_label ctx ~dbg ~sr ~new_name_label = u "SR.set_name_label" + let set_name_label ctx ~dbg ~sr ~new_name_label = + Storage_interface.unimplemented __FUNCTION__ let set_name_description ctx ~dbg ~sr ~new_name_description = - u "SR.set_name_description" + Storage_interface.unimplemented __FUNCTION__ - let detach ctx ~dbg ~sr = u "SR.detach" + let detach ctx ~dbg ~sr = Storage_interface.unimplemented __FUNCTION__ - let reset ctx ~dbg ~sr = u "SR.reset" + let reset ctx ~dbg ~sr = Storage_interface.unimplemented __FUNCTION__ - let destroy ctx ~dbg ~sr = u "SR.destroy" + let destroy ctx ~dbg ~sr = Storage_interface.unimplemented __FUNCTION__ - let probe ctx ~dbg ~queue ~device_config ~sm_config = u "SR.probe" + let probe ctx ~dbg ~queue ~device_config ~sm_config = + Storage_interface.unimplemented __FUNCTION__ - let scan ctx ~dbg ~sr = u "SR.scan" + let scan ctx ~dbg ~sr = Storage_interface.unimplemented __FUNCTION__ - let scan2 ctx ~dbg ~sr = u "SR.scan2" + let scan2 ctx ~dbg ~sr = Storage_interface.unimplemented __FUNCTION__ let update_snapshot_info_src ctx ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs = - u "SR.update_snapshot_info_src" + Storage_interface.unimplemented __FUNCTION__ let update_snapshot_info_dest ctx ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs = - u "SR.update_snapshot_info_dest" + Storage_interface.unimplemented __FUNCTION__ - let stat ctx ~dbg ~sr = u "SR.stat" + let stat ctx ~dbg ~sr = Storage_interface.unimplemented __FUNCTION__ - let list ctx ~dbg = u "SR.list" + let list ctx ~dbg = Storage_interface.unimplemented __FUNCTION__ end module VDI = struct - let create ctx ~dbg ~sr ~vdi_info = u "VDI.create" + let create ctx ~dbg ~sr ~vdi_info = + Storage_interface.unimplemented __FUNCTION__ - let set_name_label ctx ~dbg ~sr ~vdi ~new_name_label = u "VDI.set_name_label" + let set_name_label ctx ~dbg ~sr ~vdi ~new_name_label = + Storage_interface.unimplemented __FUNCTION__ let set_name_description ctx ~dbg ~sr ~vdi ~new_name_description = - u "VDI.set_name_description" + Storage_interface.unimplemented __FUNCTION__ - let snapshot ctx ~dbg ~sr ~vdi_info = u "VDI.snapshot" + let snapshot ctx ~dbg ~sr ~vdi_info = + Storage_interface.unimplemented __FUNCTION__ - let clone ctx ~dbg ~sr ~vdi_info = u "VDI.clone" + let clone ctx ~dbg ~sr ~vdi_info = + Storage_interface.unimplemented __FUNCTION__ - let resize ctx ~dbg ~sr ~vdi ~new_size = u "VDI.resize" + let resize ctx ~dbg ~sr ~vdi ~new_size = + Storage_interface.unimplemented __FUNCTION__ - let destroy ctx ~dbg ~sr ~vdi = u "VDI.destroy" + let destroy ctx ~dbg ~sr ~vdi = Storage_interface.unimplemented __FUNCTION__ - let stat ctx ~dbg ~sr ~vdi = u "VDI.stat" + let stat ctx ~dbg ~sr ~vdi = Storage_interface.unimplemented __FUNCTION__ - let introduce ctx ~dbg ~sr ~uuid ~sm_config ~location = u "VDI.introduce" + let introduce ctx ~dbg ~sr ~uuid ~sm_config ~location = + Storage_interface.unimplemented __FUNCTION__ - let set_persistent ctx ~dbg ~sr ~vdi ~persistent = u "VDI.set_persistent" + let set_persistent ctx ~dbg ~sr ~vdi ~persistent = + Storage_interface.unimplemented __FUNCTION__ let epoch_begin ctx ~dbg ~sr ~vdi ~vm ~persistent = () - let attach ctx ~dbg ~dp ~sr ~vdi ~read_write = u "VDI.attach" + let attach ctx ~dbg ~dp ~sr ~vdi ~read_write = + Storage_interface.unimplemented __FUNCTION__ - let attach2 ctx ~dbg ~dp ~sr ~vdi ~read_write = u "VDI.attach2" + let attach2 ctx ~dbg ~dp ~sr ~vdi ~read_write = + Storage_interface.unimplemented __FUNCTION__ - let attach3 ctx ~dbg ~dp ~sr ~vdi ~vm ~read_write = u "VDI.attach3" + let attach3 ctx ~dbg ~dp ~sr ~vdi ~vm ~read_write = + Storage_interface.unimplemented __FUNCTION__ - let activate ctx ~dbg ~dp ~sr ~vdi = u "VDI.activate" + let activate ctx ~dbg ~dp ~sr ~vdi = + Storage_interface.unimplemented __FUNCTION__ - let activate3 ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.activate3" + let activate3 ctx ~dbg ~dp ~sr ~vdi ~vm = + Storage_interface.unimplemented __FUNCTION__ - let activate_readonly ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.activate_readonly" + let activate_readonly ctx ~dbg ~dp ~sr ~vdi ~vm = + Storage_interface.unimplemented __FUNCTION__ - let deactivate ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.deactivate" + let deactivate ctx ~dbg ~dp ~sr ~vdi ~vm = + Storage_interface.unimplemented __FUNCTION__ - let detach ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.detach" + let detach ctx ~dbg ~dp ~sr ~vdi ~vm = + Storage_interface.unimplemented __FUNCTION__ let epoch_end ctx ~dbg ~sr ~vdi ~vm = () - let get_url ctx ~dbg ~sr ~vdi = u "VDI.get_url" + let get_url ctx ~dbg ~sr ~vdi = Storage_interface.unimplemented __FUNCTION__ - let similar_content ctx ~dbg ~sr ~vdi = u "VDI.similar_content" + let similar_content ctx ~dbg ~sr ~vdi = + Storage_interface.unimplemented __FUNCTION__ - let get_by_name ctx ~dbg ~sr ~name = u "VDI.get_by_name" + let get_by_name ctx ~dbg ~sr ~name = + Storage_interface.unimplemented __FUNCTION__ - let set_content_id ctx ~dbg ~sr ~vdi ~content_id = u "VDI.set_content_id" + let set_content_id ctx ~dbg ~sr ~vdi ~content_id = + Storage_interface.unimplemented __FUNCTION__ - let compose ctx ~dbg ~sr ~vdi1 ~vdi2 = u "VDI.compose" + let compose ctx ~dbg ~sr ~vdi1 ~vdi2 = + Storage_interface.unimplemented __FUNCTION__ - let add_to_sm_config ctx ~dbg ~sr ~vdi ~key ~value = u "VDI.add_to_sm_config" + let add_to_sm_config ctx ~dbg ~sr ~vdi ~key ~value = + Storage_interface.unimplemented __FUNCTION__ let remove_from_sm_config ctx ~dbg ~sr ~vdi ~key = - u "VDI.remove_from_sm_config" + Storage_interface.unimplemented __FUNCTION__ - let enable_cbt ctx ~dbg ~sr ~vdi = u "VDI.enable_cbt" + let enable_cbt ctx ~dbg ~sr ~vdi = + Storage_interface.unimplemented __FUNCTION__ - let disable_cbt ctx ~dbg ~sr ~vdi = u "VDI.disable_cbt" + let disable_cbt ctx ~dbg ~sr ~vdi = + Storage_interface.unimplemented __FUNCTION__ - let data_destroy ctx ~dbg ~sr ~vdi = u "VDI.data_destroy" + let data_destroy ctx ~dbg ~sr ~vdi = + Storage_interface.unimplemented __FUNCTION__ let list_changed_blocks ctx ~dbg ~sr ~vdi_from ~vdi_to = - u "VDI.list_changed_blocks" + Storage_interface.unimplemented __FUNCTION__ end -let get_by_name ctx ~dbg ~name = u "get_by_name" +let get_by_name ctx ~dbg ~name = Storage_interface.unimplemented __FUNCTION__ module DATA = struct - let copy ctx ~dbg ~sr ~vdi ~vm ~url ~dest = u "DATA.copy" + let copy ctx ~dbg ~sr ~vdi ~vm ~url ~dest = + Storage_interface.unimplemented __FUNCTION__ + + let mirror ctx ~dbg ~sr ~vdi ~vm ~dest = + Storage_interface.unimplemented __FUNCTION__ + + let stat ctx ~dbg ~sr ~vdi ~vm ~key = + Storage_interface.unimplemented __FUNCTION__ let import_activate ctx ~dbg ~dp ~sr ~vdi ~vm = - u "DATA.MIRROR.import_activate" + Storage_interface.unimplemented __FUNCTION__ - let get_nbd_server ctx ~dbg ~dp ~sr ~vdi ~vm = u "DATA.MIRROR.get_nbd_server" + let get_nbd_server ctx ~dbg ~dp ~sr ~vdi ~vm = + Storage_interface.unimplemented __FUNCTION__ module MIRROR = struct type context = unit let send_start ctx ~dbg ~task_id ~dp ~sr ~vdi ~mirror_vm ~mirror_id ~local_vdi ~copy_vm ~live_vm ~url ~remote_mirror ~dest_sr ~verify_dest = - u "DATA.MIRROR.send_start" + Storage_interface.unimplemented __FUNCTION__ let receive_start ctx ~dbg ~sr ~vdi_info ~id ~similar = - u "DATA.MIRROR.receive_start" + Storage_interface.unimplemented __FUNCTION__ - let receive_start2 ctx ~dbg ~sr ~vdi_info ~mirror_id ~similar ~vm ~url + 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 ~similar ~vm ~url ~verify_dest = - u "DATA.MIRROR.receive_start2" + Storage_interface.unimplemented __FUNCTION__ + + let receive_finalize ctx ~dbg ~id = + Storage_interface.unimplemented __FUNCTION__ - let receive_finalize ctx ~dbg ~id = u "DATA.MIRROR.receive_finalize" + let receive_finalize2 ctx ~dbg ~id = + Storage_interface.unimplemented __FUNCTION__ - let receive_finalize2 ctx ~dbg ~mirror_id ~sr ~url ~verify_dest = - u "DATA.MIRROR.receive_finalize2" + let receive_finalize3 ctx ~dbg ~mirror_id ~sr ~url ~verify_dest = + Storage_interface.unimplemented __FUNCTION__ - let receive_cancel ctx ~dbg ~id = u "DATA.MIRROR.receive_cancel" + let receive_cancel ctx ~dbg ~id = + Storage_interface.unimplemented __FUNCTION__ let receive_cancel2 ctx ~dbg ~mirror_id ~url ~verify_dest = - u "DATA.MIRROR.receive_cancel2" + Storage_interface.unimplemented __FUNCTION__ + + let pre_deactivate_hook ctx ~dbg ~dp ~sr ~vdi = + Storage_interface.unimplemented __FUNCTION__ + + let has_mirror_failed ctx ~dbg ~mirror_id ~sr = + Storage_interface.unimplemented __FUNCTION__ + + let list ctx ~dbg = Storage_interface.unimplemented __FUNCTION__ + + let stat ctx ~dbg ~id = Storage_interface.unimplemented __FUNCTION__ end end module Policy = struct - let get_backend_vm ctx ~dbg ~vm ~sr ~vdi = u "Policy.get_backend_vm" + let get_backend_vm ctx ~dbg ~vm ~sr ~vdi = + Storage_interface.unimplemented __FUNCTION__ end module TASK = struct - let stat ctx ~dbg ~task = u "TASK.stat" + let stat ctx ~dbg ~task = Storage_interface.unimplemented __FUNCTION__ - let cancel ctx ~dbg ~task = u "TASK.cancel" + let cancel ctx ~dbg ~task = Storage_interface.unimplemented __FUNCTION__ - let destroy ctx ~dbg ~task = u "TASK.destroy" + let destroy ctx ~dbg ~task = Storage_interface.unimplemented __FUNCTION__ - let list ctx ~dbg = u "TASK.list" + let list ctx ~dbg = Storage_interface.unimplemented __FUNCTION__ end diff --git a/ocaml/xapi-idl/storage/storage_test.ml b/ocaml/xapi-idl/storage/storage_test.ml index f4145ceccc..d86c6b69df 100644 --- a/ocaml/xapi-idl/storage/storage_test.ml +++ b/ocaml/xapi-idl/storage/storage_test.ml @@ -63,7 +63,7 @@ let names = let vdi_exists sr vdi = let all = Client.SR.scan dbg sr in - List.fold_left (fun acc vdi_info -> acc || vdi_info.vdi = vdi) false all + List.exists (fun vdi_info -> vdi_info.vdi = vdi) all let create sr name_label = let vdi_info = diff --git a/ocaml/xapi-idl/storage/vdi_automaton.ml b/ocaml/xapi-idl/storage/vdi_automaton.ml index e36de90e2b..3192fd585d 100644 --- a/ocaml/xapi-idl/storage/vdi_automaton.ml +++ b/ocaml/xapi-idl/storage/vdi_automaton.ml @@ -94,15 +94,9 @@ let ( + ) state operation = let superstate states = let activated = - List.fold_left - (fun acc s -> acc || s = Activated RO || s = Activated RW) - false states - in - let rw = - List.fold_left - (fun acc s -> acc || s = Activated RW || s = Attached RW) - false states + List.exists (fun s -> s = Activated RO || s = Activated RW) states in + let rw = List.exists (fun s -> s = Activated RW || s = Attached RW) states in if states = [] then Detached else if activated then diff --git a/ocaml/xapi-idl/v6/cli-help.t b/ocaml/xapi-idl/v6/cli-help.t new file mode 100644 index 0000000000..ed7d3b47ba --- /dev/null +++ b/ocaml/xapi-idl/v6/cli-help.t @@ -0,0 +1,40 @@ + $ ./v6_cli.exe --help=plain + NAME + licensing_cli - A CLI for the V6d API. This allows scripting of the + licensing daemon for testing and debugging. This tool is not intended + to be used as an end user tool + + SYNOPSIS + licensing_cli [COMMAND] … + + COMMANDS + apply_edition [OPTION]… debug_info string string_pair_lst + Checks license info to ensures enabled features are compatible. + + get_editions [OPTION]… debug_info + Gets list of accepted editions. + + get_version [OPTION]… debug_info + Gets list of version-related string pairs + + COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + + EXIT STATUS + licensing_cli exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + + diff --git a/ocaml/xapi-idl/v6/dune b/ocaml/xapi-idl/v6/dune index 79751c0879..51ddb5707e 100644 --- a/ocaml/xapi-idl/v6/dune +++ b/ocaml/xapi-idl/v6/dune @@ -7,6 +7,7 @@ rpclib.core rresult threads.posix + unix xapi-idl xapi-log ) @@ -19,7 +20,7 @@ (modules v6_cli) (libraries cmdliner - + rpclib.cmdliner rpclib.core rpclib.markdown @@ -28,8 +29,6 @@ xapi-log )) -(rule - (alias runtest) - (deps (:x v6_cli.exe)) +(cram (package xapi-idl) - (action (run %{x} --help=plain))) + (deps v6_cli.exe)) diff --git a/ocaml/xapi-idl/v6/v6_interface.ml b/ocaml/xapi-idl/v6/v6_interface.ml index ba42aa259e..3098713c59 100644 --- a/ocaml/xapi-idl/v6/v6_interface.ml +++ b/ocaml/xapi-idl/v6/v6_interface.ml @@ -78,7 +78,8 @@ type errors = (** Thrown by license_check when expiry date matches or precedes current date *) | License_processing_error (** License could not be processed *) - | License_checkout_error of string (** License could not be checked out *) + | License_checkout_error of string * string + (** License could not be checked out *) | Missing_connection_details (** Thrown if connection port or address parameter not supplied to check_license *) diff --git a/ocaml/xapi-idl/xen/xenops_interface.ml b/ocaml/xapi-idl/xen/xenops_interface.ml index 68ef01b29c..a67c51b013 100644 --- a/ocaml/xapi-idl/xen/xenops_interface.ml +++ b/ocaml/xapi-idl/xen/xenops_interface.ml @@ -303,6 +303,7 @@ module Vbd = struct ; extra_private_keys: (string * string) list [@default []] ; qos: qos option [@default None] ; persistent: bool [@default true] + ; can_attach_early: bool [@default false] } [@@deriving rpcty] @@ -444,16 +445,6 @@ module Dynamic = struct type barrier = int * id list [@@deriving rpcty] - type t = - | Vm_t of Vm.id * (Vm.t * Vm.state) option - | Vbd_t of Vbd.id * (Vbd.t * Vbd.state) option - | Vif_t of Vif.id * (Vif.t * Vif.state) option - | Pci_t of Pci.id * (Pci.t * Pci.state) option - | Vgpu_t of Vgpu.id * (Vgpu.t * Vgpu.state) option - | Vusb_t of Vusb.id * (Vusb.t * Vusb.state) option - | Task_t of Task.id * Task.t option - [@@deriving rpcty] - let rpc_of_id = Rpcmarshal.marshal id.Rpc.Types.ty end @@ -462,6 +453,7 @@ module Host = struct cpu_count: int ; socket_count: int ; threads_per_core: int + ; nr_nodes: int ; vendor: string ; speed: string ; modelname: string @@ -496,9 +488,12 @@ module Host = struct [@@deriving rpcty] type numa_affinity_policy = - | Any (** VMs may run on any NUMA nodes. This is the default in 8.2CU1 *) + | Any (** VMs may run on any NUMA nodes. *) | Best_effort - (** best effort placement on the smallest number of NUMA nodes where possible *) + (** Best-effort placement. Assigns the memory of the VM to a single + node, and soft-pins its VCPUs to the node, if possible. Otherwise + behaves like Any. *) + | Best_effort_hard (** Like Best_effort, but hard-pins the VCPUs *) [@@deriving rpcty] type numa_affinity_policy_opt = numa_affinity_policy option [@@deriving rpcty] @@ -718,6 +713,11 @@ module XenopsAPI (R : RPC) = struct ~description:["when true, verify remote server certificate"] Types.bool in + let localhost_migration = + Param.mk ~name:"localhost_migration" + ~description:["when true, localhost migration is being performed"] + Types.bool + in declare "VM.migrate" [] (debug_info_p @-> vm_id_p @@ -727,6 +727,7 @@ module XenopsAPI (R : RPC) = struct @-> xenops_url @-> compress @-> verify_dest + @-> localhost_migration @-> returning task_id_p err ) @@ -1146,80 +1147,5 @@ module XenopsAPI (R : RPC) = struct (debug_info_p @-> unit_p @-> returning unit_p err) end - module Observer = struct - open TypeCombinators - - let endpoints_p = Param.mk ~name:"endpoints" (list Types.string) - - let bool_p = Param.mk ~name:"bool" Types.bool - - let uuid_p = Param.mk ~name:"uuid" Types.string - - let name_label_p = Param.mk ~name:"name_label" Types.string - - let dict_p = Param.mk ~name:"dict" dict - - let string_p = Param.mk ~name:"string" Types.string - - let int_p = Param.mk ~name:"int" Types.int - - let float_p = Param.mk ~name:"float" Types.float - - let create = - declare "Observer.create" [] - (debug_info_p - @-> uuid_p - @-> name_label_p - @-> dict_p - @-> endpoints_p - @-> bool_p - @-> returning unit_p err - ) - - let destroy = - declare "Observer.destroy" [] - (debug_info_p @-> uuid_p @-> returning unit_p err) - - let set_enabled = - declare "Observer.set_enabled" [] - (debug_info_p @-> uuid_p @-> bool_p @-> returning unit_p err) - - let set_attributes = - declare "Observer.set_attributes" [] - (debug_info_p @-> uuid_p @-> dict_p @-> returning unit_p err) - - let set_endpoints = - declare "Observer.set_endpoints" [] - (debug_info_p @-> uuid_p @-> endpoints_p @-> returning unit_p err) - - let init = declare "Observer.init" [] (debug_info_p @-> returning unit_p err) - - let set_trace_log_dir = - declare "Observer.set_trace_log_dir" [] - (debug_info_p @-> string_p @-> returning unit_p err) - - let set_export_interval = - declare "Observer.set_export_interval" [] - (debug_info_p @-> float_p @-> returning unit_p err) - - let set_host_id = - declare "Observer.set_host_id" [] - (debug_info_p @-> string_p @-> returning unit_p err) - - let set_max_traces = - declare "Observer.set_max_traces" [] - (debug_info_p @-> int_p @-> returning unit_p err) - - let set_max_spans = - declare "Observer.set_max_spans" [] - (debug_info_p @-> int_p @-> returning unit_p err) - - let set_max_file_size = - declare "Observer.set_max_file_size" [] - (debug_info_p @-> int_p @-> returning unit_p err) - - let set_compress_tracing_files = - declare "Observer.set_compress_tracing_files" [] - (debug_info_p @-> bool_p @-> returning unit_p err) - end + module Observer = Observer_helpers.ObserverAPI (R) end diff --git a/ocaml/xapi-storage-cli/dune b/ocaml/xapi-storage-cli/dune index c59c5c1fad..92322f692a 100644 --- a/ocaml/xapi-storage-cli/dune +++ b/ocaml/xapi-storage-cli/dune @@ -1,7 +1,7 @@ (executable (name main) (libraries - + unix xapi-idl xapi-idl.storage xapi-idl.storage.interface diff --git a/ocaml/xapi-storage-cli/main.ml b/ocaml/xapi-storage-cli/main.ml index 6a607f5098..f581d6b6b4 100644 --- a/ocaml/xapi-storage-cli/main.ml +++ b/ocaml/xapi-storage-cli/main.ml @@ -149,7 +149,7 @@ let string_of_file filename = let mirror_list common_opts = wrap common_opts (fun () -> - let list = Storage_migrate.list ~dbg in + let list = Client.DATA.MIRROR.list dbg in List.iter (fun (id, status) -> Printf.printf "%s" (string_of_mirror id status)) list diff --git a/ocaml/xapi-storage-script/dune b/ocaml/xapi-storage-script/dune index e1391aed2c..9f1f798df5 100644 --- a/ocaml/xapi-storage-script/dune +++ b/ocaml/xapi-storage-script/dune @@ -7,6 +7,7 @@ inotify.lwt lwt lwt.unix + unix rpclib.core ) (preprocess (pps ppx_deriving_rpc)) @@ -16,7 +17,7 @@ (name test_lib) (modules test_lib) (package xapi-storage-script) - (libraries alcotest alcotest-lwt lwt fmt private) + (libraries alcotest alcotest-lwt lwt fmt private unix) ) (executable @@ -41,6 +42,8 @@ sexplib sexplib0 uri + threads.posix + unix xapi-backtrace xapi-consts xapi-consts.xapi_version @@ -76,20 +79,19 @@ (files (xapi-storage-script.8 as man8/xapi-storage-script.8)) ) -(rule +(cram (alias runtest-python) + (runtest_alias false) (package xapi-storage-script) (deps - (:x main.exe) + main.exe + ../xapi-storage/python/xapi/storage/api/v5/datapath.py + ../xapi-storage/python/xapi/storage/api/v5/plugin.py + ../xapi-storage/python/xapi/storage/api/v5/task.py + ../xapi-storage/python/xapi/storage/api/v5/volume.py + (source_tree ../xapi-storage/python/xapi) (source_tree test/volume) - (:p - ../xapi-storage/python/xapi/storage/api/v5/datapath.py - ../xapi-storage/python/xapi/storage/api/v5/plugin.py - ../xapi-storage/python/xapi/storage/api/v5/task.py - ../xapi-storage/python/xapi/storage/api/v5/volume.py - ) ) - (action (bash "export PYTHONPATH=../xapi-storage/python/; echo $PYTHONPATH; ./%{x} --root=$PWD/test --self-test-only=true")) ) (data_only_dirs test examples) diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 0800223c3f..1eccd3867f 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -16,6 +16,7 @@ module Plugin_client = Xapi_storage.Plugin.Plugin (Rpc_lwt.GenClient ()) module Volume_client = Xapi_storage.Control.Volume (Rpc_lwt.GenClient ()) module Sr_client = Xapi_storage.Control.Sr (Rpc_lwt.GenClient ()) module Datapath_client = Xapi_storage.Data.Datapath (Rpc_lwt.GenClient ()) +module Data_client = Xapi_storage.Data.Data (Rpc_lwt.GenClient ()) open Private.Lib let ( >>= ) = Lwt.bind @@ -410,19 +411,6 @@ let observer_config_dir = in dir // component // "enabled" -(** Determine if SM API observation is enabled from the - filesystem. Ordinarily, determining if a component is enabled - would consist of querying the 'components' field of an observer - from the xapi database. *) -let observer_is_component_enabled () = - let is_enabled () = - let is_config_file path = Filename.check_suffix path ".observer.conf" in - let* files = Sys.readdir observer_config_dir in - Lwt.return (List.exists is_config_file files) - in - let* result = Deferred.try_with is_enabled in - Lwt.return (Option.value (Result.to_option result) ~default:false) - (** Call the script named after the RPC method in the [script_dir] directory. The arguments (not the whole JSON-RPC call) are passed as JSON to its stdin, and stdout is returned. In case of a non-zero exit code, @@ -1456,6 +1444,12 @@ module VDIImpl (M : META) = struct set ~dbg ~sr ~vdi:response.Xapi_storage.Control.key ~key:_snapshot_of_key ~value:vdi >>>= fun () -> + set ~dbg ~sr ~vdi:response.Xapi_storage.Control.key + ~key:_vdi_content_id_key ~value:vdi_info.content_id + >>>= fun () -> + set ~dbg ~sr ~vdi:response.Xapi_storage.Control.key + ~key:_vdi_type_key ~value:vdi_info.ty + >>>= fun () -> let response = { (vdi_of_volume response) with @@ -1753,6 +1747,8 @@ module VDIImpl (M : META) = struct let vdi = Storage_interface.Vdi.string_of vdi in let* () = unset ~dbg ~sr ~vdi ~key:(_sm_config_prefix_key ^ key) in return () + + let similar_content_impl _dbg _sr _vdi = wrap @@ return [] end module DPImpl (M : META) = struct @@ -1789,6 +1785,62 @@ end module DATAImpl (M : META) = struct module VDI = VDIImpl (M) + let stat dbg sr vdi' _vm key = + let open Storage_interface in + let convert_key = function + | Mirror.CopyV1 k -> + Data_client.CopyV1 k + | Mirror.MirrorV1 k -> + Data_client.MirrorV1 k + in + + let vdi = Vdi.string_of vdi' in + Attached_SRs.find sr >>>= fun sr -> + VDI.stat ~dbg ~sr ~vdi >>>= fun response -> + ( match + List.assoc_opt _clone_on_boot_key response.Xapi_storage.Control.keys + with + | None -> + return response + | Some temporary -> + VDI.stat ~dbg ~sr ~vdi:temporary + ) + >>>= fun response -> + choose_datapath response >>>= fun (rpc, _datapath, _uri) -> + let key = convert_key key in + return_data_rpc (fun () -> Data_client.stat (rpc ~dbg) dbg key) + >>>= function + | {failed; complete; progress} -> + return Mirror.{failed; complete; progress} + + let stat_impl dbg sr vdi vm key = wrap @@ stat dbg sr vdi vm key + + let mirror dbg sr vdi' vm' remote = + let vdi = Storage_interface.Vdi.string_of vdi' in + let domain = Storage_interface.Vm.string_of vm' in + Attached_SRs.find sr >>>= fun sr -> + VDI.stat ~dbg ~sr ~vdi >>>= fun response -> + ( match + List.assoc_opt _clone_on_boot_key response.Xapi_storage.Control.keys + with + | None -> + return response + | Some temporary -> + VDI.stat ~dbg ~sr ~vdi:temporary + ) + >>>= fun response -> + choose_datapath response >>>= fun (rpc, _datapath, uri) -> + return_data_rpc (fun () -> + Data_client.mirror (rpc ~dbg) dbg uri domain remote + ) + >>>= function + | CopyV1 v -> + return (Storage_interface.Mirror.CopyV1 v) + | MirrorV1 v -> + return (Storage_interface.Mirror.MirrorV1 v) + + let mirror_impl dbg sr vdi vm remote = wrap @@ mirror dbg sr vdi vm remote + let data_import_activate_impl dbg _dp sr vdi' vm' = wrap @@ @@ -1855,6 +1907,7 @@ let bind ~volume_script_dir = (* this version field will be updated once query is called *) let version = ref None end in + let u name _ = failwith ("Unimplemented: " ^ name) in let module Query = QueryImpl (RuntimeMeta) in S.Query.query Query.query_impl ; S.Query.diagnostics Query.query_diagnostics_impl ; @@ -1899,16 +1952,19 @@ let bind ~volume_script_dir = S.VDI.set_content_id VDI.vdi_set_content_id_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.similar_content VDI.similar_content_impl ; let module DP = DPImpl (RuntimeMeta) in S.DP.destroy2 DP.dp_destroy2 ; S.DP.attach_info DP.dp_attach_info_impl ; let module DATA = DATAImpl (RuntimeMeta) in + S.DATA.copy (u "DATA.copy") ; + S.DATA.mirror DATA.mirror_impl ; + S.DATA.stat DATA.stat_impl ; S.DATA.get_nbd_server DATA.get_nbd_server_impl ; S.DATA.import_activate DATA.data_import_activate_impl ; - let u name _ = failwith ("Unimplemented: " ^ name) in S.get_by_name (u "get_by_name") ; S.VDI.get_by_name (u "VDI.get_by_name") ; S.UPDATES.get (u "UPDATES.get") ; @@ -1917,16 +1973,20 @@ let bind ~volume_script_dir = S.DP.diagnostics (u "DP.diagnostics") ; S.TASK.destroy (u "TASK.destroy") ; S.DP.destroy (u "DP.destroy") ; - S.VDI.similar_content (u "VDI.similar_content") ; - S.DATA.copy (u "DATA.copy") ; S.DP.stat_vdi (u "DP.stat_vdi") ; S.DATA.MIRROR.send_start (u "DATA.MIRROR.send_start") ; S.DATA.MIRROR.receive_start (u "DATA.MIRROR.receive_start") ; S.DATA.MIRROR.receive_start2 (u "DATA.MIRROR.receive_start2") ; + S.DATA.MIRROR.receive_start3 (u "DATA.MIRROR.receive_start3") ; S.DATA.MIRROR.receive_finalize (u "DATA.MIRROR.receive_finalize") ; S.DATA.MIRROR.receive_finalize2 (u "DATA.MIRROR.receive_finalize2") ; + S.DATA.MIRROR.receive_finalize3 (u "DATA.MIRROR.receive_finalize3") ; S.DATA.MIRROR.receive_cancel (u "DATA.MIRROR.receive_cancel") ; S.DATA.MIRROR.receive_cancel2 (u "DATA.MIRROR.receive_cancel2") ; + S.DATA.MIRROR.pre_deactivate_hook (u "DATA.MIRROR.pre_deactivate_hook") ; + S.DATA.MIRROR.has_mirror_failed (u "DATA.MIRROR.has_mirror_failed") ; + S.DATA.MIRROR.list (u "DATA.MIRROR.list") ; + S.DATA.MIRROR.stat (u "DATA.MIRROR.stat") ; S.DP.create (u "DP.create") ; S.TASK.cancel (u "TASK.cancel") ; S.TASK.list (u "TASK.list") ; @@ -2177,6 +2237,19 @@ let register_exn_pretty_printers () = assert false ) +module XapiStorageScript : Observer_helpers.Server_impl = struct + include Observer_skeleton.Observer + + let create _context ~dbg:_ ~uuid:_ ~name_label:_ ~attributes:_ ~endpoints:_ + ~enabled = + config.use_observer <- enabled + + let destroy _context ~dbg:_ ~uuid:_ = config.use_observer <- false + + let set_enabled _context ~dbg:_ ~uuid:_ ~enabled = + config.use_observer <- enabled +end + let () = register_exn_pretty_printers () ; let root_dir = ref "/var/lib/xapi/storage-scripts" in @@ -2223,9 +2296,17 @@ let () = Logs.set_reporter (lwt_reporter ()) ; Logs.set_level ~all:true (Some Logs.Info) ; + + let module S = Observer_helpers.Server (XapiStorageScript) () in + let s = + Xcp_service.make ~path:Observer_helpers.default_path + ~queue_name:Observer_helpers.queue_name ~rpc_fn:S.process () + in + let (_ : Thread.t) = + Thread.create (fun () -> Xcp_service.serve_forever s) () + in + let main = - let* observer_enabled = observer_is_component_enabled () in - config.use_observer <- observer_enabled ; if !self_test_only then self_test ~root_dir:!root_dir else diff --git a/ocaml/xapi-storage-script/python-self-test.t b/ocaml/xapi-storage-script/python-self-test.t new file mode 100644 index 0000000000..9ac59bed95 --- /dev/null +++ b/ocaml/xapi-storage-script/python-self-test.t @@ -0,0 +1,47 @@ +run the self-checks for xapi-storage-script, it logs to stderr, so process +stderr instead of stdout + +The output of the logs needs to delete randomization, there are two sources: +pids and uuids + + $ export PYTHONPATH=../xapi-storage/python/; ./main.exe --root=$PWD/test --self-test-only=true 2>&1 >/dev/null | sed -E 's/\[[0-9]+\]/[PID]/g' | sed -E 's/[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}/UUID/g' + [INFO] {"method":"Plugin.query","params":[{"dbg":"debug"}],"id":2} + [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Plugin.Query[PID] succeeded: {"plugin": "dummy", "name": "dummy SR plugin", "description": "Dummy v5 SR for unit tests.", "vendor": "Citrix Systems Inc", "copyright": "(C) 2018 Citrix Inc", "version": "1.0", "required_api_version": "5.0", "features": ["SR_ATTACH", "SR_DETACH", "SR_CREATE", "SR_PROBE", "VDI_CREATE", "VDI_DESTROY"], "configuration": {}, "required_cluster_stack": []} + + [INFO] {"method":"Plugin.diagnostics","params":[{"dbg":"debug"}],"id":4} + [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/Plugin.diagnostics[PID] succeeded: "Dummy diagnostics" + + [INFO] {"method":"SR.create","params":[{"description":"dummy description","name":"dummy name","configuration":{"uri":"file:///dev/null"},"uuid":"dummySR","dbg":"debug"}],"id":6} + [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/SR.create[PID] succeeded: {"uri": "file:///tmp/dummy"} + + [INFO] {"method":"SR.attach","params":[{"configuration":{"uri":"file:///tmp/dummy"},"dbg":"debug"}],"id":9} + [INFO] $TESTCASE_ROOT/test/volume/org.xen.xapi.storage.dummyv5/SR.attach[PID] succeeded: "file:///tmp/dummy" + + [INFO] {"method":"SR.stat","params":[{"sr":"file:///tmp/dummy","dbg":"debug"}],"id":10} + [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] {"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] {"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] {"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 + + [INFO] {"method":"SR.stat","params":[{"sr":"file:///tmp/dummy","dbg":"debug"}],"id":20} + [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] {"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": {}}] + + [INFO] test thread shutdown cleanly diff --git a/ocaml/xapi-storage/generator/test/dune b/ocaml/xapi-storage/generator/test/dune index d37a25a870..1897c393b4 100644 --- a/ocaml/xapi-storage/generator/test/dune +++ b/ocaml/xapi-storage/generator/test/dune @@ -7,6 +7,7 @@ lwt.unix rpclib.core rpclib.xml + unix xapi_storage ) ) diff --git a/ocaml/xapi-types/dune b/ocaml/xapi-types/dune index ab33ae1f35..8122674acf 100644 --- a/ocaml/xapi-types/dune +++ b/ocaml/xapi-types/dune @@ -17,12 +17,15 @@ rpclib.core rpclib.json rpclib.xml + unix uuid xapi-consts clock xapi-stdext-unix ) (wrapped false) - (preprocess (per_module ((pps ppx_deriving_rpc) API Event_types Features SecretString))) + (preprocess + (per_module + ((pps ppx_deriving_rpc) API Event_types SecretString) + ((pps ppx_deriving_rpc ppx_deriving.enum) Features))) ) - diff --git a/ocaml/xapi-types/event_types.ml b/ocaml/xapi-types/event_types.ml index 83c82b0bc8..46ea2d310d 100644 --- a/ocaml/xapi-types/event_types.ml +++ b/ocaml/xapi-types/event_types.ml @@ -20,37 +20,15 @@ let rpc_of_op = API.rpc_of_event_operation let op_of_rpc = API.event_operation_of_rpc type event = { - id: string - ; ts: string - ; ty: string - ; op: op - ; reference: string - ; snapshot: Rpc.t option + id: string [@key "id"] + ; ts: string [@key "timestamp"] + ; ty: string [@key "class"] + ; op: op [@key "operation"] + ; reference: string [@key "ref"] + ; snapshot: Rpc.t option [@key "snapshot"] } [@@deriving rpc] -let ev_struct_remap = - [ - ("id", "id") - ; ("ts", "timestamp") - ; ("ty", "class") - ; ("op", "operation") - ; ("reference", "ref") - ; ("snapshot", "snapshot") - ] - -let remap map str = - match str with - | Rpc.Dict d -> - Rpc.Dict (List.map (fun (k, v) -> (List.assoc k map, v)) d) - | _ -> - str - -let rpc_of_event ev = remap ev_struct_remap (rpc_of_event ev) - -let event_of_rpc rpc = - event_of_rpc (remap (List.map (fun (k, v) -> (v, k)) ev_struct_remap) rpc) - type events = event list [@@deriving rpc] type token = string [@@deriving rpc] diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml index 52469387ac..7453ab49a7 100644 --- a/ocaml/xapi-types/features.ml +++ b/ocaml/xapi-types/features.ml @@ -68,79 +68,119 @@ type feature = | VM_groups | VM_start | VM_appliance_start -[@@deriving rpc] +[@@deriving rpc, enum] type orientation = Positive | Negative -let keys_of_features = - [ - (VLAN, ("restrict_vlan", Negative, "VLAN")) - ; (QoS, ("restrict_qos", Negative, "QoS")) - ; (Shared_storage, ("restrict_pool_attached_storage", Negative, "SStorage")) - ; (Netapp, ("restrict_netapp", Negative, "NTAP")) - ; (Equalogic, ("restrict_equalogic", Negative, "EQL")) - ; (Pooling, ("restrict_pooling", Negative, "Pool")) - ; (HA, ("enable_xha", Positive, "XHA")) - ; (Marathon, ("restrict_marathon", Negative, "MTC")) - ; (Email, ("restrict_email_alerting", Negative, "email")) - ; (Performance, ("restrict_historical_performance", Negative, "perf")) - ; (WLB, ("restrict_wlb", Negative, "WLB")) - ; (RBAC, ("restrict_rbac", Negative, "RBAC")) - ; (DMC, ("restrict_dmc", Negative, "DMC")) - ; (Checkpoint, ("restrict_checkpoint", Negative, "chpt")) - ; (CPU_masking, ("restrict_cpu_masking", Negative, "Mask")) - ; (Connection, ("restrict_connection", Negative, "Cnx")) - ; (No_platform_filter, ("platform_filter", Negative, "Plat")) - ; (No_nag_dialog, ("regular_nag_dialog", Negative, "nonag")) - ; (VMPR, ("restrict_vmpr", Negative, "VMPR")) - ; (VMSS, ("restrict_vmss", Negative, "VMSS")) - ; (IntelliCache, ("restrict_intellicache", Negative, "IntelliCache")) - ; (GPU, ("restrict_gpu", Negative, "GPU")) - ; (DR, ("restrict_dr", Negative, "DR")) - ; (VIF_locking, ("restrict_vif_locking", Negative, "VIFLock")) - ; (Storage_motion, ("restrict_storage_xen_motion", Negative, "SXM")) - ; (VGPU, ("restrict_vgpu", Negative, "vGPU")) - ; (Integrated_GPU, ("restrict_integrated_gpu_passthrough", Negative, "iGPU")) - ; (VSS, ("restrict_vss", Negative, "VSS")) - ; ( Guest_agent_auto_update - , ("restrict_guest_agent_auto_update", Negative, "GAAU") - ) - ; ( PCI_device_for_auto_update - , ("restrict_pci_device_for_auto_update", Negative, "PciAU") - ) - ; (Xen_motion, ("restrict_xen_motion", Negative, "Live_migration")) - ; (Guest_ip_setting, ("restrict_guest_ip_setting", Negative, "GuestIP")) - ; (AD, ("restrict_ad", Negative, "AD")) - ; (Nested_virt, ("restrict_nested_virt", Negative, "Nested_virt")) - ; (Live_patching, ("restrict_live_patching", Negative, "Live_patching")) - ; ( Live_set_vcpus - , ("restrict_set_vcpus_number_live", Negative, "Live_set_vcpus") - ) - ; (PVS_proxy, ("restrict_pvs_proxy", Negative, "PVS_proxy")) - ; (IGMP_snooping, ("restrict_igmp_snooping", Negative, "IGMP_snooping")) - ; (RPU, ("restrict_rpu", Negative, "RPU")) - ; (Pool_size, ("restrict_pool_size", Negative, "Pool_size")) - ; (CBT, ("restrict_cbt", Negative, "CBT")) - ; (USB_passthrough, ("restrict_usb_passthrough", Negative, "USB_passthrough")) - ; (Network_sriov, ("restrict_network_sriov", Negative, "Network_sriov")) - ; (Corosync, ("restrict_corosync", Negative, "Corosync")) - ; (Cluster_address, ("restrict_cluster_address", Negative, "Cluster_address")) - ; (Zstd_export, ("restrict_zstd_export", Negative, "Zstd_export")) - ; ( Pool_secret_rotation - , ("restrict_pool_secret_rotation", Negative, "Pool_secret_rotation") - ) - ; ( Certificate_verification - , ("restrict_certificate_verification", Negative, "Certificate_verification") - ) - ; (Updates, ("restrict_updates", Negative, "Upd")) - ; ( Internal_repo_access - , ("restrict_internal_repo_access", Negative, "Internal_repo_access") - ) - ; (VTPM, ("restrict_vtpm", Negative, "VTPM")) - ; (VM_groups, ("restrict_vm_groups", Negative, "VM_groups")) - ; (VM_start, ("restrict_vm_start", Negative, "Start")) - ; (VM_appliance_start, ("restrict_vm_appliance_start", Negative, "Start")) - ] +let props_of_feature = function + | VLAN -> + ("restrict_vlan", Negative, "VLAN") + | QoS -> + ("restrict_qos", Negative, "QoS") + | Shared_storage -> + ("restrict_pool_attached_storage", Negative, "SStorage") + | Netapp -> + ("restrict_netapp", Negative, "NTAP") + | Equalogic -> + ("restrict_equalogic", Negative, "EQL") + | Pooling -> + ("restrict_pooling", Negative, "Pool") + | HA -> + ("enable_xha", Positive, "XHA") + | Marathon -> + ("restrict_marathon", Negative, "MTC") + | Email -> + ("restrict_email_alerting", Negative, "email") + | Performance -> + ("restrict_historical_performance", Negative, "perf") + | WLB -> + ("restrict_wlb", Negative, "WLB") + | RBAC -> + ("restrict_rbac", Negative, "RBAC") + | DMC -> + ("restrict_dmc", Negative, "DMC") + | Checkpoint -> + ("restrict_checkpoint", Negative, "chpt") + | CPU_masking -> + ("restrict_cpu_masking", Negative, "Mask") + | Connection -> + ("restrict_connection", Negative, "Cnx") + | No_platform_filter -> + ("platform_filter", Negative, "Plat") + | No_nag_dialog -> + ("regular_nag_dialog", Negative, "nonag") + | VMPR -> + ("restrict_vmpr", Negative, "VMPR") + | VMSS -> + ("restrict_vmss", Negative, "VMSS") + | IntelliCache -> + ("restrict_intellicache", Negative, "IntelliCache") + | GPU -> + ("restrict_gpu", Negative, "GPU") + | DR -> + ("restrict_dr", Negative, "DR") + | VIF_locking -> + ("restrict_vif_locking", Negative, "VIFLock") + | Storage_motion -> + ("restrict_storage_xen_motion", Negative, "SXM") + | VGPU -> + ("restrict_vgpu", Negative, "vGPU") + | Integrated_GPU -> + ("restrict_integrated_gpu_passthrough", Negative, "iGPU") + | VSS -> + ("restrict_vss", Negative, "VSS") + | Guest_agent_auto_update -> + ("restrict_guest_agent_auto_update", Negative, "GAAU") + | PCI_device_for_auto_update -> + ("restrict_pci_device_for_auto_update", Negative, "PciAU") + | Xen_motion -> + ("restrict_xen_motion", Negative, "Live_migration") + | Guest_ip_setting -> + ("restrict_guest_ip_setting", Negative, "GuestIP") + | AD -> + ("restrict_ad", Negative, "AD") + | Nested_virt -> + ("restrict_nested_virt", Negative, "Nested_virt") + | Live_patching -> + ("restrict_live_patching", Negative, "Live_patching") + | Live_set_vcpus -> + ("restrict_set_vcpus_number_live", Negative, "Live_set_vcpus") + | PVS_proxy -> + ("restrict_pvs_proxy", Negative, "PVS_proxy") + | IGMP_snooping -> + ("restrict_igmp_snooping", Negative, "IGMP_snooping") + | RPU -> + ("restrict_rpu", Negative, "RPU") + | Pool_size -> + ("restrict_pool_size", Negative, "Pool_size") + | CBT -> + ("restrict_cbt", Negative, "CBT") + | USB_passthrough -> + ("restrict_usb_passthrough", Negative, "USB_passthrough") + | Network_sriov -> + ("restrict_network_sriov", Negative, "Network_sriov") + | Corosync -> + ("restrict_corosync", Negative, "Corosync") + | Cluster_address -> + ("restrict_cluster_address", Negative, "Cluster_address") + | Zstd_export -> + ("restrict_zstd_export", Negative, "Zstd_export") + | Pool_secret_rotation -> + ("restrict_pool_secret_rotation", Negative, "Pool_secret_rotation") + | Certificate_verification -> + ("restrict_certificate_verification", Negative, "Certificate_verification") + | Updates -> + ("restrict_updates", Negative, "Upd") + | Internal_repo_access -> + ("restrict_internal_repo_access", Negative, "Internal_repo_access") + | VTPM -> + ("restrict_vtpm", Negative, "VTPM") + | VM_groups -> + ("restrict_vm_groups", Negative, "VM_groups") + | VM_start -> + ("restrict_vm_start", Negative, "Start") + | VM_appliance_start -> + ("restrict_vm_appliance_start", Negative, "Start") (* A list of features that must be considered "enabled" by `of_assoc_list` if the feature string is missing from the list. These are existing features @@ -149,52 +189,40 @@ let keys_of_features = let enabled_when_unknown = [Xen_motion; AD; Updates; VM_start; VM_appliance_start] -let name_of_feature f = rpc_of_feature f |> Rpc.string_of_rpc - -let string_of_feature f = - let str, o, _ = List.assoc f keys_of_features in - (str, o) +let all_features = + let length = max_feature - min_feature + 1 in + let start = min_feature in + List.init length (fun i -> feature_of_enum (i + start) |> Option.get) -let tag_of_feature f = - let _, _, tag = List.assoc f keys_of_features in - tag +let name_of_feature f = rpc_of_feature f |> Rpc.string_of_rpc -let all_features = List.map (fun (f, _) -> f) keys_of_features +let is_enabled v = function Positive -> v | Negative -> not v let to_compact_string (s : feature list) = let get_tag f = - let tag = tag_of_feature f in + let _, _, tag = props_of_feature f in if List.mem f s then tag else String.make (String.length tag) ' ' in - let tags = List.map get_tag all_features in - String.concat " " tags + List.map get_tag all_features |> String.concat " " let to_assoc_list (s : feature list) = let get_map f = - let str, o = string_of_feature f in + let str, o, _ = props_of_feature f in let switch = List.mem f s in - let switch = string_of_bool (if o = Positive then switch else not switch) in + let switch = string_of_bool (is_enabled switch o) in (str, switch) in List.map get_map all_features let of_assoc_list l = - let get_feature f = + let enabled f = try - let str, o = string_of_feature f in - let v = bool_of_string (List.assoc str l) in - let v = if o = Positive then v else not v in - if v then Some f else None - with _ -> if List.mem f enabled_when_unknown then Some f else None + let str, o, _ = props_of_feature f in + let v = List.assoc str l in + is_enabled (bool_of_string v) o + with _ -> List.mem f enabled_when_unknown in - (* Filter_map to avoid having to carry the whole xapi-stdext-std - * Note that the following is not tail recursive, in this case I - * have chosen such implementation because the feature list is small - * and the implementation looks readable and fairly self-contained. - * Do not use this pattern for lists that can be long. *) - List.fold_right - (fun f acc -> match get_feature f with Some v -> v :: acc | None -> acc) - all_features [] + List.filter enabled all_features diff --git a/ocaml/xapi-types/secretString.ml b/ocaml/xapi-types/secretString.ml index 781dac8669..b552e46edf 100644 --- a/ocaml/xapi-types/secretString.ml +++ b/ocaml/xapi-types/secretString.ml @@ -24,6 +24,8 @@ let write_to_channel c s = output_string c s let equal = String.equal +let length = String.length + let pool_secret = "pool_secret" let with_cookie t cookies = (pool_secret, t) :: cookies diff --git a/ocaml/xapi-types/secretString.mli b/ocaml/xapi-types/secretString.mli index 82d97eaaa7..1f14b6a9e9 100644 --- a/ocaml/xapi-types/secretString.mli +++ b/ocaml/xapi-types/secretString.mli @@ -16,7 +16,7 @@ * It is still possible to convert it to Rpc.t and recover it that way, * it is not a protection against willfully recovering the protected string * (we do need to send these as parameters in RPCs). - * *) + *) (** a type with no direct conversions to string *) type t @@ -25,6 +25,8 @@ val of_string : string -> t val equal : t -> t -> bool +val length : t -> int + val json_rpc_of_t : t -> Rpc.t val t_of_rpc : Rpc.t -> t diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index e6864bd80e..96f152181e 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -7,7 +7,7 @@ module Helper = struct include Tracing.Propagator.Make (struct include Tracing_propagator.Propagator.Http - let name_span req = req.Http.Request.uri + let name_span req = req.Http.Request.path end) end diff --git a/ocaml/xapi/at_least_once_more.ml b/ocaml/xapi/at_least_once_more.ml index 084cd4c602..f2623c4990 100644 --- a/ocaml/xapi/at_least_once_more.ml +++ b/ocaml/xapi/at_least_once_more.ml @@ -16,6 +16,10 @@ to minimise the number of times we run the operation i.e. if a large set of changes happen we'd ideally like to just execute the function once or twice but not once per thing that changed. *) +module D = Debug.Make (struct let name = "at_least_once_more" end) + +open D + let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute (** Type of the function executed in the background *) @@ -50,7 +54,7 @@ let again (x : manager) = Thread.create (fun () -> (* Always do the operation immediately: thread is only created when work needs doing *) - x.f () ; + log_and_ignore_exn x.f ; while with_lock x.m (fun () -> if x.needs_doing_again then ( @@ -63,7 +67,7 @@ let again (x : manager) = ) ) do - x.f () + log_and_ignore_exn x.f done ) () diff --git a/ocaml/xapi/binpack.ml b/ocaml/xapi/binpack.ml index 14c0405bd7..c805e53565 100644 --- a/ocaml/xapi/binpack.ml +++ b/ocaml/xapi/binpack.ml @@ -98,7 +98,7 @@ let choose l n = (** Return all permutations of a list *) let rec permutations : 'a list -> 'a list list = let rotate n xs = - let a, b = Xapi_stdext_std.Listext.List.chop n xs in + let a, b = Xapi_stdext_std.Listext.List.split_at n xs in b @ a in let insert_at n x xs = rotate (List.length xs - n + 1) (x :: rotate n xs) in diff --git a/ocaml/xapi/cert_refresh.ml b/ocaml/xapi/cert_refresh.ml index 12ab75dc23..213d0abc22 100644 --- a/ocaml/xapi/cert_refresh.ml +++ b/ocaml/xapi/cert_refresh.ml @@ -79,7 +79,7 @@ let host ~__context ~type' = Server_error (cannot_contact_host, [Ref.string_of (HostSet.choose unreachable)]) ) ; - let content = X509.Certificate.encode_pem cert |> Cstruct.to_string in + let content = X509.Certificate.encode_pem cert in (* distribute public part of new cert in pool *) Cert_distrib.distribute_new_host_cert ~__context ~host ~content ; (* replace certs in file system on host *) diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 4d9702bb43..f0a7577964 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -20,19 +20,19 @@ module D = Debug.Make (struct let name = "certificates" end) open D (* Certificate locations: - * a) stunnel external = /etc/xensource/xapi-ssl.pem - * b) stunnel SNI (internal) = /etc/xensource/xapi-pool-tls.pem - * c) user trusted cert folder = /etc/stunnel/certs/ - * d) internal trusted cert folder = /etc/stunnel/certs-pool/ - * e) appliance trusted bundle = /etc/stunnel/xapi-stunnel-ca-bundle.pem - * f) host-in-pool trusted bundle = /etc/stunnel/xapi-pool-ca-bundle.pem - * - * Note that the bundles (e) and (f) are generated automatically using the contents of (c) and (d) respectively *) + * a) stunnel external = /etc/xensource/xapi-ssl.pem + * b) stunnel SNI (internal) = /etc/xensource/xapi-pool-tls.pem + * c) user trusted cert folder = /etc/stunnel/certs/ + * d) internal trusted cert folder = /etc/stunnel/certs-pool/ + * e) appliance trusted bundle = /etc/stunnel/xapi-stunnel-ca-bundle.pem + * f) host-in-pool trusted bundle = /etc/stunnel/xapi-pool-ca-bundle.pem + * + * Note that the bundles (e) and (f) are generated automatically using the contents of (c) and (d) respectively *) type t_trusted = CA_Certificate | CRL let pem_of_string x = - match Cstruct.of_string x |> X509.Certificate.decode_pem with + match X509.Certificate.decode_pem x with | Error _ -> D.error "pem_of_string: failed to parse certificate string" ; raise @@ -75,7 +75,7 @@ let to_string = function CA_Certificate -> "CA certificate" | CRL -> "CRL" adding a colon between every octet, in uppercase. *) let pp_hash hash = - let hex = Hex.(show @@ of_cstruct hash) in + let hex = Hex.(show @@ of_string hash) in let length = (3 * String.length hex / 2) - 1 in let value_of i = match (i + 1) mod 3 with @@ -441,9 +441,7 @@ let get_internal_server_certificate () = open Rresult let hostnames_of_pem_cert pem = - Cstruct.of_string pem - |> X509.Certificate.decode_pem - >>| X509.Certificate.hostnames + X509.Certificate.decode_pem pem >>| X509.Certificate.hostnames let install_server_certificate ~pem_chain ~pem_leaf ~pkcs8_private_key ~path = let installation = diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index 064c7e47e3..6776220df4 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -18,10 +18,9 @@ type t_trusted = CA_Certificate | CRL val pem_of_string : string -> X509.Certificate.t -val pp_hash : Cstruct.t -> string +val pp_hash : string -> string -val pp_fingerprint : - hash_type:Mirage_crypto.Hash.hash -> X509.Certificate.t -> string +val pp_fingerprint : hash_type:Digestif.hash' -> X509.Certificate.t -> string val validate_name : t_trusted -> string -> unit diff --git a/ocaml/xapi/certificates_sync.ml b/ocaml/xapi/certificates_sync.ml index a9691adf29..2ab3492ffa 100644 --- a/ocaml/xapi/certificates_sync.ml +++ b/ocaml/xapi/certificates_sync.ml @@ -57,10 +57,8 @@ let get_server_cert path = | Error msg -> Error (`Msg (msg, [])) | Ok cert -> - let host_pem = cert.GP.host_cert in let* host_cert = - Cstruct.of_string host_pem - |> X509.Certificate.decode_pem + X509.Certificate.decode_pem cert.GP.host_cert |> R.reword_error (fun (`Msg msg) -> D.info {|Failed to decode certificate because "%s"|} msg ; `Msg (server_certificate_invalid, []) diff --git a/ocaml/xapi/config_file_sync.ml b/ocaml/xapi/config_file_sync.ml index 1a49ed0188..b765f1ceae 100644 --- a/ocaml/xapi/config_file_sync.ml +++ b/ocaml/xapi/config_file_sync.ml @@ -58,7 +58,7 @@ let config_file_sync_handler (req : Http.Request.t) s _ = Xapi_http.with_context "Syncing dom0 config files over HTTP" req s (fun __context -> let uri = - String.split '/' req.Http.Request.uri |> List.filter (fun x -> x <> "") + String.split '/' req.Http.Request.path |> List.filter (fun x -> x <> "") in req.Http.Request.close <- true ; debug "sending headers" ; diff --git a/ocaml/xapi/console.ml b/ocaml/xapi/console.ml index 03cb4bf955..b812cf65c7 100644 --- a/ocaml/xapi/console.ml +++ b/ocaml/xapi/console.ml @@ -185,7 +185,7 @@ let console_of_request __context req = let db = Context.database_of __context in let is_vm, _ = let module DB = - (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS) + (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS2) in match DB.get_table_from_ref db _ref with | Some c when c = Db_names.vm -> diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index b71ed4ca23..a49c8ecd1b 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -504,11 +504,40 @@ let get_client_ip context = let get_user_agent context = match context.origin with Internal -> None | Http (rq, _) -> rq.user_agent -let with_tracing ?originator ~__context name f = +let finally_destroy_context ~__context f = + let tracing = __context.tracing in + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> f __context) + (fun () -> + __context.tracing <- tracing ; + destroy __context ; + __context.tracing <- None + ) + +let with_context ?http_other_config ?quiet ?subtask_of ?session_id ?database + ?task_in_database ?task_description ?origin task_name f = + let __context = + make ?http_other_config ?quiet ?subtask_of ?session_id ?database + ?task_in_database ?task_description ?origin task_name + in + finally_destroy_context ~__context f + +let with_subcontext ~__context ?task_in_database task_name f = + let __context = make_subcontext ~__context ?task_in_database task_name in + finally_destroy_context ~__context f + +let with_forwarded_task ?http_other_config ?session_id ?origin task_id f = + let __context = + from_forwarded_task ?http_other_config ?session_id ?origin task_id + in + finally_destroy_context ~__context f + +let with_tracing ?(attributes = []) ?originator ~__context name f = let open Tracing in let parent = __context.tracing in let span_attributes = Attributes.attr_of_originator originator + @ attributes @ make_attributes ~task_id:__context.task_id ?session_id:__context.session_id () in diff --git a/ocaml/xapi/context.mli b/ocaml/xapi/context.mli index 34e51afd2e..ac3250f856 100644 --- a/ocaml/xapi/context.mli +++ b/ocaml/xapi/context.mli @@ -146,7 +146,50 @@ val complete_tracing : ?error:exn * Printexc.raw_backtrace -> t -> unit val tracing_of : t -> Tracing.Span.t option +val finally_destroy_context : __context:t -> (t -> 'a) -> 'a +(** [finally_destroy_context ~context f] executes [f ~__context] and then + ensure [__context] is destroyed.*) + +val with_context : + ?http_other_config:(string * string) list + -> ?quiet:bool + -> ?subtask_of:API.ref_task + -> ?session_id:API.ref_session + -> ?database:Xapi_database.Db_ref.t + -> ?task_in_database:bool + -> ?task_description:string + -> ?origin:origin + -> string + -> (t -> 'a) + -> 'a +(** [with_context ?http_other_config ?quiet ?subtask_of ?session_id ?database + ?task_in_database ?task_description ?origin name f] creates a + context [__context], executes [f ~__context] and then ensure [__context] is + destroyed.*) + +val with_subcontext : + __context:t -> ?task_in_database:bool -> string -> (t -> 'a) -> 'a +(** [with_subcontext ~__context ?task_in_database name] creates a subcontext + [__context], executes [f ~__context] and then ensure `__context` is + destroyed.*) + +val with_forwarded_task : + ?http_other_config:(string * string) list + -> ?session_id:API.ref_session + -> ?origin:origin + -> API.ref_task + -> (t -> 'a) + -> 'a +(** [with_forwarded_task ?http_other_config ?session_id ?origin task f] + creates a context form frowarded task [task], executes [f ~__context] and + then ensure [__context] is destroyed.*) + val with_tracing : - ?originator:string -> __context:t -> string -> (t -> 'a) -> 'a + ?attributes:(string * string) list + -> ?originator:string + -> __context:t + -> string + -> (t -> 'a) + -> 'a val set_client_span : t -> Tracing.Span.t option diff --git a/ocaml/xapi/cpuid_helpers.ml b/ocaml/xapi/cpuid_helpers.ml index 1bf6731efa..e453d53a93 100644 --- a/ocaml/xapi/cpuid_helpers.ml +++ b/ocaml/xapi/cpuid_helpers.ml @@ -12,8 +12,6 @@ * GNU Lesser General Public License for more details. *) -open Xapi_globs - module D = Debug.Make (struct let name = "cpuid_helpers" end) open D @@ -24,20 +22,19 @@ let features_t t = (Xenops_interface.CPU_policy.of_string t) Xenops_interface.CPU_policy.to_string -let features = - Map_check.(field Xapi_globs.cpu_info_features_key (features_t `vm)) +let features = Map_check.(field Constants.cpu_info_features_key (features_t `vm)) let features_pv = - Map_check.(field Xapi_globs.cpu_info_features_pv_key (features_t `host)) + Map_check.(field Constants.cpu_info_features_pv_key (features_t `host)) let features_hvm = - Map_check.(field Xapi_globs.cpu_info_features_hvm_key (features_t `host)) + Map_check.(field Constants.cpu_info_features_hvm_key (features_t `host)) let features_pv_host = - Map_check.(field Xapi_globs.cpu_info_features_pv_host_key (features_t `host)) + Map_check.(field Constants.cpu_info_features_pv_host_key (features_t `host)) let features_hvm_host = - Map_check.(field Xapi_globs.cpu_info_features_hvm_host_key (features_t `host)) + Map_check.(field Constants.cpu_info_features_hvm_host_key (features_t `host)) let cpu_count = Map_check.(field "cpu_count" int) @@ -45,6 +42,8 @@ let socket_count = Map_check.(field "socket_count" int) let threads_per_core = Map_check.(field "threads_per_core" int) +let nr_nodes = Map_check.(field "nr_nodes" int) + let vendor = Map_check.(field "vendor" string) let get_flags_for_vm ~__context domain_type cpu_info = @@ -55,7 +54,7 @@ let get_flags_for_vm ~__context domain_type cpu_info = | `pv -> features_pv in - let vendor = List.assoc cpu_info_vendor_key cpu_info in + let vendor = List.assoc Constants.cpu_info_vendor_key cpu_info in let migration = Map_check.getf features_field cpu_info in (vendor, migration) @@ -124,16 +123,18 @@ let assert_vm_is_compatible ~__context ~vm ~host = get_host_compatibility_info ~__context ~domain_type ~host () in let vm_cpu_info = vm_rec.API.vM_last_boot_CPU_flags in - if List.mem_assoc cpu_info_vendor_key vm_cpu_info then ( + if List.mem_assoc Constants.cpu_info_vendor_key vm_cpu_info then ( (* Check the VM was last booted on a CPU with the same vendor as this host's CPU. *) - let vm_cpu_vendor = List.assoc cpu_info_vendor_key vm_cpu_info in + let vm_cpu_vendor = + List.assoc Constants.cpu_info_vendor_key vm_cpu_info + in debug "VM last booted on CPU of vendor %s; host CPUs are of vendor %s" vm_cpu_vendor host_cpu_vendor ; if vm_cpu_vendor <> host_cpu_vendor then fail "VM last booted on a host which had a CPU from a different vendor." ) ; - if List.mem_assoc cpu_info_features_key vm_cpu_info then ( + if List.mem_assoc Constants.cpu_info_features_key vm_cpu_info then ( (* Check the VM was last booted on a CPU whose features are a subset of the features of this host's CPU. *) let vm_cpu_features = Map_check.getf features vm_cpu_info in debug diff --git a/ocaml/xapi/cpuid_helpers.mli b/ocaml/xapi/cpuid_helpers.mli index ff672b884a..c909344ed9 100644 --- a/ocaml/xapi/cpuid_helpers.mli +++ b/ocaml/xapi/cpuid_helpers.mli @@ -31,6 +31,8 @@ val socket_count : int Map_check.field val threads_per_core : int Map_check.field +val nr_nodes : int Map_check.field + val features : [`vm] Xenops_interface.CPU_policy.t Map_check.field val features_pv : [`host] Xenops_interface.CPU_policy.t Map_check.field diff --git a/ocaml/xapi/create_misc.ml b/ocaml/xapi/create_misc.ml index cd0a97b411..cf411f0468 100644 --- a/ocaml/xapi/create_misc.ml +++ b/ocaml/xapi/create_misc.ml @@ -48,11 +48,11 @@ type host_info = { (** The format of the response looks like * # xen-livepatch list - * ID | status - * ----------------------------------------+------------ - * hp_1_1 | CHECKED - * hp_2_1 | APPLIED - * hp_3_2 | APPLIED *) + * ID | status | metadata + * ----------------------------------------+------------+--------------- + * hp_1_1 | CHECKED | + * hp_2_1 | APPLIED | + * hp_3_2 | APPLIED | *) let make_xen_livepatch_list () = let lines = try @@ -63,8 +63,8 @@ let make_xen_livepatch_list () = let patches = List.fold_left (fun acc l -> - match List.map String.trim (Xstringext.String.split ~limit:2 '|' l) with - | [key; "APPLIED"] -> + match List.map String.trim (String.split_on_char '|' l) with + | key :: "APPLIED" :: _ -> key :: acc | _ -> acc @@ -76,10 +76,12 @@ let make_xen_livepatch_list () = (** The format of the response looks like * # kpatch list * Loaded patch modules: - * kpatch_hp_1_1 - * kpatch_hp_2_1 - - * Installed patch modules: *) + * lp_4_19_19__8_0_32_xs8__4_19_19__8_0_33_xs8 [enabled] + * lp_4_19_19__8_0_20_xs8__4_19_19__8_0_21_xs8 [enabled] + * + * Installed patch modules: + * + * Only patch name are returned, status are excluded. *) let make_kpatch_list () = let start_line = "Loaded patch modules:" in let end_line = "Installed patch modules:" in @@ -99,7 +101,14 @@ let make_kpatch_list () = | line :: rest -> let line' = String.trim line in if line' <> "" && started then - loop (line' :: acc) true rest + let patch_name = + match String.split_on_char ' ' line' with + | patch :: _ -> + patch + | [] -> + line' + in + loop (patch_name :: acc) true rest else loop acc started rest in @@ -307,7 +316,7 @@ and create_domain_zero_console_record_with_protocol ~__context ~domain_zero_ref let location = Uri.( make ~scheme:"https" ~host:address ~path:Constants.console_uri - ~query:[("ref", [Ref.string_of domain_zero_ref])] + ~query:[("ref", [Ref.string_of console_ref])] () |> to_string ) @@ -434,10 +443,6 @@ let create_root_user ~__context = if all = [] then Db.User.create ~__context ~ref ~fullname ~short_name ~uuid ~other_config:[] -let get_xapi_verstring () = - Printf.sprintf "%d.%d" Xapi_version.xapi_version_major - Xapi_version.xapi_version_minor - (** Create assoc list of Supplemental-Pack information. * The package information is taking from the [XS-REPOSITORY] XML file in the package * directory. @@ -531,8 +536,7 @@ let make_software_version ~__context host_info = Xapi_globs.software_version () @ v6_version @ [ - (Xapi_globs._xapi_version, get_xapi_verstring ()) - ; ("xapi_build", Xapi_version.version) + ("xapi_build", Xapi_version.version) ; ("xen", Option.value ~default:"(unknown)" host_info.xen_verstring) ; ("linux", host_info.linux_verstring) ; ("xencenter_min", Xapi_globs.xencenter_min_verstring) @@ -572,6 +576,7 @@ let create_host_cpu ~__context host_info = ("cpu_count", string_of_int cpu_info.cpu_count) ; ("socket_count", string_of_int cpu_info.socket_count) ; ("threads_per_core", string_of_int cpu_info.threads_per_core) + ; ("nr_nodes", string_of_int cpu_info.nr_nodes) ; ("vendor", cpu_info.vendor) ; ("speed", cpu_info.speed) ; ("modelname", cpu_info.modelname) @@ -579,16 +584,16 @@ let create_host_cpu ~__context host_info = ; ("model", cpu_info.model) ; ("stepping", cpu_info.stepping) ; ("flags", cpu_info.flags) - ; ( Xapi_globs.cpu_info_features_pv_key + ; ( Constants.cpu_info_features_pv_key , CPU_policy.to_string cpu_info.features_pv ) - ; ( Xapi_globs.cpu_info_features_hvm_key + ; ( Constants.cpu_info_features_hvm_key , CPU_policy.to_string cpu_info.features_hvm ) - ; ( Xapi_globs.cpu_info_features_hvm_host_key + ; ( Constants.cpu_info_features_hvm_host_key , CPU_policy.to_string cpu_info.features_hvm_host ) - ; ( Xapi_globs.cpu_info_features_pv_host_key + ; ( Constants.cpu_info_features_pv_host_key , CPU_policy.to_string cpu_info.features_pv_host ) ] @@ -597,11 +602,12 @@ let create_host_cpu ~__context host_info = let old_cpu_info = Db.Host.get_cpu_info ~__context ~self:host in debug "create_host_cpuinfo: setting host cpuinfo: socket_count=%d, \ - cpu_count=%d, threads_per_core=%d, features_hvm=%s, features_pv=%s, \ - features_hvm_host=%s, features_pv_host=%s" + cpu_count=%d, threads_per_core=%d, nr_nodes=%d, features_hvm=%s, \ + features_pv=%s, features_hvm_host=%s, features_pv_host=%s" (Map_check.getf socket_count cpu) (Map_check.getf cpu_count cpu) (Map_check.getf threads_per_core cpu) + (Map_check.getf nr_nodes cpu) (Map_check.getf features_hvm cpu |> CPU_policy.to_string) (Map_check.getf features_pv cpu |> CPU_policy.to_string) (Map_check.getf features_hvm_host cpu |> CPU_policy.to_string) @@ -698,8 +704,8 @@ let create_pool_cpuinfo ~__context = ("vendor", "") ; ("socket_count", "0") ; ("cpu_count", "0") - ; (Xapi_globs.cpu_info_features_pv_host_key, "") - ; (Xapi_globs.cpu_info_features_hvm_host_key, "") + ; (Constants.cpu_info_features_pv_host_key, "") + ; (Constants.cpu_info_features_hvm_host_key, "") ] in let pool_cpuinfo = List.fold_left merge zero all_host_cpus in diff --git a/ocaml/xapi/create_storage.ml b/ocaml/xapi/create_storage.ml index 19aff8ecbb..edc5502032 100644 --- a/ocaml/xapi/create_storage.ml +++ b/ocaml/xapi/create_storage.ml @@ -79,24 +79,20 @@ let maybe_create_pbd rpc session_id sr device_config me = (fun self -> Client.PBD.get_host ~rpc ~session_id ~self = me) pbds in - (* Check not more than 1 pbd in the database *) - let pbds = - if List.length pbds > 1 then ( - (* shouldn't happen... delete all but first pbd to make db consistent again *) - List.iter - (fun pbd -> Client.PBD.destroy ~rpc ~session_id ~self:pbd) - (List.tl pbds) ; - [List.hd pbds] - ) else - pbds - in - if pbds = [] (* If there's no PBD, create it *) then + let create () : [`PBD] Ref.t = Client.PBD.create ~rpc ~session_id ~host:me ~sR:sr ~device_config ~other_config:[] - else - List.hd pbds - -(* Otherwise, return the current one *) + in + (* Ensure there's a single PBD *) + match pbds with + | [] -> + ignore (create ()) + | [_] -> + () + | _ :: pbds -> + (* shouldn't happen... delete all but first pbd to make db consistent + again *) + List.iter (fun pbd -> Client.PBD.destroy ~rpc ~session_id ~self:pbd) pbds let maybe_remove_tools_sr rpc session_id __context = let srs = Db.SR.get_all ~__context in @@ -153,17 +149,13 @@ let initialise_storage (me : API.ref_host) rpc session_id __context : unit = List.filter (fun (_, pbd_rec) -> pbd_rec.API.pBD_host = master) pbds in let maybe_create_pbd_for_shared_sr s = - let _, mpbd_rec = - List.find (fun (_, pbdr) -> pbdr.API.pBD_SR = s) master_pbds - in - let master_devconf = mpbd_rec.API.pBD_device_config in - let my_devconf = List.remove_assoc "SRmaster" master_devconf in - (* this should never be used *) - maybe_create_pbd rpc session_id s my_devconf me + List.find_opt (fun (_, pbdr) -> pbdr.API.pBD_SR = s) master_pbds + |> Option.iter @@ fun (_, mpbd_rec) -> + let master_devconf = mpbd_rec.API.pBD_device_config in + let my_devconf = List.remove_assoc "SRmaster" master_devconf in + try maybe_create_pbd rpc session_id s my_devconf me with _ -> () in - List.iter - (fun s -> try ignore (maybe_create_pbd_for_shared_sr s) with _ -> ()) - shared_sr_refs + List.iter maybe_create_pbd_for_shared_sr shared_sr_refs in let other_config = try @@ -173,9 +165,8 @@ let initialise_storage (me : API.ref_host) rpc session_id __context : unit = in if not - (List.mem_assoc Xapi_globs.sync_create_pbds other_config - && List.assoc Xapi_globs.sync_create_pbds other_config - = Xapi_globs.sync_switch_off + (List.assoc_opt Xapi_globs.sync_create_pbds other_config + = Some Xapi_globs.sync_switch_off ) then ( debug "Creating PBDs for shared SRs" ; diff --git a/ocaml/xapi/db.ml b/ocaml/xapi/db.ml index 4b4b6c2dee..f343086a2d 100644 --- a/ocaml/xapi/db.ml +++ b/ocaml/xapi/db.ml @@ -23,5 +23,5 @@ let is_valid_ref __context r = false else let t = Context.database_of __context in - let module DB = (val Db_cache.get t : Db_interface.DB_ACCESS) in + let module DB = (val Db_cache.get t : Db_interface.DB_ACCESS2) in DB.is_valid_ref t (Ref.string_of r) diff --git a/ocaml/xapi/db_gc.ml b/ocaml/xapi/db_gc.ml index c8c6830936..12e0284125 100644 --- a/ocaml/xapi/db_gc.ml +++ b/ocaml/xapi/db_gc.ml @@ -149,11 +149,10 @@ let detect_rolling_upgrade ~__context = (* NB: it is critical this code runs once in the master of a pool of one before the dbsync, since this is the only time at which the master's Version will be out of sync with its database record *) let actually_in_progress = - Helpers.pool_has_different_host_platform_versions ~__context + Helpers.Checks.RPU.pool_has_different_host_platform_versions ~__context in (* Check the current state of the Pool as indicated by the Pool.other_config:rolling_upgrade_in_progress *) - let pools = Db.Pool.get_all ~__context in - match pools with + match Db.Pool.get_all ~__context with | [] -> debug "Ignoring absence of pool record in detect_rolling_upgrade: this is \ @@ -165,16 +164,18 @@ let detect_rolling_upgrade ~__context = in (* Resynchronise *) if actually_in_progress <> pool_says_in_progress then ( - let platform_versions = + let host_versions = List.map (fun host -> - Helpers.version_string_of ~__context (Helpers.LocalObject host) + Helpers.Checks.RPU.get_software_versions ~__context + (Helpers.LocalObject host) + |> Helpers.Checks.versions_string_of ) (Db.Host.get_all ~__context) in debug "xapi platform version = %s; host platform versions = [ %s ]" (Xapi_version.platform_version ()) - (String.concat "; " platform_versions) ; + (String.concat "; " host_versions) ; warn "Pool thinks rolling upgrade%s in progress but Host version \ numbers indicate otherwise; correcting" diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index 202b51cc5e..8a8f116b55 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -28,7 +28,7 @@ let gc_connector ~__context get_all get_record 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_ACCESS) + (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS2) in let all_refs = get_all ~__context in let do_gc ref = @@ -293,6 +293,12 @@ let gc_vtpms ~__context = let probation_pending_tasks = Hashtbl.create 53 +let sort_and_split compare n tasks = + if List.length tasks <= n then + (tasks, []) + else + Listext.List.split_at n (List.sort compare tasks) + let timeout_tasks ~__context = let all_tasks = Db.Task.get_internal_records_where ~__context @@ -368,32 +374,20 @@ let timeout_tasks ~__context = let lucky, unlucky = if List.length young <= Xapi_globs.max_tasks then (young, []) (* keep them all *) - else (* Compute how many we'd like to delete *) - let overflow = List.length young - Xapi_globs.max_tasks in - (* We only consider deleting completed tasks *) + else (* We only consider deleting completed tasks *) let completed, pending = List.partition (fun (_, t) -> TaskHelper.status_is_completed t.Db_actions.task_status) young in - (* Sort the completed tasks so we delete oldest tasks in preference *) - let completed = - List.sort - (fun (_, t1) (_, t2) -> - compare - (Date.to_unix_time t1.Db_actions.task_finished) - (Date.to_unix_time t2.Db_actions.task_finished) - ) - completed - in - (* From the completes set, choose up to 'overflow' *) - let unlucky, lucky = - if List.length completed > overflow then - Listext.List.chop overflow completed - else - (completed, []) + (* pending tasks limit the amount of completed tasks to keep, negatives + values are equivalent to 0 *) + let limit = Xapi_globs.max_tasks - List.length completed in + (* Reverse compare order so oldest dates (earliest) are sorted last *) + let compare (_, t1) (_, t2) = + Date.compare t2.Db_actions.task_finished t1.Db_actions.task_finished in - (* not enough to delete, oh well *) + let lucky, unlucky = sort_and_split compare limit completed in (* Keep all pending and any which were not chosen from the completed set *) (pending @ lucky, unlucky) in @@ -456,11 +450,8 @@ let timeout_sessions_common ~__context sessions limit session_group = in (* If there are too many young sessions then we need to delete the oldest *) let _, unlucky = - if List.length young <= limit then - (young, []) (* keep them all *) - else (* Need to reverse sort by last active and drop the oldest *) - Listext.List.chop limit - (List.sort (fun (_, a, _) (_, b, _) -> compare b a) young) + let compare (_, a, _) (_, b, _) = compare b a in + sort_and_split compare limit young in let cancel doc sessions = List.iter diff --git a/ocaml/xapi/dbsync_master.ml b/ocaml/xapi/dbsync_master.ml index f8316b8199..dbf6080f45 100644 --- a/ocaml/xapi/dbsync_master.ml +++ b/ocaml/xapi/dbsync_master.ml @@ -25,8 +25,7 @@ open Recommendations (* create pool record (if master and not one already there) *) let create_pool_record ~__context = - let pools = Db.Pool.get_all ~__context in - if pools = [] then + if Db.Pool.get_all ~__context = [] then Db.Pool.create ~__context ~ref:(Ref.make ()) ~uuid:(Uuidx.to_string (Uuidx.make ())) ~name_label:"" ~name_description:"" @@ -354,6 +353,7 @@ let update_pool_recommendations_noexn ~__context = (* Update the database to reflect current state. Called for both start of day and after an agent restart. *) let update_env __context = + Db_gc.detect_rolling_upgrade ~__context ; debug "creating root user" ; Create_misc.create_root_user ~__context ; debug "creating pool record" ; diff --git a/ocaml/xapi/dbsync_slave.ml b/ocaml/xapi/dbsync_slave.ml index 366990e269..91bea2d25b 100644 --- a/ocaml/xapi/dbsync_slave.ml +++ b/ocaml/xapi/dbsync_slave.ml @@ -60,6 +60,12 @@ let create_localhost ~__context info = ~license_server:[("address", "localhost"); ("port", "27000")] ~local_cache_sr:Ref.null ~chipset_info:[] ~ssl_legacy:false ~last_software_update:Date.epoch ~last_update_hash:"" + ~ssh_enabled:Constants.default_ssh_enabled + ~ssh_enabled_timeout:Constants.default_ssh_enabled_timeout + ~ssh_expiry:Date.epoch + ~console_idle_timeout:Constants.default_console_idle_timeout + ~ssh_auto_mode:!Xapi_globs.ssh_auto_mode_default + ~secure_boot:false ~software_version:[] in () @@ -129,16 +135,19 @@ let refresh_localhost_info ~__context info = ) else Db.Host.remove_from_other_config ~__context ~self:host ~key:Xapi_globs.host_no_local_storage ; - let script_output = - Helpers.call_script !Xapi_globs.firewall_port_config_script ["check"; "80"] + let status = + match Db.Host.get_https_only ~__context ~self:host with + | true -> + Firewall.Disabled + | false -> + Firewall.Enabled in - try - let network_state = Scanf.sscanf script_output "Port 80 open: %B" Fun.id in - Db.Host.set_https_only ~__context ~self:host ~value:network_state - with _ -> - Helpers.internal_error - "unexpected output from /etc/xapi.d/plugins/firewall-port: %s" - script_output + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Http status (*************** update database tools ******************) (** Record host memory properties in database *) @@ -376,5 +385,44 @@ let update_env __context sync_keys = Create_misc.create_chipset_info ~__context info ) ; switched_sync Xapi_globs.sync_gpus (fun () -> Xapi_pgpu.update_gpus ~__context) ; - + switched_sync Xapi_globs.sync_ssh_status (fun () -> + let ssh_service = !Xapi_globs.ssh_service in + let status = Fe_systemctl.is_active ~service:ssh_service in + Db.Host.set_ssh_enabled ~__context ~self:localhost ~value:status ; + let auto_mode_in_db = + Db.Host.get_ssh_auto_mode ~__context ~self:localhost + in + let ssh_monitor_enabled = + Fe_systemctl.is_active ~service:!Xapi_globs.ssh_monitor_service + in + (* For xs9 when fresh install, the ssh_monitor service is not enabled by default. + If the auto_mode is enabled, we need to enable the ssh_monitor service. + and user may have disabled monitor service by mistake as well, so we need to check the status. *) + if auto_mode_in_db <> ssh_monitor_enabled then + Xapi_host.set_ssh_auto_mode ~__context ~self:localhost + ~value:auto_mode_in_db ; + let console_timeout = + Db.Host.get_console_idle_timeout ~__context ~self:localhost + in + let console_timeout_file_exists = + Sys.file_exists !Xapi_globs.console_timeout_profile_path + in + (* Ensure the console timeout profile file exists if the timeout is configured *) + if console_timeout > 0L && not console_timeout_file_exists then + Xapi_host.set_console_idle_timeout ~__context ~self:localhost + ~value:console_timeout + ) ; + switched_sync Xapi_globs.sync_secure_boot (fun () -> + let result = + try + let contents = Unixext.string_of_file !Xapi_globs.secure_boot_path in + contents.[4] <> '\x00' + with e -> + warn "%s error while reading %S: %s" __FUNCTION__ + !Xapi_globs.secure_boot_path + (Printexc.to_string e) ; + false + in + Db.Host.set_secure_boot ~__context ~self:localhost ~value:result + ) ; remove_pending_guidances ~__context diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 85f4bf030a..8095a5c4bf 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -90,6 +90,7 @@ sexpr tgroup forkexec + unix xapi-idl xapi_aux xapi-stdext-std @@ -138,6 +139,7 @@ clock cohttp cohttp_posix + digestif domain-name ezxenstore.core fmt @@ -177,6 +179,7 @@ sexplib0 sexpr sha + str stunnel tapctl tar @@ -185,6 +188,7 @@ threads.posix tracing tracing_propagator + unix unixpwd uri uuid @@ -238,7 +242,7 @@ xxhash yojson zstd - xapi_host_driver_helpers) + ) (preprocess (per_module ((pps ppx_sexp_conv) @@ -258,7 +262,9 @@ System_domains Xapi_psr Xapi_services - Xapi_udhcpd)))) + Xapi_udhcpd) + ((pps ppx_deriving.enum) + Firewall)))) (library (name xapi_internal_server_only) @@ -269,6 +275,7 @@ xapi_internal_minimal http_lib rpclib.core + unix xapi-types xapi-log xapi-stdext-encodings @@ -296,6 +303,7 @@ threads.posix tracing tracing_propagator + unix xapi-backtrace xapi-client xapi-consts @@ -325,6 +333,7 @@ (package xapi) (modules xapi_main) (libraries + unix xapi_internal xapi_internal_server xapi_internal_minimal diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index 753bb8fdf7..810b30bd80 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -107,7 +107,7 @@ open Xapi_database.Db_action_helper let is_valid_ref db = function | Schema.Value.String r -> ( try - ignore (Database.table_of_ref r db) ; + ignore (Database.table_of_ref (r :> string) db) ; true with _ -> false ) diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 81dcb22bc4..3d7b65c507 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -713,11 +713,15 @@ open Http open Client let lock_vm ~__context ~vm ~task_id op = - (* Note slight race here because we haven't got the master lock *) - Xapi_vm_lifecycle.assert_operation_valid ~__context ~self:vm ~op ~strict:true ; - (* ... small race lives here ... *) - Db.VM.add_to_current_operations ~__context ~self:vm ~key:task_id ~value:op ; - Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm + Helpers.retry ~__context ~doc:task_id ~policy:Helpers.Policy.fail_quickly + (fun () -> + (* Note slight race here because we haven't got the master lock *) + Xapi_vm_lifecycle.assert_operation_valid ~__context ~self:vm ~op + ~strict:true ; + (* ... small race lives here ... *) + Db.VM.add_to_current_operations ~__context ~self:vm ~key:task_id ~value:op ; + Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm + ) let unlock_vm ~__context ~vm ~task_id = Db.VM.remove_from_current_operations ~__context ~self:vm ~key:task_id ; @@ -902,7 +906,7 @@ let handler (req : Request.t) s _ = let address = Db.Host.get_address ~__context ~self:host in let url = Uri.( - make ~scheme:"https" ~host:address ~path:req.Request.uri + make ~scheme:"https" ~host:address ~path:req.Request.path ~query:(List.map (fun (a, b) -> (a, [b])) req.Request.query) () |> to_string diff --git a/ocaml/xapi/export_raw_vdi.ml b/ocaml/xapi/export_raw_vdi.ml index cea32fb553..df3d778d57 100644 --- a/ocaml/xapi/export_raw_vdi.ml +++ b/ocaml/xapi/export_raw_vdi.ml @@ -47,12 +47,18 @@ let localhost_handler rpc session_id vdi (req : Http.Request.t) let copy base_path path size = try debug "Copying VDI contents..." ; - Vhd_tool_wrapper.send ?relative_to:base_path - (Vhd_tool_wrapper.update_task_progress __context) - "none" - (Importexport.Format.to_string format) - s path size "" ; - debug "Copying VDI complete." + match format with + | Qcow -> + Qcow_tool_wrapper.send ?relative_to:base_path + (Qcow_tool_wrapper.update_task_progress __context) + s path size + | Vhd | Tar | Raw -> + Vhd_tool_wrapper.send ?relative_to:base_path + (Vhd_tool_wrapper.update_task_progress __context) + "none" + (Importexport.Format.to_string format) + s path size "" ; + debug "Copying VDI complete." with Unix.Unix_error (Unix.EIO, _, _) -> raise (Api_errors.Server_error @@ -73,7 +79,7 @@ let localhost_handler rpc session_id vdi (req : Http.Request.t) in Http_svr.headers s headers ; match format with - | Raw | Vhd -> + | Raw | Vhd | Qcow -> let size = Db.VDI.get_virtual_size ~__context ~self:vdi in if format = Vhd && size > Constants.max_vhd_size then raise diff --git a/ocaml/xapi/extauth_plugin_ADpbis.ml b/ocaml/xapi/extauth_plugin_ADpbis.ml index 56f723ff6f..ea2dedfccc 100644 --- a/ocaml/xapi/extauth_plugin_ADpbis.ml +++ b/ocaml/xapi/extauth_plugin_ADpbis.ml @@ -942,10 +942,9 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct Db.Host.get_external_auth_service_name ~__context ~self:host ) in - if - List.mem_assoc "domain" config_params - (* legacy test: do we have domain name in config? *) - then (* then config:domain must match service-name *) + (* legacy test: do we have domain name in config? + then config:domain must match service-name *) + if List.mem_assoc "domain" config_params then let _domain = List.assoc "domain" config_params in if service_name <> _domain then raise diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index b3458478e3..837dc429ca 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -91,6 +91,14 @@ let generic_error msg = let fail fmt = Printf.ksprintf generic_error fmt +let is_samba_updated = + (* This is temporary workaround to be compatible for old and new samba, to decouple the merge of xapi and samba *) + let check_file = "/usr/lib64/samba/libxattr-tdb-private-samba.so" in + Sys.file_exists check_file + +let kerberos_opt = + match is_samba_updated with true -> [] | false -> ["--kerberos"] + (** Kerberos Domain Controller. The current implementation does not work with non-standard ports *) module KDC : sig @@ -208,7 +216,7 @@ module Ldap = struct (* * Escape characters according to * https://docs.microsoft.com/en-gb/windows/win32/adsi/search-filter-syntax?redirectedfrom=MSDN#special-characters - * *) + *) let reg_star = {|*|} |> Re.str |> Re.compile @@ -402,7 +410,7 @@ module Ldap = struct let* stdout = try (* Query KDC instead of use domain here - * Just in case cannot resolve domain name from DNS *) + * Just in case cannot resolve domain name from DNS *) let args = [ "ads" @@ -413,8 +421,8 @@ module Ldap = struct ; "--server" ; KDC.server kdc ; "--machine-pass" - ; "--kerberos" ] + @ kerberos_opt @ attrs in let stdout = @@ -440,10 +448,9 @@ module Ldap = struct ; "--server" ; KDC.server kdc ; "--machine-pass" - ; "--kerberos" - ; query - ; key ] + @ kerberos_opt + @ [query; key] in try Helpers.call_script ~env !Xapi_globs.net_cmd args @@ -553,7 +560,7 @@ module Wbinfo = struct * Name : UCC * Alt_Name : ucc.local * SID : S-1-5-21-2850064427-2368465266-4270348630 - * *) + *) let args = ["--domain-info"; from_name] in let* stdout = call_wbinfo args in let key = @@ -614,7 +621,7 @@ module Wbinfo = struct * CHILD1 * GRANDCHILD * UDDCHILD1 - * *) + *) let args = ["--all-domains"] in let* stdout = call_wbinfo args in Ok @@ -686,11 +693,30 @@ module Wbinfo = struct let parse_uid_info stdout = (* looks like one line from /etc/passwd: https://en.wikipedia.org/wiki/Passwd#Password_file *) match String.split_on_char ':' stdout with - | [user_name; _passwd; uid; gid; gecos; _homedir; _shell] -> ( - try Ok {user_name; uid= int_of_string uid; gid= int_of_string gid; gecos} - with _ -> Error () - ) + | user_name :: _passwd :: uid :: gid :: rest -> ( + (* We expect at least homedir and shell at the end *) + let rest = List.rev rest in + match rest with + | _shell :: _homedir :: tail -> ( + (* Rev it back to original order *) + let tail = List.rev tail in + let gecos = String.concat ":" tail in + try + Ok + { + user_name + ; uid= int_of_string uid + ; gid= int_of_string gid + ; gecos + } + with _ -> Error () + ) + | _ -> + debug "%s uid_info format error: %s" __FUNCTION__ stdout ; + Error () + ) | _ -> + debug "%s uid_info format error: %s" __FUNCTION__ stdout ; Error () let uid_info_of_uid (uid : int) = @@ -775,7 +801,7 @@ end let kdcs_of_domain domain = try Helpers.call_script ~log_output:On_failure net_cmd - ["lookup"; "kdc"; domain; "-d"; debug_level (); "--kerberos"] + (["lookup"; "kdc"; domain; "-d"; debug_level ()] @ kerberos_opt) (* 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 *) @@ -789,9 +815,9 @@ let workgroup_from_server kdc = 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 (); "--kerberos" - ] + (["ads"; "lookup"; "-S"; KDC.server kdc; "-d"; debug_level ()] + @ kerberos_opt + ) |> Xapi_cmd_result.of_output ~sep:':' ~key |> Result.ok with _ -> @@ -824,36 +850,47 @@ let config_winbind_daemon ~workgroup ~netbios_name ~domain = * upgrade to samba packages with this capacity *) if !Xapi_globs.winbind_allow_kerberos_auth_fallback then "yes" else "no" in + let version_conf = + match is_samba_updated with + | false -> + [Printf.sprintf "allow kerberos auth fallback = %s" allow_fallback] + | true -> + [ + "client use kerberos = required" + ; "sync machine password to keytab = \ + /etc/krb5.keytab:account_name:sync_etypes:sync_kvno:machine_password" + ] + in ( match (workgroup, netbios_name, domain) with | Some wkgroup, Some netbios, Some dom -> - [ - "# autogenerated by xapi" - ; "[global]" - ; "kerberos method = secrets and keytab" - ; Printf.sprintf "realm = %s" dom - ; "security = ADS" - ; "template shell = /bin/bash" - ; "winbind refresh tickets = yes" - ; "winbind enum groups = no" - ; "winbind enum users = no" - ; "winbind scan trusted domains = yes" - ; "winbind use krb5 enterprise principals = yes" - ; Printf.sprintf "winbind cache time = %d" !Xapi_globs.winbind_cache_time - ; Printf.sprintf "machine password timeout = 0" - ; Printf.sprintf "kerberos encryption types = %s" - (Kerberos_encryption_types.Winbind.to_string - !Xapi_globs.winbind_kerberos_encryption_type - ) - ; Printf.sprintf "workgroup = %s" wkgroup - ; Printf.sprintf "netbios name = %s" netbios - ; "idmap config * : range = 3000000-3999999" - ; Printf.sprintf "idmap config %s: backend = rid" dom - ; Printf.sprintf "idmap config %s: range = 2000000-2999999" dom - ; Printf.sprintf "log level = %s" (debug_level ()) - ; Printf.sprintf "allow kerberos auth fallback = %s" allow_fallback - ; "idmap config * : backend = tdb" - ; "" (* Empty line at the end *) - ] + ["# autogenerated by xapi"; "[global]"] + @ version_conf + @ [ + "kerberos method = secrets and keytab" + ; Printf.sprintf "realm = %s" dom + ; "security = ADS" + ; "template shell = /bin/bash" + ; "winbind refresh tickets = yes" + ; "winbind enum groups = no" + ; "winbind enum users = no" + ; "winbind scan trusted domains = yes" + ; "winbind use krb5 enterprise principals = yes" + ; Printf.sprintf "winbind cache time = %d" + !Xapi_globs.winbind_cache_time + ; Printf.sprintf "machine password timeout = 0" + ; Printf.sprintf "kerberos encryption types = %s" + (Kerberos_encryption_types.Winbind.to_string + !Xapi_globs.winbind_kerberos_encryption_type + ) + ; Printf.sprintf "workgroup = %s" wkgroup + ; Printf.sprintf "netbios name = %s" netbios + ; "idmap config * : range = 3000000-3999999" + ; Printf.sprintf "idmap config %s: backend = rid" dom + ; Printf.sprintf "idmap config %s: range = 2000000-2999999" dom + ; Printf.sprintf "log level = %s" (debug_level ()) + ; "idmap config * : backend = tdb" + ; "" (* Empty line at the end *) + ] | _ -> ["# autogenerated by xapi"; "[global]"; "" (* Empty line at the end *)] ) @@ -932,7 +969,7 @@ let clear_machine_account ~service_name = function (* Disable machine account in DC *) let env = [|Printf.sprintf "PASSWD=%s" p|] in let args = - ["ads"; "leave"; "-U"; u; "-d"; debug_level (); "--kerberos"] + ["ads"; "leave"; "-U"; u; "-d"; debug_level ()] @ kerberos_opt in try Helpers.call_script ~env net_cmd args |> ignore ; @@ -1204,108 +1241,24 @@ end module RotateMachinePassword = struct let task_name = "Rotating machine password" - let tmp_krb5_conf = - Printf.sprintf "%s/pwrotate.krb5" (Filename.get_temp_dir_name ()) - - let kdc_fqdn_of_ip kdc = - let args = - [ - "ads" - ; "lookup" - ; "--server" - ; KDC.server kdc - ; "--kerberos" - ; "-d" - ; debug_level () - ] - in - Helpers.call_script !Xapi_globs.net_cmd args ~log_output:On_failure - |> Xapi_cmd_result.of_output ~sep:':' ~key:"Domain Controller" - - let generate_krb5_tmp_config ~domain ~kdc_fqdn = - (* Configure which server to change the password - * https://web.mit.edu/kerberos/krb5-devel/doc/admin/conf_files/krb5_conf.html *) - let realm = String.uppercase_ascii domain in - let domain_netbios = - Wbinfo.domain_name_of ~target_name_type:NetbiosName ~from_name:domain - |> Result.get_ok - in - let winbind_krb5 = Ldap.krb5_conf_path ~domain_netbios in - let include_item = - if Sys.file_exists winbind_krb5 then - [Printf.sprintf "include %s" winbind_krb5] - else - [] - in - - [ - "# autogenerated by xapi" - ; "[libdefaults]" - ; Printf.sprintf "default_realm = %s" realm - ; "[realms]" - ; Printf.sprintf "%s={" realm - ; Printf.sprintf "kpasswd_server=%s" kdc_fqdn - ; Printf.sprintf "kdc=%s" kdc_fqdn - ; "}" (* include winbind generated configure if exists *) - ] - @ include_item - @ [""] - (* Empty line at the end *) - |> String.concat "\n" - |> Xapi_stdext_unix.Unixext.write_string_to_file tmp_krb5_conf - - let clear_tmp_krb5_conf () = - if !Xapi_globs.winbind_keep_configuration then - () - else - try Sys.remove tmp_krb5_conf - with e -> - debug "Failed to remove tmp keytab file %s" (ExnHelper.string_of_exn e) - let rotate () = let now = Unix.time () in let now_str = string_of_float now in try - let {service_name; machine_pwd_last_change_time; _} = - get_domain_info_from_db () + let machine_pwd_last_change_time = + (get_domain_info_from_db ()).machine_pwd_last_change_time in match machine_pwd_last_change_time with | Some time when now < time +. !Xapi_globs.winbind_machine_pwd_timeout -> () - | _ -> ( - match ClosestKdc.from_db service_name with - | Some kdc -> - debug "%s started at %s" task_name now_str ; - (* Samba expect fqdn instead of IP *) - let kdc_fqdn = kdc_fqdn_of_ip kdc in - generate_krb5_tmp_config ~domain:service_name ~kdc_fqdn ; - let env = [|Printf.sprintf "KRB5_CONFIG=%s" tmp_krb5_conf|] in - let args = - [ - "ads" - ; "changetrustpw" - ; "--kerberos" - ; "--server" - ; kdc_fqdn - ; "-d" - ; debug_level () - ] - in - finally - (fun () -> - Helpers.call_script ~env net_cmd args ~log_output:Always - |> ignore - ) - (fun () -> clear_tmp_krb5_conf ()) ; + | _ -> + 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 - | _ -> - debug "Xapi database does not has closest KDC, skip this rotation" - ) + 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) @@ -1347,13 +1300,28 @@ module HostsConfFunc (T : LocalHostTag) : HostsConf = struct let name = String.lowercase_ascii name in let domain = String.lowercase_ascii domain in let fqdn = Printf.sprintf "%s.%s" name domain in + let rec add_hostname pre line = + match line with + | ip :: alias when ip = T.local_ip -> + (* Add localhost IP *) + add_hostname [ip] alias + | sp :: left when sp = "" -> + (* Add space to reserve the indent *) + add_hostname (pre @ [sp]) left + | alias :: left -> + (* hosts entry: ip fqdn alias1 alias2 ... *) + pre @ [fqdn; name; alias] @ left + | [] -> + failwith "Can not add local hostname to non local IP" + in + match interest line with | false -> line | true -> String.split_on_char sep line |> List.filter (fun x -> x <> name && x <> fqdn) - |> (fun x -> match op with Add -> x @ [name; fqdn] | Remove -> x) + |> (fun x -> match op with Add -> add_hostname [] x | Remove -> x) |> String.concat sep_str let leave ~name ~domain ~lines = @@ -1369,8 +1337,8 @@ module HostsConfFunc (T : LocalHostTag) : HostsConf = struct | false -> (* Does not found and updated the conf, then add one *) [ - Printf.sprintf "%s%s%s%s%s.%s" T.local_ip sep_str name sep_str name - domain + Printf.sprintf "%s%s%s.%s%s%s" T.local_ip sep_str name domain sep_str + name ] @ x end @@ -1386,18 +1354,73 @@ module ConfigHosts = struct let join ~name ~domain = read_lines ~path |> fun lines -> HostsConfIPv4.join ~name ~domain ~lines |> fun lines -> - HostsConfIPv6.join ~name ~domain ~lines + HostsConfIPv6.join ~name ~domain ~lines |> fun x -> + x @ [""] (* Add final line break *) |> String.concat "\n" |> write_string_to_file path let leave ~name ~domain = read_lines ~path |> fun lines -> HostsConfIPv4.leave ~name ~domain ~lines |> fun lines -> - HostsConfIPv6.leave ~name ~domain ~lines + HostsConfIPv6.leave ~name ~domain ~lines |> fun x -> + x @ [""] (* Add final line break *) |> String.concat "\n" |> write_string_to_file path end +module DNSSync = struct + let task_name = "Sync hostname with DNS" + + type t = Register | Unregister + + let handle op hostname netbios_name domain = + (* By default, hostname should equal to netbios_name, just register it to DNS server*) + try + let ops = + match op with Register -> "register" | Unregister -> "unregister" + in + let netbios_fqdn = Printf.sprintf "%s.%s" netbios_name domain in + let args = ["ads"; "dns"] @ [ops] @ ["--machine-pass"] in + Helpers.call_script net_cmd (args @ [netbios_fqdn]) |> ignore ; + if hostname <> netbios_name then + let hostname_fqdn = Printf.sprintf "%s.%s" hostname domain in + (* netbios_name is compressed, op on extra hostname *) + Helpers.call_script net_cmd (args @ [hostname_fqdn]) |> ignore + with e -> + debug "Register/unregister with DNS failed %s" (ExnHelper.string_of_exn e) + + let register hostname netbios_name domain = + handle Register hostname netbios_name domain + + let unregister hostname netbios_name domain = + handle Unregister hostname netbios_name domain + + let sync () = + Server_helpers.exec_with_new_task "sync hostname with DNS" + @@ fun __context -> + let host = Helpers.get_localhost ~__context in + let service_name = + Db.Host.get_external_auth_service_name ~__context ~self:host + in + let netbios_name = + Db.Host.get_external_auth_configuration ~__context ~self:host + |> fun config -> List.assoc_opt "netbios_name" config + in + let hostname = Db.Host.get_hostname ~__context ~self:host in + match netbios_name with + | Some netbios -> + register hostname netbios service_name + | None -> + debug "Netbios name is none, skip sync hostname to DNS" + + let trigger_sync ~start = + debug "Trigger task: %s" task_name ; + Scheduler.add_to_queue task_name + (Scheduler.Periodic !Xapi_globs.winbind_dns_sync_interval) start sync + + let stop_sync () = Scheduler.remove_from_queue task_name +end + let build_netbios_name ~config_params = let key = "netbios-name" in match List.assoc_opt key config_params with @@ -1566,7 +1589,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct * the joined domain (with 1 way trust ) , just return the default value * This is NOT a regression issue of PBIS * PBIS cannot handle such case neither - * *) + *) debug "Fallback to default value as no DC info in xapi database" ; Ok default_account in @@ -1697,8 +1720,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct ; "-d" ; debug_level () ; "--no-dns-updates" - ; "--kerberos" ] + @ kerberos_opt ; ou_param ; dns_hostname_option ] @@ -1721,6 +1744,12 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct ClosestKdc.trigger_update ~start:0. ; RotateMachinePassword.trigger_rotate ~start:0. ; ConfigHosts.join ~domain:service_name ~name:netbios_name ; + let _, _ = + Forkhelpers.execute_command_get_output !Xapi_globs.set_hostname + [get_localhost_name ()] + in + (* Trigger right now *) + DNSSync.trigger_sync ~start:0. ; Winbind.set_machine_account_encryption_type netbios_name ; debug "Succeed to join domain %s" service_name with @@ -1760,9 +1789,12 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct 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 + DNSSync.stop_sync () ; ( match netbios_name with - | Some name -> - ConfigHosts.leave ~domain:service_name ~name + | Some netbios -> + ConfigHosts.leave ~domain:service_name ~name:netbios ; + let hostname = get_localhost_name () in + DNSSync.unregister hostname netbios service_name | _ -> () ) ; @@ -1792,6 +1824,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct ClosestKdc.trigger_update ~start:ClosestKdc.startup_delay ; RotateMachinePassword.trigger_rotate ~start:5. ; Winbind.check_ready_to_serve ~timeout:300. ; + DNSSync.trigger_sync ~start:5. ; let {service_name; netbios_name; _} = get_domain_info_from_db () in match netbios_name with diff --git a/ocaml/xapi/fileserver.ml b/ocaml/xapi/fileserver.ml index 5780a87720..9820a55d5c 100644 --- a/ocaml/xapi/fileserver.ml +++ b/ocaml/xapi/fileserver.ml @@ -63,11 +63,11 @@ let send_file (uri_base : string) (dir : string) (req : Request.t) else if is_external_http && Option.is_some req.Request.host then (* Redirect towards HTTPS *) let host = Option.get req.Request.host in - let path = req.Request.uri in + let path = req.Request.path in let dest = Uri.make ~scheme:"https" ~host ~path () |> Uri.to_string in Http_svr.response_redirect ~req s dest else - let uri = req.Request.uri in + let uri = req.Request.path in try let relative_url = String.sub uri uri_base_len (String.length uri - uri_base_len) diff --git a/ocaml/xapi/firewall.ml b/ocaml/xapi/firewall.ml new file mode 100644 index 0000000000..c9bae62aa3 --- /dev/null +++ b/ocaml/xapi/firewall.ml @@ -0,0 +1,175 @@ +(* + * 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 = __MODULE__ end) + +open D + +type service_type = Dlm | Nbd | Ssh | Vxlan | Http | Xenha [@@deriving enum] + +type status = Enabled | Disabled + +type protocol = TCP | UDP + +(* 1. For firewalld, xapi is always responsible for dynamically controlling + firewalld services. + 2. For legacy iptables compatibility: + - Certain iptables ports (such as 4789 for VXLAN) are managed dynamically. + - Other ports (such as 22 for SSH) do not require dynamic control, as they + are already enabled when the host boots up. + - The `dynamic_control_iptables_port` parameter is used to decide if the + ports should be controlled dynamically when iptables is selected. +*) +type service_info = { + name: string + ; port: int + ; protocol: protocol + ; dynamic_control_iptables_port: bool +} + +let all_service_types = + let length = max_service_type - min_service_type + 1 in + List.init length (fun i -> + service_type_of_enum (min_service_type + i) |> Option.get + ) + +let status_to_string = function Enabled -> "enabled" | Disabled -> "disabled" + +let protocol_to_string = function TCP -> "tcp" | UDP -> "udp" + +let service_type_to_service_info = function + | Dlm -> + { + name= "dlm" + ; port= !Xapi_globs.xapi_clusterd_port + ; protocol= TCP + ; dynamic_control_iptables_port= true + } + | Nbd -> + { + name= "nbd" + ; port= 10809 + ; protocol= TCP + ; dynamic_control_iptables_port= true + } + | Ssh -> + { + name= "ssh" + ; port= 22 + ; protocol= TCP + ; dynamic_control_iptables_port= false + } + | Vxlan -> + { + name= "vxlan" + ; port= 4789 + ; protocol= UDP + ; dynamic_control_iptables_port= true + } + | Http -> + { + name= "xapi-insecure" + ; port= Constants.http_port + ; protocol= TCP + ; dynamic_control_iptables_port= true + } + | Xenha -> + { + name= "xenha" + ; port= Xapi_globs.xha_udp_port + ; protocol= UDP + ; dynamic_control_iptables_port= false + } + +module type FIREWALL = sig + val update_firewall_status : + ?interfaces:string list -> service_type -> status -> unit +end + +module Firewalld : FIREWALL = struct + let update_firewall_status ?(interfaces = []) service status = + if !Xapi_globs.dynamic_control_firewalld_service then ( + let service_option = + match status with + | Enabled -> + "--add-service" + | Disabled -> + "--remove-service" + in + let service_info = service_type_to_service_info service in + ( match interfaces with + | _ :: _ when service = Nbd -> + let interface_list = String.concat ", " interfaces in + debug + "%s: Enable NBD service as the following interfaces are used for \ + NBD: [%s]" + __FUNCTION__ interface_list + | _ -> + () + ) ; + try + Helpers.call_script !Xapi_globs.firewall_cmd + [service_option; service_info.name] + |> ignore + with e -> + error + "%s: Failed to update firewall service (%s) to (%s) with error: %s" + __FUNCTION__ service_info.name (status_to_string status) + (Printexc.to_string e) ; + Helpers.internal_error "Failed to update firewall service (%s)" + service_info.name + ) +end + +module Iptables : FIREWALL = struct + let update_firewall_status ?(interfaces = []) service status = + let service_info = service_type_to_service_info service in + if service_info.dynamic_control_iptables_port then ( + try + match service with + | Dlm | Ssh | Vxlan | Http | Xenha -> + let op = + match status with Enabled -> "open" | Disabled -> "close" + in + Helpers.call_script + !Xapi_globs.firewall_port_config_script + [ + op + ; string_of_int service_info.port + ; protocol_to_string service_info.protocol + ] + |> ignore + | Nbd -> + (* For legacy iptables, NBD port needs to be precisely controlled on + each interface *) + let args = "set" :: interfaces in + Helpers.call_script !Xapi_globs.nbd_firewall_config_script args + |> ignore + with e -> + error + "%s: Failed to update firewall service (%s) to (%s) with error: %s" + __FUNCTION__ service_info.name (status_to_string status) + (Printexc.to_string e) ; + Helpers.internal_error "Failed to update firewall service (%s)" + service_info.name + ) +end + +let firewall_provider (backend : Xapi_globs.firewall_backend_type) : + (module FIREWALL) = + match backend with + | Firewalld -> + (module Firewalld) + | Iptables -> + (module Iptables) diff --git a/ocaml/xapi/firewall.mli b/ocaml/xapi/firewall.mli new file mode 100644 index 0000000000..a692719a13 --- /dev/null +++ b/ocaml/xapi/firewall.mli @@ -0,0 +1,38 @@ +(* + * 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. + *) + +type service_type = Dlm | Nbd | Ssh | Vxlan | Http | Xenha + +type status = Enabled | Disabled + +val all_service_types : service_type list + +module type FIREWALL = sig + val update_firewall_status : + ?interfaces:string list -> service_type -> status -> unit + (** [update_firewall_status] updates the firewalld service status based on the + status of the corresponding service. + + [interfaces] is a list of bridge names of the Network objects whose + purpose is `nbd` or `insecure_nbd`. [interfaces] is only used to controll + the NBD iptables port dynamically, to specify which interfaces are + permitted for NBD connections. + *) +end + +module Firewalld : FIREWALL + +module Iptables : FIREWALL + +val firewall_provider : Xapi_globs.firewall_backend_type -> (module FIREWALL) diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 2ef1611205..32fb3c97d8 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -129,8 +129,11 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = raise e (** Construct a descriptive network name (used as name_label) for a give network interface. *) -let choose_network_name_for_pif device = - Printf.sprintf "Pool-wide network associated with %s" device +let choose_network_name_for_pif device = function + | Some pos -> + Printf.sprintf "Pool-wide network %d" pos + | None -> + Printf.sprintf "Pool-wide network associated with %s" device (* !! FIXME - trap proper MISSINGREFERENCE exception when this has been defined *) (* !! FIXME(2) - this code could be shared with the CLI? *) @@ -139,7 +142,12 @@ let checknull f = try f () with _ -> "" let ignore_invalid_ref f (x : 'a Ref.t) = try Ref.to_option (f x) with Db_exn.DBCache_NotFound _ -> None -let get_pool ~__context = List.hd (Db.Pool.get_all ~__context) +let get_pool ~__context = + match Db.Pool.get_all ~__context with + | [] -> + raise (Failure "Helpers.get_pool: No pool available") + | pool :: _ -> + pool let get_master ~__context = Db.Pool.get_master ~__context ~self:(get_pool ~__context) @@ -157,7 +165,7 @@ let get_management_iface_is_connected ~__context = let get_management_ip_addr ~__context = let dbg = Context.string_of_task __context in - Option.map fst (Networking_info.get_management_ip_addr ~dbg) + Networking_info.get_management_ip_addr ~dbg let get_localhost_uuid () = Xapi_inventory.lookup Xapi_inventory._installation_uuid @@ -171,8 +179,13 @@ let get_localhost ~__context = match localhost_ref = Ref.null with | false -> localhost_ref - | true -> - get_localhost_uncached ~__context + | true -> ( + try get_localhost_uncached ~__context + with Db_exn.Read_missing_uuid (_, _, _) as e -> + Unixext.raise_with_preserved_backtrace e (fun () -> + warn "The database has not fully come up yet, so localhost is missing" + ) + ) (* Determine the gateway and DNS PIFs: * If one of the PIFs with IP has other_config:defaultroute=true, then @@ -499,7 +512,7 @@ let make_remote_rpc_of_url ~verify_cert ~srcstr ~dststr (url, pool_secret) call let http = xmlrpc ~version:"1.0" ?auth:(Http.Url.auth_of url) ~query:(Http.Url.get_query_params url) - (Http.Url.get_uri url) + (Http.Url.get_path url) in let http = match pool_secret with @@ -586,6 +599,7 @@ let call_api_functions ~__context f = call_api_functions_internal ~__context f let call_emergency_mode_functions hostname f = + let __FUN = __FUNCTION__ in let open Xmlrpc_client in let transport = SSL @@ -604,15 +618,13 @@ let call_emergency_mode_functions hostname f = in finally (fun () -> f rpc session_id) - (fun () -> Client.Client.Session.local_logout ~rpc ~session_id) - -let progress ~__context t = - for i = 0 to int_of_float (t *. 100.) do - let v = float_of_int i /. 100. /. t in - TaskHelper.set_progress ~__context v ; - Thread.delay 1. - done ; - TaskHelper.set_progress ~__context 1. + (fun () -> + try Client.Client.Session.local_logout ~rpc ~session_id + with _ -> + (* This is an emergency mode function, so we don't care about the error + in logout *) + debug "%s: The logout failed in emergency mode function" __FUN + ) let is_domain_zero_with_record ~__context vm_ref vm_rec = let host_ref = vm_rec.API.vM_resident_on in @@ -863,12 +875,18 @@ let assert_we_are_master ~__context = ) (* Host version compare helpers *) -let compare_int_lists : int list -> int list -> int = +let rec compare_int_lists : int list -> int list -> int = fun a b -> - let first_non_zero is = - List.fold_left (fun a b -> if a <> 0 then a else b) 0 is - in - first_non_zero (List.map2 compare a b) + match (a, b) with + | [], [] -> + 0 + | [], _ -> + -1 + | _, [] -> + 1 + | x :: xs, y :: ys -> + let r = compare x y in + if r <> 0 then r else compare_int_lists xs ys let group_by f list = let evaluated_list = List.map (fun x -> (x, f x)) list in @@ -909,63 +927,161 @@ let sort_by_schwarzian ?(descending = false) f list = |> List.sort (fun (_, x') (_, y') -> comp x' y') |> List.map (fun (x, _) -> x) -let platform_version_inverness = [2; 4; 0] +module Checks = struct + let get_software_versions ~version_keys ~__context host = + ( match host with + | LocalObject self -> + Db.Host.get_software_version ~__context ~self + | RemoteObject (rpc, session_id, self) -> + Client.Client.Host.get_software_version ~rpc ~session_id ~self + ) + |> List.filter (fun (k, _) -> List.mem k version_keys) + + let versions_string_of : (string * string) list -> string = + fun ver_list -> + ver_list + |> List.map (fun (k, v) -> Printf.sprintf "%s: %s" k v) + |> String.concat "," + + let version_numbers_of_string version_string = + ( match String.split_on_char '-' version_string with + | standard_version :: patch :: _ -> + List.concat_map (String.split_on_char '.') [standard_version; patch] + | standard_version :: [] -> + String.split_on_char '.' standard_version + | _ -> + ["0"; "0"; "0"] + ) + |> List.filter_map int_of_string_opt + + let version_of : version_key:string -> (string * string) list -> int list = + fun ~version_key versions_list -> + List.assoc_opt version_key versions_list + |> Option.value ~default:"0.0.0" + |> version_numbers_of_string + + (* Compares host versions, analogous to Stdlib.compare. *) + let compare_versions : + version_key:string + -> (string * string) list + -> (string * string) list + -> int = + fun ~version_key sw_ver_a sw_ver_b -> + let version_a = version_of ~version_key sw_ver_a in + let version_b = version_of ~version_key sw_ver_b in + compare_int_lists version_a version_b + + let compare_all_versions ~version_keys ~is_greater_or_equal:a ~than:b = + List.for_all + (fun version_key -> compare_versions ~version_key a b >= 0) + version_keys + + module RPU = struct + let version_keys = Xapi_globs.[_platform_version; _xapi_version] + + let get_software_versions ~__context host = + get_software_versions ~version_keys ~__context host + + let compare_all_versions ~is_greater_or_equal:a ~than:b = + compare_all_versions ~version_keys ~is_greater_or_equal:a ~than:b + + let max_version_in_pool : __context:Context.t -> (string * string) list = + fun ~__context -> + let max_version a b = + if a = [] then + b + else if compare_all_versions ~is_greater_or_equal:a ~than:b then + a + else + b + and versions = + List.map + (fun host_ref -> + get_software_versions ~__context (LocalObject host_ref) + ) + (Db.Host.get_all ~__context) + in + List.fold_left max_version [] versions + + let host_has_highest_version_in_pool : + __context:Context.t -> host:[`host] api_object -> bool = + fun ~__context ~host -> + let host_versions = get_software_versions ~__context host + and max_version = max_version_in_pool ~__context in + compare_all_versions ~is_greater_or_equal:host_versions ~than:max_version + + (* Assertion functions which raise an exception if certain invariants + are broken during an upgrade. *) + let assert_rolling_upgrade_not_in_progress : __context:Context.t -> unit = + fun ~__context -> + if rolling_upgrade_in_progress ~__context then + raise + (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])) + + let assert_host_has_highest_version_in_pool ~(__context : Context.t) + ~(host : API.ref_host) : unit = + if + not + (host_has_highest_version_in_pool ~__context ~host:(LocalObject host)) + then + raise + (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])) -let version_string_of : __context:Context.t -> [`host] api_object -> string = - fun ~__context host -> - try - let software_version = - match host with - | LocalObject host_ref -> - Db.Host.get_software_version ~__context ~self:host_ref - | RemoteObject (rpc, session_id, host_ref) -> - Client.Client.Host.get_software_version ~rpc ~session_id - ~self:host_ref - in - List.assoc Xapi_globs._platform_version software_version - with Not_found -> Xapi_globs.default_platform_version - -let version_of : __context:Context.t -> [`host] api_object -> int list = - fun ~__context host -> - let vs = version_string_of ~__context host in - List.map int_of_string (String.split_on_char '.' vs) - -(* Compares host versions, analogous to Stdlib.compare. *) -let compare_host_platform_versions : - __context:Context.t -> [`host] api_object -> [`host] api_object -> int = - fun ~__context host_a host_b -> - let version_of = version_of ~__context in - compare_int_lists (version_of host_a) (version_of host_b) - -let max_version_in_pool : __context:Context.t -> int list = - fun ~__context -> - let max_version a b = - if a = [] then b else if compare_int_lists a b > 0 then a else b - and versions = - List.map - (fun host_ref -> version_of ~__context (LocalObject host_ref)) - (Db.Host.get_all ~__context) - in - List.fold_left max_version [] versions + let are_host_versions_same_on_master_inner ~__context ~host ~master = + if is_pool_master ~__context ~host then + true + else + let sw_ver_master = + get_software_versions ~__context (LocalObject master) + in + let sw_ver_host = get_software_versions ~__context (LocalObject host) in + List.for_all + (fun version_key -> + compare_versions ~version_key sw_ver_master sw_ver_host = 0 + ) + version_keys + + let are_host_versions_same_on_master ~__context ~host = + let master = get_master ~__context in + are_host_versions_same_on_master_inner ~__context ~host ~master + + let pool_has_different_host_platform_versions ~__context = + let all_hosts = Db.Host.get_all ~__context in + let master = get_master ~__context in + not + (List.for_all + (fun host -> + are_host_versions_same_on_master_inner ~__context ~host ~master + ) + all_hosts + ) + + let assert_host_versions_are_same_on_master ~__context ~host ~self = + if not (are_host_versions_same_on_master ~__context ~host) then + raise + (Api_errors.Server_error + ( Api_errors.vm_host_incompatible_version + , [Ref.string_of host; Ref.string_of self] + ) + ) + end -let host_has_highest_version_in_pool : - __context:Context.t -> host:[`host] api_object -> bool = - fun ~__context ~host -> - let host_version = version_of ~__context host - and max_version = max_version_in_pool ~__context in - compare_int_lists host_version max_version >= 0 + module Migration = struct + let version_keys = + Xapi_globs.[_platform_version; _xapi_build_version; _xen_version] -let host_versions_not_decreasing ~__context ~host_from ~host_to = - compare_host_platform_versions ~__context host_from host_to <= 0 + let get_software_versions ~__context host = + get_software_versions ~version_keys ~__context host -let is_platform_version_same_on_master ~__context ~host = - if is_pool_master ~__context ~host then - true - else - let master = get_master ~__context in - compare_host_platform_versions ~__context (LocalObject master) - (LocalObject host) - = 0 + let compare_all_versions ~is_greater_or_equal:a ~than:b = + compare_all_versions ~version_keys ~is_greater_or_equal:a ~than:b + + let host_versions_not_decreasing ~__context ~host_from ~host_to = + let sw_vers_from = get_software_versions ~__context host_from in + let sw_vers_to = get_software_versions ~__context host_to in + compare_all_versions ~is_greater_or_equal:sw_vers_to ~than:sw_vers_from + end +end let maybe_raise_vtpm_unimplemented func message = if not !ignore_vtpm_unimplemented then ( @@ -973,43 +1089,6 @@ let maybe_raise_vtpm_unimplemented func message = raise Api_errors.(Server_error (not_implemented, [message])) ) -let assert_platform_version_is_same_on_master ~__context ~host ~self = - if not (is_platform_version_same_on_master ~__context ~host) then - raise - (Api_errors.Server_error - ( Api_errors.vm_host_incompatible_version - , [Ref.string_of host; Ref.string_of self] - ) - ) - -(** PR-1007 - block operations during rolling upgrade *) - -(* Assertion functions which raise an exception if certain invariants - are broken during an upgrade. *) -let assert_rolling_upgrade_not_in_progress : __context:Context.t -> unit = - fun ~__context -> - if rolling_upgrade_in_progress ~__context then - raise (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])) - -let assert_host_has_highest_version_in_pool : - __context:Context.t -> host:API.ref_host -> unit = - fun ~__context ~host -> - if not (host_has_highest_version_in_pool ~__context ~host:(LocalObject host)) - then - raise (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])) - -let pool_has_different_host_platform_versions ~__context = - let all_hosts = Db.Host.get_all ~__context in - let platform_versions = - List.map - (fun host -> version_string_of ~__context (LocalObject host)) - all_hosts - in - let is_different_to_me platform_version = - platform_version <> Xapi_version.platform_version () - in - List.fold_left ( || ) false (List.map is_different_to_me platform_versions) - (* Checks that a host has a PBD for a particular SR (meaning that the SR is visible to the host) *) let host_has_pbd_for_sr ~__context ~host ~sr = @@ -1349,13 +1428,19 @@ let vm_to_string __context vm = raise (Api_errors.Server_error (Api_errors.invalid_value, [str])) ; let t = Context.database_of __context in let module DB = - (val Xapi_database.Db_cache.get t : Xapi_database.Db_interface.DB_ACCESS) + (val Xapi_database.Db_cache.get t : Xapi_database.Db_interface.DB_ACCESS2) in - let fields = fst (DB.read_record t Db_names.vm str) in + let fields, _ = DB.read_record t Db_names.vm str in let sexpr = SExpr.Node (List.map - (fun (key, value) -> SExpr.Node [SExpr.String key; SExpr.String value]) + (fun (key, value) -> + SExpr.Node + [ + SExpr.String key + ; SExpr.String (Schema.CachedValue.string_of value) + ] + ) fields ) in @@ -1675,7 +1760,7 @@ module Repeat_with_uniform_backoff : POLICY = struct debug "Waiting for up to %f seconds before retrying..." this_timeout ; let start = Unix.gettimeofday () in ( match e with - | Api_errors.Server_error (code, [cls; objref]) + | Api_errors.Server_error (code, cls :: objref :: _) when code = Api_errors.other_operation_in_progress -> Early_wakeup.wait (cls, objref) this_timeout | _ -> diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index 91a900dedd..04306cff5f 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -2602,7 +2602,7 @@ let handler (req : Request.t) s _ = let address = Db.Host.get_address ~__context ~self:host in let url = Uri.( - make ~scheme:"https" ~host:address ~path:req.Request.uri + make ~scheme:"https" ~host:address ~path:req.Request.path ~query:(List.map (fun (a, b) -> (a, [b])) req.Request.query) () |> to_string diff --git a/ocaml/xapi/import_raw_vdi.ml b/ocaml/xapi/import_raw_vdi.ml index 565c29e7d8..8eacfe0a78 100644 --- a/ocaml/xapi/import_raw_vdi.ml +++ b/ocaml/xapi/import_raw_vdi.ml @@ -106,6 +106,10 @@ let localhost_handler rpc session_id vdi_opt (req : Request.t) ) ) | None -> + (* FIXME: Currently, when importing an image with a virtual + size that's bigger than the VDI's virtual size, we fail in + an unhelpful manner on some write. + We could instead parse the header first and fail early. *) let vdi = match ( vdi_opt @@ -122,6 +126,22 @@ let localhost_handler rpc session_id vdi_opt (req : Request.t) ~virtual_size:length ~_type:`user ~sharable:false ~read_only:false ~other_config:[] ~xenstore_data:[] ~sm_config:[] ~tags:[] + | None, Importexport.Format.Qcow, _, _ -> + error + "Importing a QCOW2 directly into an SR not yet \ + supported" ; + raise + (HandleError + ( Api_errors.Server_error + ( Api_errors.internal_error + , [ + "Importing a QCOW2 directly into an SR not \ + yet supported" + ] + ) + , Http.http_400_badrequest ~version:"1.0" () + ) + ) | None, Importexport.Format.Vhd, _, _ -> error "Importing a VHD directly into an SR not yet supported" ; @@ -158,6 +178,13 @@ let localhost_handler rpc session_id vdi_opt (req : Request.t) in Http_svr.headers s headers ; ( match format with + | Qcow -> + Sm_fs_ops.with_block_attached_device __context rpc + session_id vdi `RW (fun path -> + Qcow_tool_wrapper.receive + (Qcow_tool_wrapper.update_task_progress __context) + s path + ) | Raw | Vhd -> let prezeroed = not diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index a210bda04d..8f60995bbf 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -430,9 +430,17 @@ let sr_of_req ~__context (req : Http.Request.t) = None module Format = struct - type t = Raw | Vhd | Tar + type t = Raw | Vhd | Tar | Qcow - let to_string = function Raw -> "raw" | Vhd -> "vhd" | Tar -> "tar" + let to_string = function + | Raw -> + "raw" + | Vhd -> + "vhd" + | Tar -> + "tar" + | Qcow -> + "qcow2" let of_string x = match String.lowercase_ascii x with @@ -442,6 +450,8 @@ module Format = struct Some Vhd | "tar" -> Some Tar + | "qcow2" -> + Some Qcow | _ -> None @@ -457,6 +467,8 @@ module Format = struct "application/vhd" | Tar -> "application/x-tar" + | Qcow -> + "application/x-qemu-disk" let _key = "format" @@ -505,7 +517,7 @@ end let return_302_redirect (req : Http.Request.t) s address = let url = Uri.( - make ~scheme:"https" ~host:address ~path:req.Http.Request.uri + make ~scheme:"https" ~host:address ~path:req.Http.Request.path ~query:(List.map (fun (a, b) -> (a, [b])) req.Http.Request.query) () |> to_string diff --git a/ocaml/xapi/localdb.ml b/ocaml/xapi/localdb.ml index 3382c42e32..7658e58523 100644 --- a/ocaml/xapi/localdb.ml +++ b/ocaml/xapi/localdb.ml @@ -64,17 +64,27 @@ exception Missing_key of string let m = Mutex.create () let get (key : string) = + let __FUN = __FUNCTION__ in + let ( let* ) = Option.bind in with_lock m (fun () -> - assert_loaded () ; - match Hashtbl.find_opt db key with - | Some x -> - x - | None -> - raise (Missing_key key) + let* () = + try assert_loaded () ; Some () + with e -> + warn "%s: unexpected error, ignoring it: %s" __FUN + (Printexc.to_string e) ; + None + in + Hashtbl.find_opt db key ) -let get_with_default (key : string) (default : string) = - try get key with Missing_key _ -> default +let get_exn key = + match get key with Some x -> x | None -> raise (Missing_key key) + +let get_of_string of_string key = Option.bind (get key) of_string + +let get_bool key = get_of_string bool_of_string_opt key + +let get_int key = get_of_string int_of_string_opt key (* Returns true if a change was made and should be flushed *) let put_one (key : string) (v : string) = diff --git a/ocaml/xapi/localdb.mli b/ocaml/xapi/localdb.mli index 3608241fc1..ae087aaa2e 100644 --- a/ocaml/xapi/localdb.mli +++ b/ocaml/xapi/localdb.mli @@ -18,12 +18,24 @@ (** Thrown when a particular named key could not be found. *) exception Missing_key of string -val get : string -> string +val get : string -> string option (** Retrieves a value *) -val get_with_default : string -> string -> string -(** [get_with_default key default] returns the value associated with [key], - or [default] if the key is missing. *) +val get_exn : string -> string +(** Retrieves the value for the key, raises Missing_key when the key is not + present *) + +val get_bool : string -> bool option +(** Retrieves the value for the key, returns a value when it's found and is a + valid boolean, otherwise is [None] *) + +val get_int : string -> int option +(** Retrieves the value for the key, returns a value when it's found and is a + valid int, otherwise is [None] *) + +val get_of_string : (string -> 'a option) -> string -> 'a option +(** [get_of_string of_string key] retrieves the value for [key], and if it + exists, processes it with [of_string], otherwise it's [None] *) val put : string -> string -> unit (** Inserts a value into the database, only returns when the insertion has diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index dc77569e64..060195e120 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -143,24 +143,15 @@ let do_op_on_common ~local_fn ~__context ~host ~remote_fn f = let task_opt = set_forwarding_on_task ~__context ~host in f __context host task_opt remote_fn with - | Xmlrpc_client.Connection_reset | Http_client.Http_request_rejected _ -> - warn - "Caught Connection_reset when contacting host %s; converting into \ - CANNOT_CONTACT_HOST" - (Ref.string_of host) ; - raise - (Api_errors.Server_error - (Api_errors.cannot_contact_host, [Ref.string_of host]) - ) - | Xmlrpc_client.Stunnel_connection_failed -> - warn - "Caught Stunnel_connection_failed while contacting host %s; converting \ - into CANNOT_CONTACT_HOST" - (Ref.string_of host) ; - raise - (Api_errors.Server_error - (Api_errors.cannot_contact_host, [Ref.string_of host]) - ) + | ( Xmlrpc_client.Connection_reset + | Http_client.Http_request_rejected _ + | Xmlrpc_client.Stunnel_connection_failed ) as e + -> + error + "%s: Caught %s when contacting host %s; converting into \ + CANNOT_CONTACT_HOST" + __FUNCTION__ (Printexc.to_string e) (Ref.string_of host) ; + raise Api_errors.(Server_error (cannot_contact_host, [Ref.string_of host])) (* regular forwarding fn, with session and live-check. Used by most calls, will use the connection cache. *) @@ -372,8 +363,15 @@ functor with _ -> "invalid" let current_pool_uuid ~__context = + let get_pool_record () = + match Db.Pool.get_all_records ~__context with + | [] -> + raise (Failure "current_pool_uuid: no pool available") + | (_, pool) :: _ -> + pool + in if Pool_role.is_master () then - let _, pool = List.hd (Db.Pool.get_all_records ~__context) in + let pool = get_pool_record () in Printf.sprintf "%s%s" pool.API.pool_uuid (add_brackets pool.API.pool_name_label) else @@ -1185,6 +1183,24 @@ functor let disable_ssh ~__context ~self = info "%s: pool = '%s'" __FUNCTION__ (pool_uuid ~__context self) ; Local.Pool.disable_ssh ~__context ~self + + let set_ssh_enabled_timeout ~__context ~self ~value = + info "Pool.set_ssh_enabled_timeout: pool='%s' value='%Ld'" + (pool_uuid ~__context self) + value ; + Local.Pool.set_ssh_enabled_timeout ~__context ~self ~value + + let set_console_idle_timeout ~__context ~self ~value = + info "Pool.set_console_idle_timeout: pool='%s' value='%Ld'" + (pool_uuid ~__context self) + value ; + Local.Pool.set_console_idle_timeout ~__context ~self ~value + + let set_ssh_auto_mode ~__context ~self ~value = + info "Pool.set_ssh_auto_mode: pool='%s' value='%b'" + (pool_uuid ~__context self) + value ; + Local.Pool.set_ssh_auto_mode ~__context ~self ~value end module VM = struct @@ -1912,7 +1928,8 @@ functor let start_on ~__context ~vm ~host ~start_paused ~force = if Helpers.rolling_upgrade_in_progress ~__context then - Helpers.assert_host_has_highest_version_in_pool ~__context ~host ; + Helpers.Checks.RPU.assert_host_has_highest_version_in_pool ~__context + ~host ; Pool_features.assert_enabled ~__context ~f:Features.VM_start ; Xapi_vm_helpers.assert_matches_control_domain_affinity ~__context ~self:vm ~host ; @@ -2018,6 +2035,34 @@ functor forward_vm_op ~local_fn ~__context ~vm ~remote_fn ) + let call_host_plugin ~__context ~vm ~plugin ~fn ~args = + info + "VM.call_host_plugin: VM = '%s'; plugin = '%s'; fn = '%s'; args = [ \ + 'hidden' ]" + (vm_uuid ~__context vm) plugin fn ; + let local_fn = Local.VM.call_host_plugin ~vm ~plugin ~fn ~args in + let remote_fn = Client.VM.call_host_plugin ~vm ~plugin ~fn ~args in + let power_state = Db.VM.get_power_state ~__context ~self:vm in + (* Insisting on running to make sure xenstore and domain exist + and the VM can react to xenstore events. Permitting Paused in + addition could be an option *) + if power_state <> `Running then + raise + Api_errors.( + Server_error + ( vm_bad_power_state + , [ + Ref.string_of vm + ; Record_util.vm_power_state_to_string `Running + ; Record_util.vm_power_state_to_string power_state + ] + ) + ) ; + with_vm_operation ~__context ~self:vm ~doc:"VM.call_host_plugin" + ~op:`call_plugin ~policy:Helpers.Policy.fail_immediately (fun () -> + forward_vm_op ~local_fn ~__context ~vm ~remote_fn + ) + let set_has_vendor_device ~__context ~self ~value = info "VM.set_has_vendor_device: VM = '%s' to %b" (vm_uuid ~__context self) value ; @@ -2390,7 +2435,8 @@ functor let resume_on ~__context ~vm ~host ~start_paused ~force = if Helpers.rolling_upgrade_in_progress ~__context then - Helpers.assert_host_has_highest_version_in_pool ~__context ~host ; + Helpers.Checks.RPU.assert_host_has_highest_version_in_pool ~__context + ~host ; info "VM.resume_on: VM = '%s'; host = '%s'" (vm_uuid ~__context vm) (host_uuid ~__context host) ; let local_fn = Local.VM.resume_on ~vm ~host ~start_paused ~force in @@ -2448,7 +2494,7 @@ functor with_vm_operation ~__context ~self:vm ~doc:"VM.pool_migrate" ~op:`pool_migrate ~strict:(not force) (fun () -> let to_equal_or_greater_version = - Helpers.host_versions_not_decreasing ~__context + Helpers.Checks.Migration.host_versions_not_decreasing ~__context ~host_from:(Helpers.LocalObject source_host) ~host_to:(Helpers.LocalObject host) in @@ -2464,6 +2510,8 @@ functor let snapshot = Db.VM.get_record ~__context ~self:vm in reserve_memory_for_vm ~__context ~vm ~host ~snapshot ~host_op:`vm_migrate (fun () -> + if Db.VM.get_VGPUs ~__context ~self:vm <> [] then + Xapi_stats.incr_pool_vgpu_migration_count () ; forward_vm_op ~local_fn ~__context ~vm ~remote_fn ) ) ; @@ -2540,7 +2588,7 @@ functor forward_vm_op ~local_fn ~__context ~vm ~remote_fn:(fun ~rpc ~session_id -> (* try InternalAsync.VM.migrate_send first to avoid long running idle stunnel connection - * fall back on Async.VM.migrate_send if slave doesn't support InternalAsync *) + * fall back on Async.VM.migrate_send if slave doesn't support InternalAsync *) Helpers.try_internal_async ~__context API.ref_VM_of_rpc (fun () -> Client.InternalAsync.VM.migrate_send ~rpc ~session_id ~vm @@ -2585,6 +2633,8 @@ functor assert_can_migrate ~__context ~vm ~dest ~live ~vdi_map ~vif_map ~vgpu_map ~options ) ; + if Db.VM.get_VGPUs ~__context ~self:vm <> [] then + Xapi_stats.incr_pool_vgpu_migration_count () ; forward_migrate_send () ) in @@ -3074,16 +3124,28 @@ functor Xapi_vm_lifecycle.update_allowed_operations ~__context ~self let add_to_blocked_operations ~__context ~self ~key ~value = - info "VM.add_to_blocked_operations: self = '%s'" - (vm_uuid ~__context self) ; + info "VM.add_to_blocked_operations: self = '%s', key = '%s'" + (vm_uuid ~__context self) + (API.vm_operations_to_string key) ; Local.VM.add_to_blocked_operations ~__context ~self ~key ~value ; Xapi_vm_lifecycle.update_allowed_operations ~__context ~self let remove_from_blocked_operations ~__context ~self ~key = - info "VM.remove_from_blocked_operations: self = '%s'" - (vm_uuid ~__context self) ; + info "VM.remove_from_blocked_operations: self = '%s', key = '%s'" + (vm_uuid ~__context self) + (API.vm_operations_to_string key) ; Local.VM.remove_from_blocked_operations ~__context ~self ~key ; Xapi_vm_lifecycle.update_allowed_operations ~__context ~self + + let sysprep ~__context ~self ~unattend ~timeout = + info "VM.sysprep: self = '%s'" (vm_uuid ~__context self) ; + let local_fn = Local.VM.sysprep ~self ~unattend ~timeout in + let remote_fn = Client.VM.sysprep ~self ~unattend ~timeout in + let policy = Helpers.Policy.fail_immediately in + with_vm_operation ~__context ~self ~doc:"VM.sysprep" ~op:`sysprep + ~policy (fun () -> + forward_vm_op ~local_fn ~__context ~vm:self ~remote_fn + ) end module VM_metrics = struct end @@ -3296,13 +3358,15 @@ functor (host_uuid ~__context host) ; Local.Host.get_management_interface ~__context ~host - let disable ~__context ~host = - info "Host.disable: host = '%s'" (host_uuid ~__context host) ; + let disable ~__context ~host ~auto_enable = + info "Host.disable: host = '%s', auto_enable = '%b'" + (host_uuid ~__context host) + auto_enable ; (* Block call if this would break our VM restart plan *) Xapi_ha_vm_failover.assert_host_disable_preserves_ha_plan ~__context host ; - let local_fn = Local.Host.disable ~host in - let remote_fn = Client.Host.disable ~host in + let local_fn = Local.Host.disable ~host ~auto_enable in + let remote_fn = Client.Host.disable ~host ~auto_enable in do_op_on ~local_fn ~__context ~host ~remote_fn ; Xapi_host_helpers.update_allowed_operations ~__context ~self:host @@ -4035,6 +4099,41 @@ functor let local_fn = Local.Host.disable_ssh ~self in let remote_fn = Client.Host.disable_ssh ~self in do_op_on ~local_fn ~__context ~host:self ~remote_fn + + let set_ssh_enabled_timeout ~__context ~self ~value = + info "Host.set_ssh_enabled_timeout: host='%s' value='%Ld'" + (host_uuid ~__context self) + value ; + let local_fn = Local.Host.set_ssh_enabled_timeout ~self ~value in + let remote_fn = Client.Host.set_ssh_enabled_timeout ~self ~value in + do_op_on ~local_fn ~__context ~host:self ~remote_fn + + let set_console_idle_timeout ~__context ~self ~value = + info "Host.set_console_idle_timeout: host='%s' value='%Ld'" + (host_uuid ~__context self) + value ; + let local_fn = Local.Host.set_console_idle_timeout ~self ~value in + let remote_fn = Client.Host.set_console_idle_timeout ~self ~value in + do_op_on ~local_fn ~__context ~host:self ~remote_fn + + let set_ssh_auto_mode ~__context ~self ~value = + info "Host.set_ssh_auto_mode: host='%s' value='%b'" + (host_uuid ~__context self) + value ; + let local_fn = Local.Host.set_ssh_auto_mode ~self ~value in + let remote_fn = Client.Host.set_ssh_auto_mode ~self ~value in + do_op_on ~local_fn ~__context ~host:self ~remote_fn + + let get_tracked_user_agents ~__context ~self = + info "Host.get_tracked_user_agents: host = '%s'" + (host_uuid ~__context self) ; + let local_fn = Local.Host.get_tracked_user_agents ~self in + let remote_fn = Client.Host.get_tracked_user_agents ~self in + do_op_on ~local_fn ~__context ~host:self ~remote_fn + + let update_firewalld_service_status ~__context = + info "Host.update_firewalld_service_status" ; + Local.Host.update_firewalld_service_status ~__context end module Host_crashdump = struct @@ -5663,14 +5762,21 @@ functor if Helpers.i_am_srmaster ~__context ~sr then List.iter (fun vdi -> - if Db.VDI.get_current_operations ~__context ~self:vdi <> [] - then - raise - (Api_errors.Server_error - ( Api_errors.other_operation_in_progress - , [Datamodel_common._vdi; Ref.string_of vdi] - ) - ) + match Db.VDI.get_current_operations ~__context ~self:vdi with + | (op_ref, op_type) :: _ -> + raise + (Api_errors.Server_error + ( Api_errors.other_operation_in_progress + , [ + Datamodel_common._vdi + ; Ref.string_of vdi + ; API.vdi_operations_to_string op_type + ; op_ref + ] + ) + ) + | [] -> + () ) (Db.SR.get_VDIs ~__context ~self:sr) ; SR.mark_sr ~__context ~sr ~doc ~op @@ -6324,7 +6430,7 @@ functor let remote_fn = Client.Cluster_host.forget ~self in (* We need to ask another host that has a cluster host to mark it as dead. * We might've run force destroy and this host would no longer have a cluster host - * *) + *) let other_hosts = Db.Cluster.get_cluster_hosts ~__context ~self:cluster |> List.filter (( <> ) self) diff --git a/ocaml/xapi/monitor_dbcalls.ml b/ocaml/xapi/monitor_dbcalls.ml index ab521155d2..48b96bbd92 100644 --- a/ocaml/xapi/monitor_dbcalls.ml +++ b/ocaml/xapi/monitor_dbcalls.ml @@ -127,8 +127,7 @@ let monitor_dbcall_thread () = try let rrd_files = Monitor_types.find_rrd_files () in pifs_update_fn () ; - Monitor_mem_host.update rrd_files ; - Monitor_mem_vms.update rrd_files ; + Monitor_mem.update rrd_files ; Monitor_pvs_proxy.update rrd_files ; Thread.delay 5. with e -> diff --git a/ocaml/xapi/monitor_mem.ml b/ocaml/xapi/monitor_mem.ml new file mode 100644 index 0000000000..79cf3cadf9 --- /dev/null +++ b/ocaml/xapi/monitor_mem.ml @@ -0,0 +1,178 @@ +(* + * 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 Mtxext = Xapi_stdext_threads.Threadext.Mutex +module Mcache = Monitor_dbcalls_cache + +module D = Debug.Make (struct let name = __MODULE__ end) + +open D + +let get_datasources rrd_files = + List.filter_map + (fun filename -> + if String.starts_with ~prefix:Xapi_globs.metrics_prefix_mem filename then + Some (filename, Monitor_types.datasources_from_filename filename) + else + None + ) + rrd_files + +module Host = struct + let get_changes datasources = + let named_dss = + List.concat_map + (fun (filename, datasources) -> + try + Mcache.log_errors_from filename ; + datasources + |> List.filter_map (function + | Rrd.Host, ds + when List.mem ds.Ds.ds_name + ["memory_total_kib"; "memory_free_kib"] -> + Some ds + | _ -> + None (* we are only interested in Host memory stats *) + ) + |> List.map (function ds -> + let value = + match ds.Ds.ds_value with + | Rrd.VT_Int64 v -> + Memory.bytes_of_kib v + | Rrd.VT_Float v -> + Memory.bytes_of_kib (Int64.of_float v) + | Rrd.VT_Unknown -> + -1L + in + (ds.Ds.ds_name, value) + ) + with e -> + if not (Mcache.is_ignored filename) then ( + error "Unable to read host memory metrics from %s: %s" filename + (Printexc.to_string e) ; + Mcache.ignore_errors_from filename + ) ; + [] + ) + datasources + in + let free_bytes = List.assoc_opt "memory_free_kib" named_dss in + let total_bytes = List.assoc_opt "memory_total_kib" named_dss in + (* Check if anything has changed since our last reading. *) + match (free_bytes, total_bytes) with + | Some free, Some total + when !Mcache.host_memory_free_cached <> free + || !Mcache.host_memory_total_cached <> total -> + Some (free, total) + | _ -> + None + + let set_changes (free_bytes, total_bytes) = + Mtxext.execute Mcache.host_memory_m (fun _ -> + Mcache.host_memory_free_cached := free_bytes ; + Mcache.host_memory_total_cached := total_bytes + ) + + let update __context datasources = + match get_changes datasources with + | None -> + () + | Some ((free, total) as c) -> ( + try + let host = Helpers.get_localhost ~__context in + let metrics = Db.Host.get_metrics ~__context ~self:host in + Db.Host_metrics.set_memory_total ~__context ~self:metrics ~value:total ; + Db.Host_metrics.set_memory_free ~__context ~self:metrics ~value:free ; + set_changes c + with e -> + error "Unable to update host memory metrics: %s" (Printexc.to_string e) + ) +end + +module VMs = struct + let get_changes datasources = + List.iter + (fun (filename, datasources) -> + try + Mcache.log_errors_from filename ; + datasources + |> List.filter_map (function + | Rrd.VM vm_uuid, ds when ds.Ds.ds_name = "memory" -> + Some (vm_uuid, ds) + | _ -> + None (* we are only interested in VM stats *) + ) + |> List.iter (function vm_uuid, ds -> + let value = + match ds.Ds.ds_value with + | Rrd.VT_Int64 v -> + v + | Rrd.VT_Float v -> + Int64.of_float v + | Rrd.VT_Unknown -> + -1L + in + Hashtbl.add Mcache.vm_memory_tmp vm_uuid value + ) + with e -> + if not (Mcache.is_ignored filename) then ( + error "Unable to read memory usage for VM %s: %s" filename + (Printexc.to_string e) ; + Mcache.ignore_errors_from filename + ) + ) + datasources ; + (* Check if anything has changed since our last reading. *) + Mcache.get_updates_map ~before:Mcache.vm_memory_cached + ~after:Mcache.vm_memory_tmp + + let set_changes ?except () = + Mtxext.execute Mcache.vm_memory_cached_m (fun _ -> + Mcache.transfer_map ?except ~source:Mcache.vm_memory_tmp + ~target:Mcache.vm_memory_cached () + ) + + let update __context datasources = + let host = Helpers.get_localhost ~__context in + let keeps = ref [] in + List.iter + (fun (vm_uuid, memory) -> + try + let vm = Db.VM.get_by_uuid ~__context ~uuid:vm_uuid in + let vmm = Db.VM.get_metrics ~__context ~self:vm in + if Db.VM.get_resident_on ~__context ~self:vm = host then + Db.VM_metrics.set_memory_actual ~__context ~self:vmm ~value:memory + else + Mcache.clear_cache_for_vm ~vm_uuid + with e -> + keeps := vm_uuid :: !keeps ; + error "Unable to update memory usage for VM %s: %s" vm_uuid + (Printexc.to_string e) + ) + (get_changes datasources) ; + set_changes ~except:!keeps () +end + +let update rrd_files = + let ( let@ ) f x = f x in + let@ __context = + Server_helpers.exec_with_new_task "Updating memory metrics" + in + let datasources = get_datasources rrd_files in + if datasources = [] then + error "%s: no memory datasources found!" __FUNCTION__ + else ( + Host.update __context datasources ; + VMs.update __context datasources + ) diff --git a/ocaml/xapi/monitor_mem.mli b/ocaml/xapi/monitor_mem.mli new file mode 100644 index 0000000000..c2b74b2512 --- /dev/null +++ b/ocaml/xapi/monitor_mem.mli @@ -0,0 +1,18 @@ +(* 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 Mcache = Monitor_dbcalls_cache + +val update : Mcache.StringSet.elt list -> unit +(** [update rrd_files] Reads rrd_files and update the host and VM memory + metrics in xapi's cache. *) diff --git a/ocaml/xapi/monitor_mem_host.ml b/ocaml/xapi/monitor_mem_host.ml deleted file mode 100644 index e4c2f012a2..0000000000 --- a/ocaml/xapi/monitor_mem_host.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* - * 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 Mtxext = Xapi_stdext_threads.Threadext.Mutex -module Mcache = Monitor_dbcalls_cache - -module D = Debug.Make (struct let name = "monitor_mem_host" end) - -open D - -let get_changes rrd_files = - let named_dss = - List.concat_map - (fun filename -> - try - let datasources = Monitor_types.datasources_from_filename filename in - Mcache.log_errors_from filename ; - datasources - |> List.filter_map (function - | Rrd.Host, ds - when List.mem ds.Ds.ds_name - ["memory_total_kib"; "memory_free_kib"] -> - Some ds - | _ -> - None (* we are only interested in Host memory stats *) - ) - |> List.map (function ds -> - let value = - match ds.Ds.ds_value with - | Rrd.VT_Int64 v -> - Memory.bytes_of_kib v - | Rrd.VT_Float v -> - Memory.bytes_of_kib (Int64.of_float v) - | Rrd.VT_Unknown -> - -1L - in - (ds.Ds.ds_name, value) - ) - with e -> - if not (Mcache.is_ignored filename) then ( - error "Unable to read host memory metrics from %s: %s" filename - (Printexc.to_string e) ; - Mcache.ignore_errors_from filename - ) ; - [] - ) - rrd_files - in - let free_bytes = List.assoc_opt "memory_free_kib" named_dss in - let total_bytes = List.assoc_opt "memory_total_kib" named_dss in - (* Check if anything has changed since our last reading. *) - match (free_bytes, total_bytes) with - | Some free, Some total - when !Mcache.host_memory_free_cached <> free - || !Mcache.host_memory_total_cached <> total -> - Some (free, total) - | _ -> - None - -let set_changes (free_bytes, total_bytes) = - Mtxext.execute Mcache.host_memory_m (fun _ -> - Mcache.host_memory_free_cached := free_bytes ; - Mcache.host_memory_total_cached := total_bytes - ) - -let update rrd_files = - let is_host_rrd = - Astring.String.is_prefix ~affix:Xapi_globs.metrics_prefix_mem_host - in - let rrd_files = List.filter is_host_rrd rrd_files in - Server_helpers.exec_with_new_task "Updating host memory metrics" - (fun __context -> - let changes = get_changes rrd_files in - match changes with - | None -> - () - | Some ((free, total) as c) -> ( - try - let host = Helpers.get_localhost ~__context in - let metrics = Db.Host.get_metrics ~__context ~self:host in - Db.Host_metrics.set_memory_total ~__context ~self:metrics ~value:total ; - Db.Host_metrics.set_memory_free ~__context ~self:metrics ~value:free ; - set_changes c - with e -> - error "Unable to update host memory metrics: %s" (Printexc.to_string e) - ) - ) diff --git a/ocaml/xapi/monitor_mem_vms.ml b/ocaml/xapi/monitor_mem_vms.ml deleted file mode 100644 index 37d737d92d..0000000000 --- a/ocaml/xapi/monitor_mem_vms.ml +++ /dev/null @@ -1,89 +0,0 @@ -(* - * 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 Mtxext = Xapi_stdext_threads.Threadext.Mutex -module Mcache = Monitor_dbcalls_cache - -module D = Debug.Make (struct let name = "monitor_mem_vms" end) - -open D - -let get_changes rrd_files = - List.iter - (fun filename -> - try - let datasources = Monitor_types.datasources_from_filename filename in - Mcache.log_errors_from filename ; - datasources - |> List.filter_map (function - | Rrd.VM vm_uuid, ds when ds.Ds.ds_name = "memory" -> - Some (vm_uuid, ds) - | _ -> - None (* we are only interested in VM stats *) - ) - |> List.iter (function vm_uuid, ds -> - let value = - match ds.Ds.ds_value with - | Rrd.VT_Int64 v -> - v - | Rrd.VT_Float v -> - Int64.of_float v - | Rrd.VT_Unknown -> - -1L - in - Hashtbl.add Mcache.vm_memory_tmp vm_uuid value - ) - with e -> - if not (Mcache.is_ignored filename) then ( - error "Unable to read memory usage for VM %s: %s" filename - (Printexc.to_string e) ; - Mcache.ignore_errors_from filename - ) - ) - rrd_files ; - (* Check if anything has changed since our last reading. *) - Mcache.get_updates_map ~before:Mcache.vm_memory_cached - ~after:Mcache.vm_memory_tmp - -let set_changes ?except () = - Mtxext.execute Mcache.vm_memory_cached_m (fun _ -> - Mcache.transfer_map ?except ~source:Mcache.vm_memory_tmp - ~target:Mcache.vm_memory_cached () - ) - -let update rrd_files = - let is_vm_rrd = - Astring.String.is_prefix ~affix:Xapi_globs.metrics_prefix_mem_vms - in - let rrd_files = List.filter is_vm_rrd rrd_files in - Server_helpers.exec_with_new_task "Updating VM memory usage" (fun __context -> - let host = Helpers.get_localhost ~__context in - let keeps = ref [] in - List.iter - (fun (vm_uuid, memory) -> - try - let vm = Db.VM.get_by_uuid ~__context ~uuid:vm_uuid in - let vmm = Db.VM.get_metrics ~__context ~self:vm in - if Db.VM.get_resident_on ~__context ~self:vm = host then - Db.VM_metrics.set_memory_actual ~__context ~self:vmm ~value:memory - else - Mcache.clear_cache_for_vm ~vm_uuid - with e -> - keeps := vm_uuid :: !keeps ; - error "Unable to update memory usage for VM %s: %s" vm_uuid - (Printexc.to_string e) - ) - (get_changes rrd_files) ; - set_changes ~except:!keeps () - ) diff --git a/ocaml/xapi/network_event_loop.ml b/ocaml/xapi/network_event_loop.ml index 4967e7f369..3b2dd53909 100644 --- a/ocaml/xapi/network_event_loop.ml +++ b/ocaml/xapi/network_event_loop.ml @@ -44,26 +44,9 @@ let _watch_networks_for_nbd_changes __context ~update_firewall let token, allowed_interfaces = try let token = wait_for_network_change ~token in - let pifs = Db.Host.get_PIFs ~__context ~self:localhost in - let allowed_connected_networks = - (* We use Valid_ref_list to continue processing the list in case some network refs are null or invalid *) - Valid_ref_list.filter_map - (fun pif -> - let network = Db.PIF.get_network ~__context ~self:pif in - let purpose = Db.Network.get_purpose ~__context ~self:network in - if List.mem `nbd purpose || List.mem `insecure_nbd purpose then - Some network - else - None - ) - pifs - in let interfaces = - List.map - (fun network -> Db.Network.get_bridge ~__context ~self:network) - allowed_connected_networks + Xapi_host.get_nbd_interfaces ~__context ~self:localhost in - let interfaces = Xapi_stdext_std.Listext.List.setify interfaces in let needs_firewall_update = match allowed_interfaces with | Some allowed_interfaces -> @@ -110,11 +93,20 @@ let _watch_networks_for_nbd_changes __context ~update_firewall loop ~token:"" ~allowed_interfaces let update_firewall interfaces_allowed_for_nbd = - let args = "set" :: interfaces_allowed_for_nbd in - Forkhelpers.execute_command_get_output - !Xapi_globs.nbd_firewall_config_script - args - |> ignore + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + let status = + match interfaces_allowed_for_nbd with + | [] -> + Firewall.Disabled + | _ -> + Firewall.Enabled + in + Fw.update_firewall_status ~interfaces:interfaces_allowed_for_nbd Firewall.Nbd + status let watch_networks_for_nbd_changes () = Server_helpers.exec_with_new_task "watching networks for NBD-related changes" diff --git a/ocaml/xapi/nm.ml b/ocaml/xapi/nm.ml index 229b53adbe..fa86a6f08e 100644 --- a/ocaml/xapi/nm.ml +++ b/ocaml/xapi/nm.ml @@ -634,28 +634,27 @@ let bring_pif_up ~__context ?(management_interface = false) (pif : API.ref_PIF) rc.API.pIF_ip_configuration_mode = `Static | `IPv6 -> rc.API.pIF_ipv6_configuration_mode = `Static + || rc.API.pIF_ipv6_configuration_mode = `Autoconf in let dns = match (static, rc.API.pIF_DNS) with - | false, _ | true, "" -> - ([], []) + | false, _ -> + None + | true, "" -> + Some ([], []) | true, pif_dns -> let nameservers = List.map Unix.inet_addr_of_string - (String.split ',' pif_dns) + (String.split_on_char ',' pif_dns) in let domains = match List.assoc_opt "domain" rc.API.pIF_other_config with - | None -> + | None | Some "" -> [] - | Some domains -> ( - try String.split ',' domains - with _ -> - warn "Invalid DNS search domains: %s" domains ; - [] - ) + | Some domains -> + String.split_on_char ',' domains in - (nameservers, domains) + Some (nameservers, domains) in let mtu = determine_mtu rc net_rc in let ethtool_settings, ethtool_offload = @@ -788,10 +787,12 @@ let bring_pif_up ~__context ?(management_interface = false) (pif : API.ref_PIF) | `vxlan -> debug "Opening VxLAN UDP port for tunnel with protocol 'vxlan'" ; - ignore - @@ Helpers.call_script - !Xapi_globs.firewall_port_config_script - ["open"; "4789"; "udp"] + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Vxlan Firewall.Enabled | `gre -> () ) @@ -849,10 +850,12 @@ let bring_pif_down ~__context ?(force = false) (pif : API.ref_PIF) = in if no_more_vxlan then ( debug "Last VxLAN tunnel was closed, closing VxLAN UDP port" ; - ignore - @@ Helpers.call_script - !Xapi_globs.firewall_port_config_script - ["close"; "4789"; "udp"] + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Vxlan Firewall.Disabled ) | `gre -> () diff --git a/ocaml/xapi/pool_db_backup.ml b/ocaml/xapi/pool_db_backup.ml index 2a0ab1eae2..f82e3340c1 100644 --- a/ocaml/xapi/pool_db_backup.ml +++ b/ocaml/xapi/pool_db_backup.ml @@ -192,7 +192,7 @@ let restore_from_xml __context dry_run (xml_filename : string) = (Db_xml.From.file (Datamodel_schema.of_datamodel ()) xml_filename) in version_check db ; - let db_ref = Db_ref.in_memory (ref (ref db)) in + let db_ref = Db_ref.in_memory (Atomic.make db) in let new_context = Context.make ~database:db_ref "restore_db" in prepare_database_for_restore ~old_context:__context ~new_context ; (* write manifest and unmarshalled db directly to db_temporary_restore_path, so its ready for us on restart *) diff --git a/ocaml/xapi/pool_features_helpers.ml b/ocaml/xapi/pool_features_helpers.ml index dda8619013..36e7e7a025 100644 --- a/ocaml/xapi/pool_features_helpers.ml +++ b/ocaml/xapi/pool_features_helpers.ml @@ -58,17 +58,16 @@ let rec compute_additional_restrictions all_host_params = function [] | flag :: rest -> let switches = - List.map + List.exists (function | params -> - if List.mem_assoc flag params then - bool_of_string (List.assoc flag params) - else - true + List.assoc_opt flag params + |> Fun.flip Option.bind bool_of_string_opt + |> Option.value ~default:true ) all_host_params in - (flag, string_of_bool (List.fold_left ( || ) false switches)) + (flag, string_of_bool switches) :: compute_additional_restrictions all_host_params rest (* Combine the host-level feature restrictions into pool-level ones, and write diff --git a/ocaml/xapi/qcow_tool_wrapper.ml b/ocaml/xapi/qcow_tool_wrapper.ml new file mode 100644 index 0000000000..30d0eb6381 --- /dev/null +++ b/ocaml/xapi/qcow_tool_wrapper.ml @@ -0,0 +1,59 @@ +(* + * Copyright (C) 2025 Vates. + * + * 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) + +open D + +let run_qcow_tool qcow_tool ?input_fd ?output_fd (_progress_cb : int -> unit) + (args : string list) = + info "Executing %s %s" qcow_tool (String.concat " " args) ; + let open Forkhelpers in + match + with_logfile_fd "qcow-tool" (fun log_fd -> + let pid = + safe_close_and_exec input_fd output_fd (Some log_fd) [] qcow_tool args + in + let _, status = waitpid pid in + if status <> Unix.WEXITED 0 then ( + error "qcow-tool failed, returning VDI_IO_ERROR" ; + raise + (Api_errors.Server_error + (Api_errors.vdi_io_error, ["Device I/O errors"]) + ) + ) + ) + with + | Success (out, _) -> + debug "qcow-tool successful export (%s)" out + | Failure (out, _e) -> + error "qcow-tool output: %s" out ; + raise (Api_errors.Server_error (Api_errors.vdi_io_error, [out])) + +let update_task_progress (__context : Context.t) (x : int) = + TaskHelper.set_progress ~__context (float_of_int x /. 100.) + +let receive (progress_cb : int -> unit) (unix_fd : Unix.file_descr) + (path : string) = + let args = [path] in + let qcow_tool = !Xapi_globs.qcow_stream_tool in + run_qcow_tool qcow_tool progress_cb args ~input_fd:unix_fd + +let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr) + (path : string) (_size : Int64.t) = + let args = + [path] @ match relative_to with None -> [] | Some vdi -> ["--diff"; vdi] + in + let qcow_tool = !Xapi_globs.qcow_to_stdout in + run_qcow_tool qcow_tool progress_cb args ~output_fd:unix_fd diff --git a/ocaml/xapi/qcow_tool_wrapper.mli b/ocaml/xapi/qcow_tool_wrapper.mli new file mode 100644 index 0000000000..51c3c62656 --- /dev/null +++ b/ocaml/xapi/qcow_tool_wrapper.mli @@ -0,0 +1,25 @@ +(* + * Copyright (C) 2025 Vates. + * + * 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. + *) + +val update_task_progress : Context.t -> int -> unit + +val receive : (int -> unit) -> Unix.file_descr -> string -> unit + +val send : + ?relative_to:string + -> (int -> unit) + -> Unix.file_descr + -> string + -> int64 + -> unit diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index 1ec1486a3e..2800e69a2a 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -33,6 +33,8 @@ let updates_in_cache : (API.ref_host, Yojson.Basic.t) Hashtbl.t = let introduce ~__context ~name_label ~name_description ~binary_url ~source_url ~update ~gpgkey_path = + assert_url_is_not_blocked ~url:binary_url ; + assert_url_is_not_blocked ~url:source_url ; assert_url_is_valid ~url:binary_url ; assert_url_is_valid ~url:source_url ; assert_gpgkey_path_is_valid gpgkey_path ; @@ -230,7 +232,7 @@ let sync ~__context ~self ~token ~token_id ~username ~password = Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> let config_repo config = - if List.length config <> 0 then (* Set params to yum/dnf *) + if config <> [] then (* Set params to yum/dnf *) let Pkg_mgr.{cmd; params} = Pkgs.config_repo ~repo_name ~config in ignore (Helpers.call_script ~log_output:Helpers.On_failure cmd params) @@ -291,7 +293,11 @@ let sync ~__context ~self ~token ~token_id ~username ~password = * will always write_initial_yum_config every time before syncing repo, * this should be ok. *) - write_initial_yum_config ~binary_url + match Pkgs.manager with + | Yum -> + write_initial_yum_config ~binary_url + | Dnf -> + Unixext.unlink_safe !Xapi_globs.dnf_repo_config_file ) ; (* The custom yum-utils will fully download repository metadata including * the repo gpg signature. @@ -596,7 +602,7 @@ let get_host_updates_in_json ~__context ~installed = let get_repository_handler (req : Http.Request.t) s _ = let open Http in - debug "%s URL: %s" __FUNCTION__ req.Request.uri ; + debug "%s URL: %s" __FUNCTION__ req.Request.path ; req.Request.close <- true ; Fileserver.send_file Constants.get_repository_uri !Xapi_globs.local_pool_repo_dir @@ -604,7 +610,7 @@ let get_repository_handler (req : Http.Request.t) s _ = let get_enabled_repository_handler (req : Http.Request.t) s _ = let open Http in - debug "%s URL: %s" __FUNCTION__ req.Request.uri ; + debug "%s URL: %s" __FUNCTION__ req.Request.path ; req.Request.close <- true ; Xapi_http.with_context __FUNCTION__ req s (fun __context -> let enabled_repo = get_single_enabled_update_repository ~__context in @@ -700,7 +706,8 @@ let apply_livepatch ~__context ~host:_ ~component ~base_build_id ~base_version with | Some livepatch_file -> Livepatch.apply ~component:component' ~livepatch_file ~base_build_id - ~base_version ~base_release ~to_version ~to_release + ~base_version ~base_release ~to_version ~to_release ; + Create_misc.create_software_version ~__context () | None -> Helpers.internal_error ~log_err:true "No expected livepatch file for %s" component diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 62df609c53..91a3c1b467 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -209,6 +209,23 @@ let assert_url_is_valid ~url = error "Invalid url %s: %s" url (ExnHelper.string_of_exn e) ; raise Api_errors.(Server_error (invalid_base_url, [url])) +let url_matches ~url (patterns : string list) : bool = + List.exists + (fun pattern -> + try + let re = Re.Perl.re pattern |> Re.compile in + Re.execp re url + with exn -> + error "Exception in %s: %s" __FUNCTION__ (Printexc.to_string exn) ; + false + ) + patterns + +let assert_url_is_not_blocked ~url = + let blocklist = !Xapi_globs.repository_url_blocklist in + if url_matches ~url blocklist then + raise Api_errors.(Server_error (blocked_repo_url, [url])) + let is_gpgkey_path_valid = function | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index a824f77f23..2d9707ab29 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -34,7 +34,7 @@ let make_url_from_query ~(address : string) ~(uri : string) let make_url ~(address : string) ~(req : Http.Request.t) : string = let open Http.Request in - make_url_from_query ~address ~uri:req.uri ~query:req.query + make_url_from_query ~address ~uri:req.path ~query:req.query let fail_req_with (s : Unix.file_descr) msg (http_err : unit -> string list) = error msg ; @@ -67,11 +67,11 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = in let unarchive_at address = let query = (Constants.rrd_unarchive, "") :: query in - let url = make_url_from_query ~address ~uri:req.uri ~query in + let url = make_url_from_query ~address ~uri:req.path ~query in Http_svr.headers s (Http.http_302_redirect url) in let unarchive () = - let req = {req with m= Post; uri= Constants.rrd_unarchive_uri} in + let req = {req with m= Post; path= Constants.rrd_unarchive_uri} in ignore (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path @@ -136,7 +136,7 @@ let get_host_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = Http.http_400_badrequest else ( debug "get_host_rrd_forwarder: forward to unarchive" ; - let req = {req with Http.Request.uri= Constants.rrd_unarchive_uri} in + let req = {req with Http.Request.path= Constants.rrd_unarchive_uri} in ignore (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path diff --git a/ocaml/xapi/server_helpers.ml b/ocaml/xapi/server_helpers.ml index 04aae67447..0fe9383c73 100644 --- a/ocaml/xapi/server_helpers.ml +++ b/ocaml/xapi/server_helpers.ml @@ -53,9 +53,10 @@ let parameter_count_mismatch_failure func expected received = API.response_of_failure Api_errors.message_parameter_count_mismatch [func; expected; received] -(** WARNING: the context is destroyed when execution is finished if the task is not forwarded, in database and not called asynchronous. *) -let exec_with_context ~__context ~need_complete ?marshaller ?f_forward - ?(called_async = false) ?quiet f = +(** WARNING: DOES NOT DESTROY the context when execution is finished. The + caller must destroy it *) +let exec_with_context ~__context ~need_complete ?marshaller ?f_forward ?quiet f + = (* Execute fn f in specified __context, marshalling result with "marshaller" *) let exec () = (* NB: @@ -95,23 +96,15 @@ let exec_with_context ~__context ~need_complete ?marshaller ?f_forward if need_complete then TaskHelper.failed ~__context e ; raise e in - Locking_helpers.Thread_state.with_named_thread - (TaskHelper.get_name ~__context) (Context.get_task_id __context) (fun () -> - let client = Context.get_client __context in - Debug.with_thread_associated ?client ?quiet - (Context.string_of_task __context) - (fun () -> - (* CP-982: promote tracking debug line to info status *) - if called_async then - info "spawning a new thread to handle the current task%s" - (Context.trackid ~with_brackets:true ~prefix:" " __context) ; - Xapi_stdext_pervasives.Pervasiveext.finally exec (fun () -> - if not called_async then Context.destroy __context - (* else debug "nothing more to process for this thread" *) - ) - ) - () - ) + let@ () = + Locking_helpers.Thread_state.with_named_thread + (TaskHelper.get_name ~__context) + (Context.get_task_id __context) + in + let client = Context.get_client __context in + Debug.with_thread_associated ?client ?quiet + (Context.string_of_task __context) + exec () let dispatch_exn_wrapper f = try f () @@ -123,7 +116,7 @@ module Helper = struct include Tracing.Propagator.Make (struct include Tracing_propagator.Propagator.Http - let name_span req = req.Http.Request.uri + let name_span req = req.Http.Request.path end) end @@ -168,18 +161,22 @@ let do_dispatch ?session_id ?forward_op ?self:_ supports_async called_fn_name let sync () = let need_complete = not (Context.forwarded_task __context) in - exec_with_context ~__context ~need_complete ~called_async - ?f_forward:forward_op ~marshaller op_fn + let@ __context = Context.finally_destroy_context ~__context in + exec_with_context ~__context ~need_complete ?f_forward:forward_op + ~marshaller op_fn |> marshaller |> Rpc.success in + let async ~need_complete = (* Fork thread in which to execute async call *) + info "spawning a new thread to handle the current task%s" + (Context.trackid ~with_brackets:true ~prefix:" " __context) ; ignore (Thread.create (fun () -> - exec_with_context ~__context ~need_complete ~called_async - ?f_forward:forward_op ~marshaller op_fn + exec_with_context ~__context ~need_complete ?f_forward:forward_op + ~marshaller op_fn ) () ) ; @@ -200,26 +197,27 @@ let do_dispatch ?session_id ?forward_op ?self:_ supports_async called_fn_name (* 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 ?task_in_database ?task_description ?origin task_name f = - exec_with_context ?quiet - ~__context: - (Context.make ?http_other_config ?quiet ?subtask_of ?session_id - ?task_in_database ?task_description ?origin task_name - ) ~need_complete:true (fun ~__context -> f __context + let@ __context = + Context.with_context ?http_other_config ?quiet ?subtask_of ?session_id + ?task_in_database ?task_description ?origin task_name + in + exec_with_context ~__context ~need_complete:true (fun ~__context -> + f __context ) let exec_with_forwarded_task ?http_other_config ?session_id ?origin task_id f = - exec_with_context - ~__context: - (Context.from_forwarded_task ?http_other_config ?session_id ?origin - task_id - ) ~need_complete:true (fun ~__context -> f __context + let@ __context = + Context.with_forwarded_task ?http_other_config ?session_id ?origin task_id + in + exec_with_context ~__context ~need_complete:true (fun ~__context -> + f __context ) let exec_with_subtask ~__context ?task_in_database task_name f = - let subcontext = - Context.make_subcontext ~__context ?task_in_database task_name + let@ __context = + Context.with_subcontext ~__context ?task_in_database task_name in - exec_with_context ~__context:subcontext ~need_complete:true f + exec_with_context ~__context ~need_complete:true f let forward_extension ~__context rbac call = rbac __context (fun () -> Xapi_extensions.call_extension call) diff --git a/ocaml/xapi/smint.ml b/ocaml/xapi/smint.ml index e58340b523..1b4e4d45e4 100644 --- a/ocaml/xapi/smint.ml +++ b/ocaml/xapi/smint.ml @@ -132,7 +132,7 @@ module Feature = struct Some (feature, 1L) ) | feature :: _ -> - error "SM.feature: unknown feature %s" feature ; + warn "SM.feature: unknown feature %s" feature ; None (** [compat_features features1 features2] finds the compatible features in the input diff --git a/ocaml/xapi/static_vdis.ml b/ocaml/xapi/static_vdis.ml index 2197ac559a..119db57e89 100644 --- a/ocaml/xapi/static_vdis.ml +++ b/ocaml/xapi/static_vdis.ml @@ -114,12 +114,14 @@ let gc () = (list ()) ) -(** If we just rebooted and failed to attach our static VDIs then this can be called to reattempt the attach: - this is necessary for HA to start. *) +(** If we just rebooted and failed to attach our static VDIs then this can be + called to reattempt the attach: this is necessary for HA to start. *) let reattempt_on_boot_attach () = - debug "%s" __FUNCTION__ ; - let script = "attach-static-vdis" in - try ignore (Helpers.call_script "/sbin/service" [script; "start"]) + debug "%s: Attempt to reattach static VDIs" __FUNCTION__ ; + let service = "attach-static-vdis.service" in + try Xapi_systemctl.start ~wait_until_success:false service with e -> - warn "Attempt to reattach static VDIs via '%s start' failed: %s" script + warn + "%s: Attempt to reattach static VDIs via 'systemctl start %s' failed: %s" + __FUNCTION__ service (ExnHelper.string_of_exn e) diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 6f2b540dac..cda399e9d6 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -111,13 +111,12 @@ exception Message_switch_failure let on_xapi_start ~__context = (* An SM is either implemented as a plugin - for which we check its presence, or via an API *) - let is_available (_rf, rc) = + let is_available rc = Sys.file_exists rc.API.sM_driver_filename || Version.String.ge rc.sM_required_api_version "5.0" in let existing = Db.SM.get_all_records ~__context - |> List.filter is_available |> List.map (fun (rf, rc) -> (rc.API.sM_type, (rf, rc))) in let explicitly_configured_drivers = @@ -172,6 +171,9 @@ let on_xapi_start ~__context = in (* Add all the running SMAPIv2 drivers *) let to_keep = to_keep @ running_smapiv2_drivers in + let unavailable = + List.filter (fun (_, (_, rc)) -> not (is_available rc)) existing + in (* Delete all records which aren't configured or in-use *) List.iter (fun ty -> @@ -182,6 +184,13 @@ let on_xapi_start ~__context = try Db.SM.destroy ~__context ~self with _ -> () ) (Listext.List.set_difference (List.map fst existing) to_keep) ; + List.iter + (fun (name, (self, rc)) -> + info "%s: unregistering SM plugin %s (%s) since it is unavailable" + __FUNCTION__ name rc.API.sM_uuid ; + try Db.SM.destroy ~__context ~self with _ -> () + ) + unavailable ; (* Synchronize SMAPIv1 plugins *) @@ -446,7 +455,7 @@ let update_task ~__context id = let update_mirror ~__context id = try let dbg = Context.string_of_task __context in - let m = Storage_migrate.stat ~dbg ~id in + let m = Client.DATA.MIRROR.stat dbg id in if m.Mirror.failed then debug "Mirror %s has failed" id ; let task = get_mirror_task id in diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index 54144ce5a2..1ff03c3d7e 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -40,29 +40,15 @@ let choose_backend dbg sr = (** module [MigrateRemote] is similar to [MigrateLocal], but most of these functions tend to be executed on the receiver side. *) module MigrateRemote = struct - (** [receive_finalize2 dbg mirror_id sr url verify_dest] takes an [sr] parameter + (** [receive_finalize3 dbg mirror_id sr url verify_dest] takes an [sr] parameter which is the source sr and multiplexes based on the type of that *) - let receive_finalize2 ~dbg ~mirror_id ~sr ~url ~verify_dest = + let receive_finalize3 ~dbg ~mirror_id ~sr ~url ~verify_dest = let (module Migrate_Backend) = choose_backend dbg sr in - Migrate_Backend.receive_finalize2 () ~dbg ~mirror_id ~sr ~url ~verify_dest + Migrate_Backend.receive_finalize3 () ~dbg ~mirror_id ~sr ~url ~verify_dest - let receive_cancel2 ~dbg ~mirror_id ~url ~verify_dest = - let (module Remote) = - Storage_migrate_helper.get_remote_backend url verify_dest - in - let receive_state = State.find_active_receive_mirror mirror_id in - let open State.Receive_state in - Option.iter - (fun r -> - D.log_and_ignore_exn (fun () -> Remote.DP.destroy dbg r.leaf_dp false) ; - List.iter - (fun v -> - D.log_and_ignore_exn (fun () -> Remote.VDI.destroy dbg r.sr v) - ) - [r.dummy_vdi; r.leaf_vdi; r.parent_vdi] - ) - receive_state ; - State.remove_receive_mirror mirror_id + let receive_cancel2 ~dbg ~mirror_id ~sr ~url ~verify_dest = + let (module Migrate_Backend) = choose_backend dbg sr in + Migrate_Backend.receive_cancel2 () ~dbg ~mirror_id ~url ~verify_dest end (** This module [MigrateLocal] consists of the concrete implementations of the @@ -107,7 +93,7 @@ module MigrateLocal = struct debug "Snapshot VDI already cleaned up" ) ; try - MigrateRemote.receive_cancel2 ~dbg ~mirror_id:id + MigrateRemote.receive_cancel2 ~dbg ~mirror_id:id ~sr ~url:remote_info.url ~verify_dest:remote_info.verify_dest with _ -> () ) @@ -131,7 +117,7 @@ module MigrateLocal = struct try let (module Migrate_Backend) = choose_backend dbg sr in let similars = similar_vdis ~dbg ~sr ~vdi in - Migrate_Backend.receive_start2 () ~dbg ~sr:dest ~vdi_info:local_vdi + Migrate_Backend.receive_start3 () ~dbg ~sr:dest ~vdi_info:local_vdi ~mirror_id ~similar:similars ~vm:mirror_vm ~url ~verify_dest with e -> error "%s Caught error %s while preparing for SXM" __FUNCTION__ @@ -186,8 +172,8 @@ module MigrateLocal = struct ~verify_dest in Migrate_Backend.send_start () ~dbg ~task_id ~dp ~sr ~vdi ~mirror_vm - ~mirror_id ~local_vdi ~copy_vm ~live_vm:(Vm.of_string "0") ~url - ~remote_mirror ~dest_sr:dest ~verify_dest ; + ~mirror_id ~local_vdi ~copy_vm ~live_vm ~url ~remote_mirror + ~dest_sr:dest ~verify_dest ; Some (Mirror_id mirror_id) with | Storage_error (Sr_not_attached sr_uuid) -> @@ -196,9 +182,14 @@ module MigrateLocal = struct raise (Api_errors.Server_error (Api_errors.sr_not_attached, [sr_uuid])) | ( Storage_error (Migration_mirror_fd_failure reason) | Storage_error (Migration_mirror_snapshot_failure reason) ) as e -> - error "%s: Caught %s: during storage migration preparation" __FUNCTION__ - reason ; - MigrateRemote.receive_cancel2 ~dbg ~mirror_id ~url ~verify_dest ; + error "%s: Caught %s: during SMAPIv1 storage migration mirror " + __FUNCTION__ reason ; + MigrateRemote.receive_cancel2 ~dbg ~mirror_id ~sr ~url ~verify_dest ; + raise e + | Storage_error (Migration_mirror_failure reason) as e -> + error "%s: Caught :%s: during SMAPIv3 storage migration mirror" + __FUNCTION__ reason ; + MigrateRemote.receive_cancel2 ~dbg ~mirror_id ~sr ~url ~verify_dest ; raise e | Storage_error (Migration_mirror_copy_failure reason) as e -> error "%s: Caught %s: during storage migration copy" __FUNCTION__ reason ; @@ -209,28 +200,20 @@ module MigrateLocal = struct stop ~dbg ~id:mirror_id ; raise e - let stat ~dbg:_ ~id = + let stat ~dbg ~id = let recv_opt = State.find_active_receive_mirror id in let send_opt = State.find_active_local_mirror id in let copy_opt = State.find_active_copy id in + let sr, _vdi = State.of_mirror_id id in let open State in let failed = match send_opt with | Some send_state -> + let (module Migrate_Backend) = choose_backend dbg sr in let failed = - match send_state.Send_state.tapdev with - | Some tapdev -> ( - try - let stats = Tapctl.stats (Tapctl.create ()) tapdev in - stats.Tapctl.Stats.nbd_mirror_failed = 1 - with _ -> - debug "Using cached copy of failure status" ; - send_state.Send_state.failed - ) - | None -> - false + Migrate_Backend.has_mirror_failed () ~dbg ~mirror_id:id ~sr in - send_state.Send_state.failed <- failed ; + send_state.failed <- failed ; failed | None -> false @@ -315,68 +298,20 @@ module MigrateLocal = struct copy_ops ; List.iter (fun (mirror_id, (recv_state : State.Receive_state.t)) -> + let sr, _vdi = State.of_mirror_id mirror_id in debug "Receive in progress: %s" mirror_id ; log_and_ignore_exn (fun () -> - MigrateRemote.receive_cancel2 ~dbg ~mirror_id ~url:recv_state.url - ~verify_dest:recv_state.verify_dest + MigrateRemote.receive_cancel2 ~dbg ~mirror_id ~sr + ~url:recv_state.url ~verify_dest:recv_state.verify_dest ) ) recv_ops ; State.clear () end -exception Timeout of Mtime.Span.t - -let reqs_outstanding_timeout = Mtime.Span.(150 * s) - -let pp_time () = Fmt.str "%a" Mtime.Span.pp - -(* Tapdisk should time out after 2 mins. We can wait a little longer *) - -let pre_deactivate_hook ~dbg:_ ~dp:_ ~sr ~vdi = - let open State.Send_state in - let id = State.mirror_id_of (sr, vdi) in - let start = Mtime_clock.counter () in - State.find_active_local_mirror id - |> Option.iter (fun s -> - (* We used to pause here and then check the nbd_mirror_failed key. Now, we poll - until the number of outstanding requests has gone to zero, then check the - status. This avoids confusing the backend (CA-128460) *) - try - match s.tapdev with - | None -> - () - | Some tapdev -> - let open Tapctl in - let ctx = create () in - let rec wait () = - let elapsed = Mtime_clock.count start in - if Mtime.Span.compare elapsed reqs_outstanding_timeout > 0 then - raise (Timeout elapsed) ; - let st = stats ctx tapdev in - if st.Stats.reqs_outstanding > 0 then ( - Thread.delay 1.0 ; wait () - ) else - (st, elapsed) - in - let st, elapsed = wait () in - debug "Got final stats after waiting %a" pp_time elapsed ; - if st.Stats.nbd_mirror_failed = 1 then ( - error "tapdisk reports mirroring failed" ; - s.failed <- true - ) - with - | Timeout elapsed -> - error - "Timeout out after %a waiting for tapdisk to complete all \ - outstanding requests" - pp_time elapsed ; - s.failed <- true - | e -> - error "Caught exception while finally checking mirror state: %s" - (Printexc.to_string e) ; - s.failed <- true - ) +let pre_deactivate_hook ~dbg ~dp ~sr ~vdi = + let (module Migrate_Backend) = choose_backend dbg sr in + Migrate_Backend.pre_deactivate_hook () ~dbg ~dp ~sr ~vdi let post_deactivate_hook ~sr ~vdi ~dp:_ = let open State.Send_state in @@ -389,15 +324,14 @@ let post_deactivate_hook ~sr ~vdi ~dp:_ = r.remote_info in let (module Remote) = get_remote_backend r.url verify_dest in - debug "Calling receive_finalize2" ; + debug "Calling receive_finalize3" ; log_and_ignore_exn (fun () -> - MigrateRemote.receive_finalize2 ~dbg:"Mirror-cleanup" ~mirror_id:id + MigrateRemote.receive_finalize3 ~dbg:"Mirror-cleanup" ~mirror_id:id ~sr ~url:r.url ~verify_dest ) ; - debug "Finished calling receive_finalize2" ; + debug "Finished calling receive_finalize3" ; State.remove_local_mirror id ; - debug "Removed active local mirror: %s" id ; - Option.iter (fun id -> Scheduler.cancel scheduler id) r.watchdog + debug "Removed active local mirror: %s" id ) let nbd_handler req s ?(vm = "0") sr vdi dp = @@ -430,7 +364,7 @@ let nbd_handler req s ?(vm = "0") sr vdi dp = (** nbd_proxy is a http handler but will turn the http connection into an nbd connection. It proxies the connection between the sender and the generic nbd server, as returned by [get_nbd_server dp sr vdi vm]. *) -let nbd_proxy req s vm sr vdi dp = +let import_nbd_proxy req s vm sr vdi dp = debug "%s: vm=%s sr=%s vdi=%s dp=%s" __FUNCTION__ vm sr vdi dp ; let sr, vdi = Storage_interface.(Sr.of_string sr, Vdi.of_string vdi) in req.Http.Request.close <- true ; @@ -508,7 +442,9 @@ let stop = MigrateLocal.stop let list = MigrateLocal.list -let killall = MigrateLocal.killall +let killall ~dbg = + with_dbg ~name:__FUNCTION__ ~dbg @@ fun di -> + MigrateLocal.killall ~dbg:(Debug_info.to_string di) let stat = MigrateLocal.stat diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index c9a387f626..0427f76ca5 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -27,6 +27,8 @@ let s_of_vdi = Storage_interface.Vdi.string_of let s_of_vm = Storage_interface.Vm.string_of +let s_of_operation = Storage_interface.Mirror.show_operation + let with_dbg ~name ~dbg f = Debug_info.with_dbg ~with_thread:true ~module_name:"SMAPIv2" ~name ~dbg f @@ -642,10 +644,23 @@ module Mux = struct with_dbg ~name:"VDI.deativate" ~dbg @@ fun di -> info "VDI.deactivate dbg:%s dp:%s sr:%s vdi:%s vm:%s" dbg dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) ; - let module C = StorageAPI (Idl.Exn.GenClient (struct - let rpc = of_sr sr - end)) in - C.VDI.deactivate (Debug_info.to_string di) dp sr vdi vm + let open DP_info in + match read dp with + | Some {sr; vdi; vm; _} -> + let module C = StorageAPI (Idl.Exn.GenClient (struct + let rpc = of_sr sr + end)) in + C.VDI.deactivate (Debug_info.to_string di) dp sr vdi vm ; + (*XX The hook should not be called here, nor should storage_mux care about + the SMAPI version of the SR, but as xapi-storage-script cannot call code + xapi, and smapiv1_wrapper has state tracking logic, the hook has to be placed + here for now. *) + if smapi_version_of_sr sr = SMAPIv3 then + Storage_migrate.post_deactivate_hook ~sr ~vdi ~dp + | None -> + info + "dp %s is not associated with a locally attached VDI; nothing to do" + dp let detach () ~dbg ~dp ~sr ~vdi ~vm = with_dbg ~name:"VDI.detach" ~dbg @@ fun di -> @@ -797,6 +812,24 @@ module Mux = struct let copy () ~dbg = with_dbg ~name:"DATA.copy" ~dbg @@ fun dbg -> Storage_migrate.copy ~dbg + let mirror () ~dbg ~sr ~vdi ~vm ~dest = + with_dbg ~name:"DATA.mirror" ~dbg @@ fun di -> + info "%s dbg:%s sr: %s vdi: %s vm:%s remote:%s" __FUNCTION__ dbg + (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) dest ; + let module C = StorageAPI (Idl.Exn.GenClient (struct + let rpc = of_sr sr + end)) in + C.DATA.mirror (Debug_info.to_string di) sr vdi vm dest + + let stat () ~dbg ~sr ~vdi ~vm ~key = + with_dbg ~name:"DATA.stat" ~dbg @@ fun di -> + info "%s dbg:%s sr: %s vdi: %s vm: %s opeartion_key: %s" __FUNCTION__ dbg + (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) (s_of_operation key) ; + let module C = StorageAPI (Idl.Exn.GenClient (struct + let rpc = of_sr sr + end)) in + C.DATA.stat (Debug_info.to_string di) sr vdi vm key + let import_activate () ~dbg ~dp ~sr ~vdi ~vm = with_dbg ~name:"DATA.import_activate" ~dbg @@ fun di -> info "%s dbg:%s dp:%s sr:%s vdi:%s vm:%s" __FUNCTION__ dbg dp (s_of_sr sr) @@ -818,12 +851,11 @@ module Mux = struct module MIRROR = struct type context = unit - let u x = raise Storage_interface.(Storage_error (Errors.Unimplemented x)) - let send_start _ctx ~dbg:_ ~task_id:_ ~dp:_ ~sr:_ ~vdi:_ ~mirror_vm:_ ~mirror_id:_ ~local_vdi:_ ~copy_vm:_ ~live_vm:_ ~url:_ ~remote_mirror:_ ~dest_sr:_ ~verify_dest:_ = - u "DATA.MIRROR.send_start" (* see storage_smapi{v1,v3}_migrate.ml *) + Storage_interface.unimplemented + __FUNCTION__ (* see storage_smapi{v1,v3}_migrate.ml *) let receive_start () ~dbg ~sr ~vdi_info ~id ~similar = with_dbg ~name:"DATA.MIRROR.receive_start" ~dbg @@ fun _di -> @@ -837,18 +869,37 @@ module Mux = struct Storage_smapiv1_migrate.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~similar - (** see storage_smapiv{1,3}_migrate.receive_start2 *) - let receive_start2 () ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ ~similar:_ + 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 similar: %s vm: %s" + __FUNCTION__ dbg (s_of_sr sr) + (string_of_vdi_info vdi_info) + 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 + ~similar ~vm + + (** see storage_smapiv{1,3}_migrate.receive_start3 *) + let receive_start3 () ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ ~similar:_ ~vm:_ = - u __FUNCTION__ + Storage_interface.unimplemented __FUNCTION__ let receive_finalize () ~dbg ~id = with_dbg ~name:"DATA.MIRROR.receive_finalize" ~dbg @@ fun di -> info "%s dbg: %s mirror_id: %s" __FUNCTION__ dbg id ; Storage_smapiv1_migrate.MIRROR.receive_finalize () ~dbg:di.log ~id - let receive_finalize2 () ~dbg:_ ~mirror_id:_ ~sr:_ ~url:_ ~verify_dest:_ = - u __FUNCTION__ + let receive_finalize2 () ~dbg ~id = + with_dbg ~name:"DATA.MIRROR.receive_finalize2" ~dbg @@ fun di -> + info "%s dbg: %s mirror_id: %s" __FUNCTION__ dbg id ; + Storage_smapiv1_migrate.MIRROR.receive_finalize2 () ~dbg:di.log ~id + + let receive_finalize3 () ~dbg:_ ~mirror_id:_ ~sr:_ ~url:_ ~verify_dest:_ = + Storage_interface.unimplemented __FUNCTION__ let receive_cancel () ~dbg ~id = with_dbg ~name:"DATA.MIRROR.receive_cancel" ~dbg @@ fun di -> @@ -856,7 +907,23 @@ module Mux = struct Storage_smapiv1_migrate.MIRROR.receive_cancel () ~dbg:di.log ~id let receive_cancel2 () ~dbg:_ ~mirror_id:_ ~url:_ ~verify_dest:_ = - u __FUNCTION__ + Storage_interface.unimplemented __FUNCTION__ + + let pre_deactivate_hook _ctx ~dbg:_ ~dp:_ ~sr:_ ~vdi:_ = + Storage_interface.unimplemented __FUNCTION__ + + let has_mirror_failed _ctx ~dbg:_ ~mirror_id:_ ~sr:_ = + Storage_interface.unimplemented __FUNCTION__ + + let list () ~dbg = + with_dbg ~name:"DATA.MIRROR.list" ~dbg @@ fun di -> + info "%s dbg: %s" __FUNCTION__ dbg ; + Storage_migrate.list ~dbg:di.log + + let stat () ~dbg ~id = + with_dbg ~name:"DATA.MIRROR.stat" ~dbg @@ fun di -> + info "%s dbg: %s mirror_id: %s" __FUNCTION__ di.log id ; + Storage_migrate.stat ~dbg:di.log ~id end end diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index 708e35c0a9..0995edc35c 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -478,6 +478,7 @@ module SMAPIv1 : Server_impl = struct ; backend_type= "vbd3" } ; BlockDevice {path= params} + ; Nbd {uri= attach_info_v1.Smint.params_nbd} ] ) } @@ -1128,6 +1129,10 @@ module SMAPIv1 : Server_impl = struct let copy _context ~dbg:_ ~sr:_ ~vdi:_ ~vm:_ ~url:_ ~dest:_ ~verify_dest:_ = assert false + let mirror _context ~dbg:_ ~sr:_ ~vdi:_ ~vm:_ ~dest:_ = assert false + + let stat _context ~dbg:_ ~sr:_ ~vdi:_ ~vm:_ ~key:_ = assert false + let import_activate _context ~dbg:_ ~dp:_ ~sr:_ ~vdi:_ ~vm:_ = assert false let get_nbd_server _context ~dbg:_ ~dp:_ ~sr:_ ~vdi:_ ~vm:_ = assert false @@ -1143,13 +1148,19 @@ module SMAPIv1 : Server_impl = struct let receive_start _context ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ = assert false - let receive_start2 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ + let receive_start2 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ + ~vm:_ = + assert false + + let receive_start3 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ ~similar:_ ~vm:_ ~url:_ ~verify_dest:_ = assert false let receive_finalize _context ~dbg:_ ~id:_ = assert false - let receive_finalize2 _context ~dbg:_ ~mirror_id:_ ~sr:_ ~url:_ + let receive_finalize2 _context ~dbg:_ ~id:_ = assert false + + let receive_finalize3 _context ~dbg:_ ~mirror_id:_ ~sr:_ ~url:_ ~verify_dest:_ = assert false @@ -1157,6 +1168,14 @@ module SMAPIv1 : Server_impl = struct let receive_cancel2 _context ~dbg:_ ~mirror_id:_ ~url:_ ~verify_dest:_ = assert false + + let pre_deactivate_hook _context ~dbg:_ ~dp:_ ~sr:_ ~vdi:_ = assert false + + let has_mirror_failed _context ~dbg:_ ~mirror_id:_ ~sr:_ = assert false + + let list _context ~dbg:_ = assert false + + let stat _context ~dbg:_ ~id:_ = assert false end end diff --git a/ocaml/xapi/storage_smapiv1_migrate.ml b/ocaml/xapi/storage_smapiv1_migrate.ml index d6156a7fad..d64ba5d0d4 100644 --- a/ocaml/xapi/storage_smapiv1_migrate.ml +++ b/ocaml/xapi/storage_smapiv1_migrate.ml @@ -25,6 +25,12 @@ module SXM = Storage_migrate_helper.SXM module type SMAPIv2_MIRROR = Storage_interface.MIRROR +let s_of_sr = Storage_interface.Sr.string_of + +let s_of_vdi = Storage_interface.Vdi.string_of + +let s_of_vm = Storage_interface.Vm.string_of + let with_activated_disk ~dbg ~sr ~vdi ~dp ~vm f = let attached_vdi = Option.map @@ -196,8 +202,9 @@ module Copy = struct let leaf_dp = Uuidx.(to_string (make ())) in let dest_vdi_url = let url' = Http.Url.of_string url in - Http.Url.set_uri url' - (Printf.sprintf "%s/nbdproxy/%s/%s/%s/%s" (Http.Url.get_uri url') + Http.Url.set_path url' + (Printf.sprintf "%s/nbdproxy/import/%s/%s/%s/%s" + (Http.Url.get_path url') (Storage_interface.Vm.string_of vm) (Storage_interface.Sr.string_of dest) (Storage_interface.Vdi.string_of dest_vdi) @@ -389,6 +396,11 @@ end let mirror_pass_fds ~dbg ~dp ~sr ~vdi ~mirror_vm ~live_vm ~mirror_id ~url ~dest_sr ~verify_dest ~(remote_mirror : Mirror.mirror_receive_result_vhd_t) = + D.debug + "%s dbg:%s dp:%s sr:%s vdi:%s mirror_vm:%s live_vm:%s mirror_id:%s url:%s \ + dest_sr:%s verify_dest:%B" + __FUNCTION__ dbg dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm mirror_vm) + (s_of_vm live_vm) mirror_id url (s_of_sr dest_sr) verify_dest ; let remote_vdi = remote_mirror.mirror_vdi.vdi in let mirror_dp = remote_mirror.mirror_datapath in @@ -400,7 +412,7 @@ let mirror_pass_fds ~dbg ~dp ~sr ~vdi ~mirror_vm ~live_vm ~mirror_id ~url mirror_dp in D.debug "%s: uri of http request for mirroring is %s" __FUNCTION__ uri ; - let dest_url = Http.Url.set_uri (Http.Url.of_string url) uri in + let dest_url = Http.Url.set_path (Http.Url.of_string url) uri in D.debug "%s url of http request for mirroring is %s" __FUNCTION__ (Http.Url.to_string dest_url) ; let request = @@ -482,6 +494,9 @@ let mirror_pass_fds ~dbg ~dp ~sr ~vdi ~mirror_vm ~live_vm ~mirror_id ~url tapdev let mirror_snapshot ~dbg ~sr ~dp ~mirror_id ~local_vdi = + D.debug "%s dbg:%s sr:%s dp:%s mirror_id:%s local_vdi:%s" __FUNCTION__ dbg + (s_of_sr sr) dp mirror_id + (string_of_vdi_info local_vdi) ; SXM.info "%s About to snapshot VDI = %s" __FUNCTION__ (string_of_vdi_info local_vdi) ; let local_vdi = add_to_sm_config local_vdi "mirror" ("nbd:" ^ dp) in @@ -552,13 +567,22 @@ let mirror_cleanup ~dbg ~sr ~snapshot = module MIRROR : SMAPIv2_MIRROR = struct type context = unit - let u x = raise Storage_interface.(Storage_error (Errors.Unimplemented x)) - let send_start _ctx ~dbg ~task_id ~dp ~sr ~vdi ~mirror_vm ~mirror_id ~local_vdi ~copy_vm ~live_vm ~url ~remote_mirror ~dest_sr ~verify_dest = + D.debug + "%s dbg: %s dp: %s sr: %s vdi:%s mirror_vm:%s mirror_id: %s live_vm: %s \ + url:%s dest_sr:%s verify_dest:%B" + __FUNCTION__ dbg dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm mirror_vm) + mirror_id (s_of_vm live_vm) url (s_of_sr dest_sr) verify_dest ; let (module Remote) = Storage_migrate_helper.get_remote_backend url verify_dest in + + let read_write = true in + (* DP set up is only essential for MIRROR.start/stop due to their open ended pattern. + It's not necessary for copy which will take care of that itself. *) + ignore (Local.VDI.attach3 dbg dp sr vdi (Vm.of_string "0") read_write) ; + Local.VDI.activate3 dbg dp sr vdi (Vm.of_string "0") ; match remote_mirror with | Mirror.SMAPIv3_mirror _ -> (* this should never happen *) @@ -661,8 +685,8 @@ module MIRROR : SMAPIv2_MIRROR = struct (* The state tracking here does not need to be changed, however, it will be stored in memory on different hosts. If receive_start is called, by an older host, this State.add is run on the destination host. On the other hand, if - receive_start2 is called, this will be stored in memory on the source host. - receive_finalize2 and receive_cancel2 handles this similarly. *) + receive_start3 is called, this will be stored in memory on the source host. + receive_finalize3 and receive_cancel2 handles this similarly. *) State.add id State.( Recv_op @@ -699,11 +723,24 @@ module MIRROR : SMAPIv2_MIRROR = struct raise e 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 ; receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm:(Vm.of_string "0") (module Local) - let receive_start2 _ctx ~dbg ~sr ~vdi_info ~mirror_id ~similar ~vm ~url + 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 ; + receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm (module Local) + + let receive_start3 _ctx ~dbg ~sr ~vdi_info ~mirror_id ~similar ~vm ~url ~verify_dest = + D.debug "%s dbg: %s sr: %s vdi: %s id: %s vm: %s url: %s verify_dest: %B" + __FUNCTION__ dbg (s_of_sr sr) + (string_of_vdi_info vdi_info) + mirror_id (s_of_vm vm) url verify_dest ; let (module Remote) = Storage_migrate_helper.get_remote_backend url verify_dest in @@ -711,15 +748,13 @@ module MIRROR : SMAPIv2_MIRROR = struct (module Remote) let receive_finalize _ctx ~dbg ~id = + D.debug "%s dbg:%s id: %s" __FUNCTION__ dbg id ; let recv_state = State.find_active_receive_mirror id in let open State.Receive_state in Option.iter (fun r -> Local.DP.destroy dbg r.leaf_dp false) recv_state ; State.remove_receive_mirror id - let receive_finalize2 _ctx ~dbg ~mirror_id ~sr:_ ~url ~verify_dest = - let (module Remote) = - Storage_migrate_helper.get_remote_backend url verify_dest - in + let receive_finalize_common ~dbg ~mirror_id (module SMAPI : SMAPIv2) = let recv_state = State.find_active_receive_mirror mirror_id in let open State.Receive_state in Option.iter @@ -729,17 +764,30 @@ module MIRROR : SMAPIv2_MIRROR = struct __FUNCTION__ (Sr.string_of r.sr) (Vdi.string_of r.parent_vdi) (Vdi.string_of r.leaf_vdi) ; - Remote.DP.destroy2 dbg r.leaf_dp r.sr r.leaf_vdi r.mirror_vm false ; - Remote.VDI.compose dbg r.sr r.parent_vdi r.leaf_vdi ; + SMAPI.DP.destroy2 dbg r.leaf_dp r.sr r.leaf_vdi r.mirror_vm false ; + SMAPI.VDI.compose dbg r.sr r.parent_vdi r.leaf_vdi ; (* On SMAPIv3, compose would have removed the now invalid dummy vdi, so there is no need to destroy it anymore, while this is necessary on SMAPIv1 SRs. *) - D.log_and_ignore_exn (fun () -> Remote.VDI.destroy dbg r.sr r.dummy_vdi) ; - Remote.VDI.remove_from_sm_config dbg r.sr r.leaf_vdi "base_mirror" + D.log_and_ignore_exn (fun () -> SMAPI.VDI.destroy dbg r.sr r.dummy_vdi) ; + SMAPI.VDI.remove_from_sm_config dbg r.sr r.leaf_vdi "base_mirror" ) recv_state ; State.remove_receive_mirror mirror_id + let receive_finalize2 _ctx ~dbg ~id = + D.debug "%s dbg:%s id: %s" __FUNCTION__ dbg id ; + receive_finalize_common ~dbg ~mirror_id:id (module Local) + + let receive_finalize3 _ctx ~dbg ~mirror_id ~sr ~url ~verify_dest = + D.debug "%s dbg:%s id: %s sr: %s url: %s verify_dest: %B" __FUNCTION__ dbg + mirror_id (s_of_sr sr) url verify_dest ; + let (module Remote) = + Storage_migrate_helper.get_remote_backend url verify_dest + in + receive_finalize_common ~dbg ~mirror_id (module Remote) + let receive_cancel _ctx ~dbg ~id = + D.debug "%s dbg:%s mirror_id:%s" __FUNCTION__ dbg id ; let receive_state = State.find_active_receive_mirror id in let open State.Receive_state in Option.iter @@ -754,7 +802,99 @@ module MIRROR : SMAPIv2_MIRROR = struct receive_state ; State.remove_receive_mirror id - let receive_cancel2 _ctx ~dbg:_ ~mirror_id:_ ~url:_ ~verify_dest:_ = - (* see Storage_migrate.receive_cancel2 *) - u __FUNCTION__ + exception Timeout of Mtime.Span.t + + let reqs_outstanding_timeout = Mtime.Span.(150 * s) + + let pp_time () = Fmt.str "%a" Mtime.Span.pp + + (* Tapdisk should time out after 2 mins. We can wait a little longer *) + + let pre_deactivate_hook _ctx ~dbg ~dp ~sr ~vdi = + D.debug "%s dbg:%s dp:%s sr:%s vdi:%s" __FUNCTION__ dbg dp (s_of_sr sr) + (s_of_vdi vdi) ; + let open State.Send_state in + let id = State.mirror_id_of (sr, vdi) in + let start = Mtime_clock.counter () in + State.find_active_local_mirror id + |> Option.iter (fun s -> + (* We used to pause here and then check the nbd_mirror_failed key. Now, we poll + until the number of outstanding requests has gone to zero, then check the + status. This avoids confusing the backend (CA-128460) *) + try + match s.tapdev with + | None -> + () + | Some tapdev -> + let open Tapctl in + let ctx = create () in + let rec wait () = + let elapsed = Mtime_clock.count start in + if Mtime.Span.compare elapsed reqs_outstanding_timeout > 0 + then + raise (Timeout elapsed) ; + let st = stats ctx tapdev in + if st.Stats.reqs_outstanding > 0 then ( + Thread.delay 1.0 ; wait () + ) else + (st, elapsed) + in + let st, elapsed = wait () in + D.debug "Got final stats after waiting %a" pp_time elapsed ; + if st.Stats.nbd_mirror_failed = 1 then ( + D.error "tapdisk reports mirroring failed" ; + s.failed <- true + ) ; + Option.iter + (fun id -> Scheduler.cancel scheduler id) + s.watchdog + with + | Timeout elapsed -> + D.error + "Timeout out after %a waiting for tapdisk to complete all \ + outstanding requests while migrating vdi %s of domain %s" + pp_time elapsed (s_of_vdi vdi) (s_of_vm s.live_vm) ; + s.failed <- true + | e -> + D.error + "Caught exception while finally checking mirror state: %s \ + when migrating vdi %s of domain %s" + (Printexc.to_string e) (s_of_vdi vdi) (s_of_vm s.live_vm) ; + s.failed <- true + ) + + let has_mirror_failed _ctx ~dbg:_ ~mirror_id ~sr:_ = + match State.find_active_local_mirror mirror_id with + | Some {tapdev= Some tapdev; failed; _} -> ( + try + let stats = Tapctl.stats (Tapctl.create ()) tapdev in + stats.Tapctl.Stats.nbd_mirror_failed = 1 + with _ -> + D.debug "Using cached copy of failure status" ; + failed + ) + | _ -> + false + + let list _ctx = Storage_interface.unimplemented __FUNCTION__ + + let stat _ctx = Storage_interface.unimplemented __FUNCTION__ + + let receive_cancel2 _ctx ~dbg ~mirror_id ~url ~verify_dest = + let (module Remote) = + Storage_migrate_helper.get_remote_backend url verify_dest + in + let receive_state = State.find_active_receive_mirror mirror_id in + let open State.Receive_state in + Option.iter + (fun r -> + D.log_and_ignore_exn (fun () -> Remote.DP.destroy dbg r.leaf_dp false) ; + List.iter + (fun v -> + D.log_and_ignore_exn (fun () -> Remote.VDI.destroy dbg r.sr v) + ) + [r.dummy_vdi; r.leaf_vdi; r.parent_vdi] + ) + receive_state ; + State.remove_receive_mirror mirror_id end diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 7d418fb909..86879780fb 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -1142,6 +1142,12 @@ functor (s_of_vdi vdi) url (s_of_sr dest) ; Impl.DATA.copy context ~dbg ~sr ~vdi ~vm ~url ~dest + let mirror _context ~dbg:_ ~sr:_ ~vdi:_ ~vm:_ ~dest:_ = + Storage_interface.unimplemented __FUNCTION__ + + let stat _context ~dbg:_ ~sr:_ ~vdi:_ ~vm:_ ~key:_ = + Storage_interface.unimplemented __FUNCTION__ + (* tapdisk supports three kind of nbd servers, the old style nbdserver, the new style nbd server and a real nbd server. The old and new style nbd servers are "special" nbd servers that accept fds passed via SCM_RIGHTS and handle @@ -1186,13 +1192,10 @@ functor module MIRROR = struct type context = unit - let u x = - raise Storage_interface.(Storage_error (Errors.Unimplemented x)) - let send_start _ctx ~dbg:_ ~task_id:_ ~dp:_ ~sr:_ ~vdi:_ ~mirror_vm:_ ~mirror_id:_ ~local_vdi:_ ~copy_vm:_ ~live_vm:_ ~url:_ ~remote_mirror:_ ~dest_sr:_ ~verify_dest:_ = - u "DATA.MIRROR.send_start" + Storage_interface.unimplemented __FUNCTION__ let receive_start context ~dbg ~sr ~vdi_info ~id ~similar = info "DATA.MIRROR.receive_start dbg:%s sr:%s id:%s similar:[%s]" dbg @@ -1200,25 +1203,50 @@ functor (String.concat "," similar) ; Impl.DATA.MIRROR.receive_start context ~dbg ~sr ~vdi_info ~id ~similar - let receive_start2 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ + let receive_start2 context ~dbg ~sr ~vdi_info ~id ~similar ~vm = + info + "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 + ~similar ~vm + + let receive_start3 _context ~dbg:_ ~sr:_ ~vdi_info:_ ~mirror_id:_ ~similar:_ ~vm:_ = - u __FUNCTION__ + (* See Storage_smapiv1_migrate.receive_start3 *) + Storage_interface.unimplemented __FUNCTION__ let receive_finalize context ~dbg ~id = info "DATA.MIRROR.receive_finalize dbg:%s id:%s" dbg id ; Impl.DATA.MIRROR.receive_finalize context ~dbg ~id - let receive_finalize2 _context ~dbg:_ ~mirror_id:_ ~sr:_ ~url:_ + let receive_finalize2 context ~dbg ~id = + info "DATA.MIRROR.receive_finalize2 dbg:%s id:%s" dbg id ; + Impl.DATA.MIRROR.receive_finalize2 context ~dbg ~id + + let receive_finalize3 _context ~dbg:_ ~mirror_id:_ ~sr:_ ~url:_ ~verify_dest:_ = (* see storage_smapiv{1,3}_migrate *) - u __FUNCTION__ + Storage_interface.unimplemented __FUNCTION__ let receive_cancel context ~dbg ~id = info "DATA.MIRROR.receive_cancel dbg:%s id:%s" dbg id ; Impl.DATA.MIRROR.receive_cancel context ~dbg ~id let receive_cancel2 _context ~dbg:_ ~mirror_id:_ ~url:_ ~verify_dest:_ = - u __FUNCTION__ + Storage_interface.unimplemented __FUNCTION__ + + let pre_deactivate_hook _context ~dbg:_ ~dp:_ ~sr:_ ~vdi:_ = + Storage_interface.unimplemented __FUNCTION__ + + let has_mirror_failed _context ~dbg:_ ~mirror_id:_ ~sr:_ = + Storage_interface.unimplemented __FUNCTION__ + + let list _context ~dbg:_ = Storage_interface.unimplemented __FUNCTION__ + + let stat _context ~dbg:_ ~id:_ = + Storage_interface.unimplemented __FUNCTION__ end end diff --git a/ocaml/xapi/storage_smapiv3_migrate.ml b/ocaml/xapi/storage_smapiv3_migrate.ml index 72d9f2bde9..958c2da5e0 100644 --- a/ocaml/xapi/storage_smapiv3_migrate.ml +++ b/ocaml/xapi/storage_smapiv3_migrate.ml @@ -12,30 +12,326 @@ * GNU Lesser General Public License for more details. *) -module D = Debug.Make (struct let name = "storage_smapiv1_migrate" end) +module D = Debug.Make (struct let name = __MODULE__ end) module Unixext = Xapi_stdext_unix.Unixext module State = Storage_migrate_helper.State module SXM = Storage_migrate_helper.SXM +open Storage_interface +open Storage_task +open Xmlrpc_client +open Storage_migrate_helper module type SMAPIv2_MIRROR = Storage_interface.MIRROR +let s_of_sr = Storage_interface.Sr.string_of + +let s_of_vdi = Storage_interface.Vdi.string_of + +let s_of_vm = Storage_interface.Vm.string_of + +let export_nbd_proxy ~remote_url ~mirror_vm ~sr ~vdi ~dp ~verify_dest = + D.debug "%s spawning exporting nbd proxy" __FUNCTION__ ; + let path = + Printf.sprintf "/var/run/nbdproxy/export/%s" (Vm.string_of mirror_vm) + in + let proxy_srv = Fecomms.open_unix_domain_sock_server path in + try + let uri = + Printf.sprintf "/services/SM/nbdproxy/import/%s/%s/%s/%s" + (Vm.string_of mirror_vm) (Sr.string_of sr) (Vdi.string_of vdi) dp + in + + let dest_url = Http.Url.set_path (Http.Url.of_string remote_url) uri in + D.debug "%s now waiting for connection at %s" __FUNCTION__ path ; + let nbd_client, _addr = Unix.accept proxy_srv in + D.debug "%s connection accepted" __FUNCTION__ ; + let request = + Http.Request.make + ~query:(Http.Url.get_query_params dest_url) + ~version:"1.0" ~user_agent:"export_nbd_proxy" Http.Put uri + in + D.debug "%s making request to dest %s" __FUNCTION__ + (Http.Url.to_string dest_url) ; + let verify_cert = if verify_dest then Stunnel_client.pool () else None in + let transport = Xmlrpc_client.transport_of_url ~verify_cert dest_url in + with_transport ~stunnel_wait_disconnect:false transport + (with_http request (fun (_response, s) -> + D.debug "%s starting proxy" __FUNCTION__ ; + Unixext.proxy (Unix.dup s) (Unix.dup nbd_client) + ) + ) ; + Unix.close proxy_srv + with e -> + D.debug "%s did not get connection due to %s, closing" __FUNCTION__ + (Printexc.to_string e) ; + Unix.close proxy_srv ; + raise e + +let mirror_wait ~dbg ~sr ~vdi ~vm ~mirror_id mirror_key = + let rec mirror_wait_rec key = + let {failed; complete; progress} : Mirror.status = + Local.DATA.stat dbg sr vdi vm key + in + if complete then ( + Option.fold ~none:() + ~some:(fun p -> D.info "%s progress is %f" __FUNCTION__ p) + progress ; + D.info "%s qemu mirror %s completed" mirror_id __FUNCTION__ + ) else if failed then ( + Option.iter + (fun (snd_state : State.Send_state.t) -> snd_state.failed <- true) + (State.find_active_local_mirror mirror_id) ; + D.info "%s qemu mirror %s failed" mirror_id __FUNCTION__ ; + State.find_active_local_mirror mirror_id + |> Option.iter (fun (s : State.Send_state.t) -> s.failed <- true) ; + Updates.add (Dynamic.Mirror mirror_id) updates ; + raise + (Storage_interface.Storage_error + (Migration_mirror_failure "Mirror failed during syncing") + ) + ) else ( + Option.fold ~none:() + ~some:(fun p -> D.info "%s progress is %f" __FUNCTION__ p) + progress ; + mirror_wait_rec key + ) + in + + match mirror_key with + | Storage_interface.Mirror.CopyV1 _ -> + () + | Storage_interface.Mirror.MirrorV1 _ -> + D.debug "%s waiting for mirroring to be done" __FUNCTION__ ; + mirror_wait_rec mirror_key + module MIRROR : SMAPIv2_MIRROR = struct type context = unit - let u x = raise Storage_interface.(Storage_error (Errors.Unimplemented x)) + let send_start _ctx ~dbg ~task_id:_ ~dp ~sr ~vdi ~mirror_vm ~mirror_id + ~local_vdi:_ ~copy_vm:_ ~live_vm ~url ~remote_mirror ~dest_sr ~verify_dest + = + D.debug + "%s dbg: %s dp: %s sr: %s vdi:%s mirror_vm:%s mirror_id: %s live_vm: %s \ + url:%s dest_sr:%s verify_dest:%B" + __FUNCTION__ dbg dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm mirror_vm) + mirror_id (s_of_vm live_vm) url (s_of_sr dest_sr) verify_dest ; + ignore (Local.VDI.attach3 dbg dp sr vdi (Vm.of_string "0") true) ; + (* TODO we are not activating the VDI here because SMAPIv3 does not support + activating the VDI again on dom 0 when it is already activated on the live_vm. + This means that if the VM shutsdown while SXM is in progress the + mirroring for SMAPIv3 will fail.*) + let nbd_proxy_path = + Printf.sprintf "/var/run/nbdproxy/export/%s" (Vm.string_of mirror_vm) + in + match remote_mirror with + | Mirror.Vhd_mirror _ -> + raise + (Storage_error + (Migration_preparation_failure + "Incorrect remote mirror format for SMAPIv3" + ) + ) + | Mirror.SMAPIv3_mirror {nbd_export; mirror_datapath; mirror_vdi} -> ( + try + let nbd_uri = + Uri.make ~scheme:"nbd+unix" ~host:"" ~path:nbd_export + ~query:[("socket", [nbd_proxy_path])] + () + |> Uri.to_string + in + let _ : Thread.t = + Thread.create + (fun () -> + export_nbd_proxy ~remote_url:url ~mirror_vm ~sr:dest_sr + ~vdi:mirror_vdi.vdi ~dp:mirror_datapath ~verify_dest + ) + () + in + + D.info "%s nbd_proxy_path: %s nbd_url %s" __FUNCTION__ nbd_proxy_path + nbd_uri ; + let mk = Local.DATA.mirror dbg sr vdi live_vm nbd_uri in + + D.debug "%s Updating active local mirrors: id=%s" __FUNCTION__ mirror_id ; + let alm = + State.Send_state. + { + url + ; dest_sr + ; remote_info= + Some + {dp= mirror_datapath; vdi= mirror_vdi.vdi; url; verify_dest} + ; local_dp= dp + ; tapdev= None + ; failed= false + ; watchdog= None + ; vdi + ; live_vm + ; mirror_key= Some mk + } + in + State.add mirror_id (State.Send_op alm) ; + D.debug "%s Updated mirror_id %s in the active local mirror" + __FUNCTION__ mirror_id ; + mirror_wait ~dbg ~sr ~vdi ~vm:live_vm ~mirror_id mk + with e -> + D.error "%s caught exception during mirror: %s" __FUNCTION__ + (Printexc.to_string e) ; + raise + (Storage_interface.Storage_error + (Migration_mirror_failure (Printexc.to_string e)) + ) + ) + + let receive_start _ctx ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ = + Storage_interface.unimplemented __FUNCTION__ + + 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 ~similar:_ ~vm ~url + ~verify_dest = + D.debug "%s dbg: %s sr: %s vdi: %s id: %s vm: %s url: %s verify_dest: %B" + __FUNCTION__ dbg (s_of_sr sr) + (string_of_vdi_info vdi_info) + mirror_id (s_of_vm vm) url verify_dest ; + let module Remote = StorageAPI (Idl.Exn.GenClient (struct + let rpc = + Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" + (Storage_utils.connection_args_of_uri ~verify_dest url) + end)) in + let on_fail : (unit -> unit) list ref = ref [] in + try + (* We drop cbt_metadata VDIs that do not have any actual data *) + let (vdi_info : vdi_info) = + {vdi_info with sm_config= [("base_mirror", mirror_id)]} + in + let leaf_dp = Remote.DP.create dbg Uuidx.(to_string (make ())) in + let leaf = Remote.VDI.create dbg sr vdi_info in + D.info "Created leaf VDI for mirror receive: %s" (string_of_vdi_info leaf) ; + on_fail := (fun () -> Remote.VDI.destroy dbg sr leaf.vdi) :: !on_fail ; + let backend = Remote.VDI.attach3 dbg leaf_dp sr leaf.vdi vm true in + let nbd_export = + match nbd_export_of_attach_info backend with + | None -> + raise + (Storage_error + (Migration_preparation_failure "Cannot parse nbd uri") + ) + | Some export -> + export + in + D.debug "%s activating dp %s sr: %s vdi: %s vm: %s" __FUNCTION__ leaf_dp + (s_of_sr sr) (s_of_vdi leaf.vdi) (s_of_vm vm) ; + Remote.VDI.activate3 dbg leaf_dp sr leaf.vdi vm ; + let qcow2_res = + {Mirror.mirror_vdi= leaf; mirror_datapath= leaf_dp; nbd_export} + in + let remote_mirror = Mirror.SMAPIv3_mirror qcow2_res in + D.debug + "%s updating receiving state lcoally to id: %s vm: %s vdi_info: %s" + __FUNCTION__ mirror_id (s_of_vm vm) + (string_of_vdi_info vdi_info) ; + State.add mirror_id + State.( + Recv_op + Receive_state. + { + sr + ; leaf_vdi= qcow2_res.mirror_vdi.vdi + ; leaf_dp= qcow2_res.mirror_datapath + ; remote_vdi= vdi_info.vdi + ; mirror_vm= vm + ; dummy_vdi= + Vdi.of_string "dummy" + (* No dummy_vdi is needed when migrating from SMAPIv3 SRs, having a + "dummy" VDI here is fine as cleanup code for SMAPIv3 will not + access dummy_vdi, and all the clean up functions will ignore + exceptions when trying to clean up the dummy VDIs even if they + do access dummy_vdi. The same applies to parent_vdi *) + ; parent_vdi= Vdi.of_string "dummy" + ; url + ; verify_dest + } + ) ; + remote_mirror + with e -> + List.iter + (fun op -> + try op () + with e -> + D.warn "Caught exception in on_fail: %s performing cleaning up" + (Printexc.to_string e) + ) + !on_fail ; + raise e + + let receive_finalize _ctx ~dbg:_ ~id:_ = + Storage_interface.unimplemented __FUNCTION__ + + let receive_finalize2 _ctx ~dbg:_ ~id:_ = + Storage_interface.unimplemented __FUNCTION__ - let send_start _ctx = u __FUNCTION__ + let receive_finalize3 _ctx ~dbg ~mirror_id ~sr ~url ~verify_dest = + D.debug "%s dbg:%s id: %s sr: %s url: %s verify_dest: %B" __FUNCTION__ dbg + mirror_id (s_of_sr sr) url verify_dest ; + let (module Remote) = + Storage_migrate_helper.get_remote_backend url verify_dest + in + let open State.Receive_state in + let recv_state = State.find_active_receive_mirror mirror_id in + Option.iter + (fun r -> + Remote.DP.destroy2 dbg r.leaf_dp r.sr r.leaf_vdi r.mirror_vm false ; + Remote.VDI.remove_from_sm_config dbg r.sr r.leaf_vdi "base_mirror" + ) + recv_state ; + State.remove_receive_mirror mirror_id - let receive_start _ctx = u __FUNCTION__ + let receive_cancel _ctx ~dbg:_ ~id:_ = + Storage_interface.unimplemented __FUNCTION__ - let receive_start2 _ctx = u __FUNCTION__ + let list _ctx = Storage_interface.unimplemented __FUNCTION__ - let receive_finalize _ctx = u __FUNCTION__ + let stat _ctx = Storage_interface.unimplemented __FUNCTION__ - let receive_finalize2 _ctx = u __FUNCTION__ + let receive_cancel2 _ctx ~dbg ~mirror_id ~url ~verify_dest = + D.debug "%s dbg:%s mirror_id:%s url:%s verify_dest:%B" __FUNCTION__ dbg + mirror_id url verify_dest ; + let (module Remote) = + Storage_migrate_helper.get_remote_backend url verify_dest + in + let receive_state = State.find_active_receive_mirror mirror_id in + let open State.Receive_state in + Option.iter + (fun r -> + D.log_and_ignore_exn (fun () -> Remote.DP.destroy dbg r.leaf_dp false) ; + D.log_and_ignore_exn (fun () -> Remote.VDI.destroy dbg r.sr r.leaf_vdi) + ) + receive_state ; + State.remove_receive_mirror mirror_id - let receive_cancel _ctx = u __FUNCTION__ + let has_mirror_failed _ctx ~dbg ~mirror_id ~sr = + match State.find_active_local_mirror mirror_id with + | Some ({mirror_key= Some mk; vdi; live_vm; _} : State.Send_state.t) -> + let {failed; _} : Mirror.status = + Local.DATA.stat dbg sr vdi live_vm mk + in + failed + | _ -> + false - let receive_cancel2 _ctx = u __FUNCTION__ + (* TODO currently we make the pre_deactivate_hook for SMAPIv3 a noop while for + SMAPIv1 it will do a final check of the state of the mirror and report error + if there is a mirror failure. We leave this for SMAPIv3 because the Data.stat + call, which checks for the state of the mirror stops working once the domain + has been paused, which happens before VDI.deactivate, hence we cannot do this check in + pre_deactivate_hook. Instead we work around this by doing mirror check in mirror_wait + as we repeatedly poll the state of the mirror job. In the future we might + want to invent a different hook that can be called to do a final check just + before the VM is paused. *) + let pre_deactivate_hook _ctx ~dbg ~dp ~sr ~vdi = + D.debug "%s dbg: %s dp: %s sr: %s vdi: %s" __FUNCTION__ dbg dp (s_of_sr sr) + (s_of_vdi vdi) end diff --git a/ocaml/xapi/storage_utils.ml b/ocaml/xapi/storage_utils.ml index 8c2398619f..220ece356e 100644 --- a/ocaml/xapi/storage_utils.ml +++ b/ocaml/xapi/storage_utils.ml @@ -72,7 +72,7 @@ let localhost_connection_args () : connection_args = let url = Http.Url. ( Http {host= "127.0.0.1"; auth= None; port= None; ssl= false} - , {uri= Constants.sm_uri; query_params= []} + , {path= Constants.sm_uri; query_params= []} ) in @@ -90,7 +90,7 @@ let intra_pool_connection_args_of_ip ip : connection_args = ; port= None ; ssl= !Xapi_globs.migration_https_only } - , {uri= Constants.sm_uri; query_params= []} + , {path= Constants.sm_uri; query_params= []} ) in diff --git a/ocaml/xapi/stream_vdi.ml b/ocaml/xapi/stream_vdi.ml index 477e84cc82..84765aeaf7 100644 --- a/ocaml/xapi/stream_vdi.ml +++ b/ocaml/xapi/stream_vdi.ml @@ -295,13 +295,9 @@ let send_all refresh_session ofd ~__context rpc session_id in Unixext.really_read ifd buffer 0 this_chunk ; if - (not - (Zerocheck.is_all_zeros - (Bytes.unsafe_to_string buffer) - this_chunk - ) - ) - || first_or_last + first_or_last + || not + (Zerocheck.is_all_zeros (Bytes.unsafe_to_string buffer)) then ( last_transmission_time := now ; write_block ~__context filename buffer ofd this_chunk diff --git a/ocaml/xapi/sync_networking.ml b/ocaml/xapi/sync_networking.ml index 6046a14782..7c8e2bc7d8 100644 --- a/ocaml/xapi/sync_networking.ml +++ b/ocaml/xapi/sync_networking.ml @@ -54,6 +54,20 @@ let fix_bonds ~__context () = in List.iter (fun bond -> Xapi_bond.fix_bond ~__context ~bond) my_bonds +let get_my_physical_pifs_with_position ~__context = + let me = !Xapi_globs.localhost_ref in + Db.PIF.get_records_where ~__context + ~expr: + (And + ( Eq (Field "host", Literal (Ref.string_of me)) + , Eq (Field "physical", Literal "true") + ) + ) + |> List.filter_map (fun (pif_ref, pif_rec) -> + Xapi_pif_helpers.get_pif_position ~__context ~pif_rec + |> Option.map (fun position -> (pif_ref, pif_rec, position)) + ) + (** Copy Bonds from master *) let copy_bonds_from_master ~__context () = (* if slave: then inherit network config (bonds and vlans) from master (if we don't already have them) *) @@ -84,26 +98,21 @@ let copy_bonds_from_master ~__context () = ) ) in - let my_phy_pifs = - Db.PIF.get_records_where ~__context - ~expr: - (And - ( Eq (Field "host", Literal (Ref.string_of me)) - , Eq (Field "physical", Literal "true") - ) - ) + let my_physical_pifs_with_position = + get_my_physical_pifs_with_position ~__context in (* Consider Bonds *) debug "Resynchronising bonds" ; let maybe_create_bond_for_me bond = let network = Db.PIF.get_network ~__context ~self:bond.API.bond_master in - let slaves_to_mac_and_device_map = - List.map + let slaves_to_mac_device_and_position_map = + List.filter_map (fun self -> - ( self - , Db.PIF.get_MAC ~__context ~self - , Db.PIF.get_device ~__context ~self - ) + let pif_rec = Db.PIF.get_record ~__context ~self in + Xapi_pif_helpers.get_pif_position ~__context ~pif_rec + |> Option.map (fun position -> + (self, pif_rec.API.pIF_MAC, pif_rec.API.pIF_device, position) + ) ) bond.API.bond_slaves in @@ -119,50 +128,55 @@ let copy_bonds_from_master ~__context () = let master_slaves_with_same_mac_as_bond (* expecting a list of at most 1 here *) = List.filter - (fun (_, mac, _) -> mac = master_bond_mac) - slaves_to_mac_and_device_map + (fun (_, mac, _, _) -> mac = master_bond_mac) + slaves_to_mac_device_and_position_map in (* This tells us the device that the master used to inherit the bond's MAC address * (if indeed that is what it did; we set it to None if we think it didn't do this) *) - let device_of_primary_slave = + let position_of_primary_slave = match master_slaves_with_same_mac_as_bond with | [] -> None - | [(_, _, device)] -> - debug "Master bond has MAC address derived from %s" device ; + | [(_, _, device, position)] -> + debug "Master bond has MAC address derived from %s, position %d" + device position ; (* found single slave with mac matching bond master => * this was one that we inherited mac from *) - Some device + Some position | _ -> None in (* Look at the master's slaves and find the corresponding slave PIFs. Note that the slave * might not have the necessary devices: in this case we'll try to make partial bonds *) - let slave_devices = - List.map (fun (_, _, device) -> device) slaves_to_mac_and_device_map + let slave_positions = + List.map + (fun (_, _, _, position) -> position) + slaves_to_mac_device_and_position_map in - let my_slave_pifs = + let my_slave_pifs_with_position = List.filter - (fun (_, pif) -> List.mem pif.API.pIF_device slave_devices) - my_phy_pifs + (fun (_, _, position) -> List.mem position slave_positions) + my_physical_pifs_with_position + in + let my_slave_pif_refs = + List.map (fun (pif_ref, _, _) -> pif_ref) my_slave_pifs_with_position in - let my_slave_pif_refs = List.map fst my_slave_pifs in (* Do I have a pif that I should treat as a primary pif - * i.e. the one to inherit the MAC address from on my bond create? *) let my_primary_slave = - match device_of_primary_slave with + match position_of_primary_slave with | None -> None (* don't care cos we couldn't even figure out who master's primary slave was *) | Some master_primary -> ( match List.filter - (fun (_, pif) -> pif.API.pIF_device = master_primary) - my_slave_pifs + (fun (_, _, position) -> position = master_primary) + my_slave_pifs_with_position with | [] -> None - | [(pifref, _)] -> + | [(pifref, _, _)] -> debug "I have found a PIF to use as primary bond slave (will inherit \ MAC address of bond from this PIF)." ; @@ -185,7 +199,7 @@ let copy_bonds_from_master ~__context () = in match ( List.filter (fun (_, pif) -> pif.API.pIF_network = network) my_bond_pifs - , my_slave_pifs + , my_slave_pifs_with_position ) with | [], [] -> @@ -266,6 +280,7 @@ let copy_tunnels_from_master ~__context () = let copy_network_sriovs_from_master ~__context () = let me = !Xapi_globs.localhost_ref in let master = Helpers.get_master ~__context in + let ( let& ) o f = Option.iter f o in let master_sriov_pifs = Db.PIF.get_records_where ~__context ~expr: @@ -284,14 +299,8 @@ let copy_network_sriovs_from_master ~__context () = ) ) in - let my_physical_pifs = - Db.PIF.get_records_where ~__context - ~expr: - (And - ( Eq (Field "host", Literal (Ref.string_of me)) - , Eq (Field "physical", Literal "true") - ) - ) + let my_physical_pifs_with_position = + get_my_physical_pifs_with_position ~__context in debug "Resynchronising network-sriovs" ; let maybe_create_sriov_for_me (_, master_pif_rec) = @@ -302,20 +311,34 @@ let copy_network_sriovs_from_master ~__context () = my_sriov_pifs in if existing_pif = [] then - let device = master_pif_rec.API.pIF_device in + let& master_sriov_physical_pif = + match + Xapi_pif_helpers.get_pif_topo ~__context ~pif_rec:master_pif_rec + with + | Network_sriov_logical _ :: Physical physical_pif :: _ -> + Some physical_pif + | _ -> + None + in + let& position = + Xapi_pif_helpers.get_pif_position ~__context + ~pif_rec:master_sriov_physical_pif + in let pifs = List.filter - (fun (_, pif_rec) -> pif_rec.API.pIF_device = device) - my_physical_pifs + (fun (_, _, pos) -> pos = position) + my_physical_pifs_with_position in match pifs with | [] -> info "Cannot sync network sriov because cannot find PIF whose device \ - name is %s" - device - | (pif_ref, pif_rec) :: _ -> ( + position is %d" + position + | (pif_ref, pif_rec, _) :: _ -> ( try + debug "Syncing network sriov for PIF %s position %d" + pif_rec.API.pIF_uuid position ; Xapi_network_sriov.create ~__context ~pif:pif_ref ~network:sriov_network |> ignore diff --git a/ocaml/xapi/system_domains.ml b/ocaml/xapi/system_domains.ml index 0453c20556..c610424aee 100644 --- a/ocaml/xapi/system_domains.ml +++ b/ocaml/xapi/system_domains.ml @@ -148,36 +148,6 @@ let is_in_use ~__context ~self = else false -(* [wait_for ?timeout f] returns true if [f()] (called at 1Hz) returns true within - the [timeout] period and false otherwise *) -let wait_for ?(timeout = 120.) f = - let start = Unix.gettimeofday () in - let finished = ref false in - let success = ref false in - while not !finished do - let remaining = timeout -. (Unix.gettimeofday () -. start) in - if remaining < 0. then - finished := true - else - try - if f () then ( - success := true ; - finished := true - ) else - Thread.delay 1. - with _ -> Thread.delay 1. - done ; - !success - -let pingable ip () = - try - let (_ : string * string) = - Forkhelpers.execute_command_get_output "/bin/ping" - ["-c"; "1"; "-w"; "1"; ip] - in - true - with _ -> false - let queryable ~__context transport () = let open Xmlrpc_client in let tracing = Context.set_client_span __context in @@ -197,47 +167,6 @@ let queryable ~__context transport () = (Printexc.to_string e) ; false -let ip_of ~__context driver = - (* Find the VIF on the Host internal management network *) - let vifs = Db.VM.get_VIFs ~__context ~self:driver in - let hin = Helpers.get_host_internal_management_network ~__context in - let ip = - let vif = - try - List.find - (fun vif -> Db.VIF.get_network ~__context ~self:vif = hin) - vifs - with Not_found -> - failwith - (Printf.sprintf - "driver domain %s has no VIF on host internal management network" - (Ref.string_of driver) - ) - in - match Xapi_udhcpd.get_ip ~__context vif with - | Some (a, b, c, d) -> - Printf.sprintf "%d.%d.%d.%d" a b c d - | None -> - failwith - (Printf.sprintf - "driver domain %s has no IP on the host internal management \ - network" - (Ref.string_of driver) - ) - in - info "driver domain uuid:%s ip:%s" (Db.VM.get_uuid ~__context ~self:driver) ip ; - if not (wait_for (pingable ip)) then - failwith - (Printf.sprintf "driver domain %s is not responding to IP ping" - (Ref.string_of driver) - ) ; - if not (wait_for (queryable ~__context (Xmlrpc_client.TCP (ip, 80)))) then - failwith - (Printf.sprintf "driver domain %s is not responding to XMLRPC query" - (Ref.string_of driver) - ) ; - ip - type service = {uuid: string; ty: string; instance: string; url: string} [@@deriving rpc] diff --git a/ocaml/xapi/system_domains.mli b/ocaml/xapi/system_domains.mli index 36881ad865..33df12a6f5 100644 --- a/ocaml/xapi/system_domains.mli +++ b/ocaml/xapi/system_domains.mli @@ -51,9 +51,6 @@ val is_in_use : __context:Context.t -> self:API.ref_VM -> bool val queryable : __context:Context.t -> Xmlrpc_client.transport -> unit -> bool (** [queryable ip port ()] returns true if [ip]:[port] responsds to an XMLRPC query *) -val ip_of : __context:Context.t -> API.ref_VM -> string -(** [ip_of __context vm] returns the IP of the given VM on the internal management network *) - (** One of many service running in a driver domain *) type service = {uuid: string; ty: string; instance: string; url: string} diff --git a/ocaml/xapi/system_status.ml b/ocaml/xapi/system_status.ml index bcbd0298d9..189fd09c83 100644 --- a/ocaml/xapi/system_status.ml +++ b/ocaml/xapi/system_status.ml @@ -11,120 +11,173 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -open Http -open Printf -open Xapi_stdext_pervasives.Pervasiveext -open Xapi_stdext_std.Xstringext -open Forkhelpers -let content_type = "application/data" +module Request = Http.Request -let xen_bugtool = "/usr/sbin/xen-bugtool" +let finally = Xapi_stdext_pervasives.Pervasiveext.finally let task_label = "Retrieving system status" -let module_key = "system_status" +module L = Debug.Make (struct let name = __MODULE__ end) -module D = Debug.Make (struct let name = module_key end) +module Output = struct + (** The output formats of xen-bugtool *) + type t = Tar | TarBz2 | Zip -open D + let of_string = function + | "tar" -> + Some Tar + | "tar.bz2" -> + Some TarBz2 + | "zip" -> + Some Zip + | _ -> + None -let get_capabilities () = - let cmd = sprintf "%s --capabilities" xen_bugtool in - Helpers.get_process_output cmd + let to_extension = function + | Tar -> + "tar" + | TarBz2 -> + "tar.bz2" + | Zip -> + "zip" -(* This fn outputs xen-bugtool straight to the socket, only - for tar output. It should work on embedded edition *) -let send_via_fd __context s entries output = - let s_uuid = Uuidx.to_string (Uuidx.make ()) in - let params = + let to_mime = function + | Tar -> + "appliation/x-tar" + | TarBz2 -> + "application/x-bzip2" + | Zip -> + "application/zip" +end + +module Bugtool = struct + let path = "/usr/sbin/xen-bugtool" + + let params_cp ~entries ~extension = [ - sprintf "--entries=%s" entries + Printf.sprintf "--entries=%s" entries ; "--silent" ; "--yestoall" - ; sprintf "--output=%s" output - ; "--outfd=" ^ s_uuid + ; Printf.sprintf "--output=%s" extension ] - in - let cmd = sprintf "%s %s" xen_bugtool (String.concat " " params) in - debug "running %s" cmd ; - try - let headers = - Http.http_200_ok ~keep_alive:false ~version:"1.0" () - @ [ - "Server: " ^ Xapi_version.xapi_user_agent - ; Http.Hdr.content_type ^ ": " ^ content_type - ; "Content-Disposition: attachment; filename=\"system_status.tgz\"" - ] - in - Http_svr.headers s headers ; - let result = - with_logfile_fd "get-system-status" (fun log_fd -> - let pid = - safe_close_and_exec None (Some log_fd) (Some log_fd) - [(s_uuid, s)] - xen_bugtool params - in - waitpid_fail_if_bad_exit pid - ) + + let cmd_capabilities = Printf.sprintf "%s --capabilities" path + + let params_fd ~entries ~extension ~uuid = + let params = + params_cp ~entries ~extension @ [Printf.sprintf "--outfd=%s" uuid] in - match result with - | Success _ -> - debug "xen-bugtool exited successfully" - | Failure (log, exn) -> - debug "xen-bugtool failed with output: %s" log ; - raise exn - with e -> - let msg = "xen-bugtool failed: " ^ Printexc.to_string e in - error "%s" msg ; - raise - (Api_errors.Server_error (Api_errors.system_status_retrieval_failed, [msg]) - ) + let cmd = String.concat " " (path :: params) in + L.debug "%s: running %s" __FUNCTION__ cmd ; + params + + let cmd_cp ~entries ~extension = + let params = params_cp ~entries ~extension in + let cmd = String.concat " " (path :: params) in + L.debug "%s: running %s" __FUNCTION__ cmd ; + cmd + + let filename __context extension = + let timestamp = Ptime_clock.now () |> Ptime.to_rfc3339 ~tz_offset_s:0 in + let self = Helpers.get_localhost ~__context in + let hostname = Db.Host.get_hostname ~__context ~self in + Printf.sprintf "system_status-%s-%s.%s" timestamp hostname extension +end + +let get_capabilities () = Helpers.get_process_output Bugtool.cmd_capabilities + +(* This fn outputs xen-bugtool straight to the socket, only + for tar output. It should work on embedded edition *) +let send_via_fd __context s entries output = + let uuid = Uuidx.to_string (Uuidx.make ()) in + let extension = Output.to_extension output in + let content_type = Output.to_mime output in + let filename = Bugtool.filename __context extension in + let params = Bugtool.params_fd ~entries ~extension ~uuid in + let headers = + Http.http_200_ok ~keep_alive:false ~version:"1.0" () + @ [ + Printf.sprintf "Server: %s" Xapi_version.xapi_user_agent + ; Printf.sprintf "%s: %s" Http.Hdr.content_type content_type + ; Printf.sprintf {|%s: attachment; filename="%s"|} + Http.Hdr.content_disposition filename + ] + in + Http_svr.headers s headers ; + let result = + Forkhelpers.with_logfile_fd "get-system-status" (fun log_fd -> + let pid = + Forkhelpers.safe_close_and_exec None (Some log_fd) (Some log_fd) + [(uuid, s)] + Bugtool.path params + in + Forkhelpers.waitpid_fail_if_bad_exit pid + ) + in + match result with Success _ -> Ok () | Failure (log, exn) -> Error (log, exn) (* This fn outputs xen-bugtool into a file and then write the file out to the socket, to deal with zipped bugtool outputs It will not work on embedded edition *) let send_via_cp __context s entries output = - let cmd = - sprintf "%s --entries=%s --silent --yestoall --output=%s" xen_bugtool - entries output - in - let () = debug "running %s" cmd in + let extension = Output.to_extension output in + let content_type = Output.to_mime output in + let cmd = Bugtool.cmd_cp ~entries ~extension in try - let filename = String.rtrim (Helpers.get_process_output cmd) in + let filepath = String.trim (Helpers.get_process_output cmd) in + let filename = Bugtool.filename __context extension in let hsts_time = !Xapi_globs.hsts_max_age in finally (fun () -> - debug "bugball path: %s" filename ; - Http_svr.response_file ~mime_content_type:content_type ~hsts_time s - filename + Http_svr.response_file ~mime_content_type:content_type ~hsts_time + ~download_name:filename s filepath ) (fun () -> Helpers.log_exn_continue "deleting xen-bugtool output" Unix.unlink - filename - ) - with e -> - let msg = "xen-bugtool failed: " ^ ExnHelper.string_of_exn e in - error "%s" msg ; - raise - (Api_errors.Server_error (Api_errors.system_status_retrieval_failed, [msg]) - ) + filepath + ) ; + Ok () + with e -> Error ("(Not captured)", e) + +let with_api_errors f ctx s entries output = + match f ctx s entries output with + | Ok () -> + () + | Error (log, exn) -> + L.debug "xen-bugtool failed with output: %s" log ; + let msg = "xen-bugtool failed: " ^ Printexc.to_string exn in + raise Api_errors.(Server_error (system_status_retrieval_failed, [msg])) + +let send_capabilities req s = + let content = get_capabilities () in + let xml_type = "application/xml" in + let hdrs = + [ + ("Server", Xapi_version.xapi_user_agent); (Http.Hdr.content_type, xml_type) + ] + in + Http_svr.response_str req ~hdrs s content let handler (req : Request.t) s _ = - debug "In system status http handler..." ; req.Request.close <- true ; - let get_param s = try List.assoc s req.Request.query with _ -> "" in - let entries = get_param "entries" in - let output = get_param "output" in - let () = debug "session_id: %s" (get_param "session_id") in - Xapi_http.with_context task_label req s (fun __context -> - if Helpers.on_oem ~__context && output <> "tar" then - raise - (Api_errors.Server_error - (Api_errors.system_status_must_use_tar_on_oem, []) - ) - else if output = "tar" then - send_via_fd __context s entries output - else - send_via_cp __context s entries output - ) + let get_param s = List.assoc_opt s req.Request.query in + let list_capabilies = Option.is_some (get_param "list") in + let entries = Option.value ~default:"" (get_param "entries") in + let output = Option.bind (get_param "output") Output.of_string in + + let send_list () = send_capabilities req s in + let send_file () = + Xapi_http.with_context task_label req s @@ fun __context -> + match + (Helpers.on_oem ~__context, Option.value ~default:Output.Tar output) + with + | _, (Output.Tar as output) -> + with_api_errors send_via_fd __context s entries output + | false, output -> + with_api_errors send_via_cp __context s entries output + | true, _ -> + raise Api_errors.(Server_error (system_status_must_use_tar_on_oem, [])) + in + + if list_capabilies then send_list () else send_file () diff --git a/ocaml/xapi/system_status.mli b/ocaml/xapi/system_status.mli new file mode 100644 index 0000000000..d0c5f2bb3d --- /dev/null +++ b/ocaml/xapi/system_status.mli @@ -0,0 +1,3 @@ +val get_capabilities : unit -> string + +val handler : Http.Request.t -> Unix.file_descr -> 'a -> unit diff --git a/ocaml/xapi/vm_evacuation.ml b/ocaml/xapi/vm_evacuation.ml index 11a7560af8..080da5a01e 100644 --- a/ocaml/xapi/vm_evacuation.ml +++ b/ocaml/xapi/vm_evacuation.ml @@ -117,7 +117,7 @@ let ensure_no_vms ~__context ~rpc ~session_id ~evacuate_timeout = let shutdown vms = log_and_ignore_exn (fun () -> clean_shutdown vms) ; (* We can unplug the PBD if a VM is suspended or halted, but not if - * it is running or paused, i.e. "live" *) + * it is running or paused, i.e. "live" *) vms |> List.filter (fun self -> Xapi_vm_lifecycle_helpers.is_live ~__context ~self diff --git a/ocaml/xapi/vm_sysprep.ml b/ocaml/xapi/vm_sysprep.ml new file mode 100644 index 0000000000..abc9a2f274 --- /dev/null +++ b/ocaml/xapi/vm_sysprep.ml @@ -0,0 +1,299 @@ +(* + * 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 = __MODULE__ end) + +open D +open Client +open Xapi_stdext_unix + +let ( // ) = Filename.concat + +let finally = Xapi_stdext_pervasives.Pervasiveext.finally + +let genisoimage = !Xapi_globs.genisoimage_path + +type error = + | API_not_enabled + | Other of string + | VM_CDR_not_found + | VM_CDR_eject + | VM_CDR_insert + | VM_misses_feature + | VM_not_running + | VM_sysprep_timeout + | XML_too_large + +exception Sysprep of error + +let _fail_fmt fmt = Printf.ksprintf (fun msg -> raise (Sysprep (Other msg))) fmt + +let fail error = raise (Sysprep error) + +let internal_error = Helpers.internal_error + +let prng = Random.State.make_self_init () + +let call = Helpers.call_api_functions + +(* A local ISO SR; we create an ISO that holds an unattend.xml file that + is than passed as CD to a VM *) +module SR = struct + let dir = "/var/opt/iso" + + (* We create a deterministic unique name label to protect us against a + user using the same name *) + let name hostname = + let digest str = + Digest.(string str |> to_hex) |> fun hex -> String.sub hex 0 4 + in + Printf.sprintf "SYSPREP-%s-%s" hostname (digest hostname) + + let find_opt ~__context ~label = + let check sr = + match Db.SR.get_record ~__context ~self:sr with + | API.{sR_type= "iso"; _} -> + true + | _ -> + false + in + Db.SR.get_by_name_label ~__context ~label |> List.find_opt check +end + +(** This is called on xapi startup. Opportunity to set up or clean up. + We destroy all VDIs that are unused. *) +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 -> ( + Db.SR.get_VDIs ~__context ~self:sr + |> List.iter @@ fun self -> + match Db.VDI.get_record ~__context ~self with + | API.{vDI_VBDs= []; _} -> + call ~__context @@ fun rpc session_id -> + Client.VDI.destroy ~rpc ~session_id ~self + | _ -> + () + ) + | _ -> + () (* none found or not enabled *) + +(** create a name with a random infix. We need random names for + temporary directories to avoid collisions of concurrent API calls *) +let temp_name prefix suffix = + let rnd = Random.State.bits prng land 0xFFFFFF in + Printf.sprintf "%s%06x%s" prefix rnd suffix + +let temp_dir = Filename.get_temp_dir_name () + +(** [mkdtmp] creates a directory in [dir] and returns its path. If [dir] + does not yet exist it is created. It is a an error if [dir] exists + and is not a directory. *) +let mkdtemp ?(dir = temp_dir) ?(perms = 0o700) prefix suffix = + ( match Sys.file_exists dir with + | true when not (Sys.is_directory dir) -> + internal_error "s: %s is not a directory" __FUNCTION__ dir + | true -> + () + | false -> + Unixext.mkdir_rec dir perms + ) ; + let rec try_upto = function + | n when n < 0 -> + internal_error "%s: can't create directory %S" __FUNCTION__ dir + | n -> ( + let path = Filename.concat dir (temp_name prefix suffix) in + try Sys.mkdir path perms ; path with Sys_error _ -> try_upto (n - 1) + ) + in + try_upto 20 + +(** Crteate a temporary directory, and pass its path to [f]. Once [f] + returns the directory is removed again *) +let with_temp_dir ?(dir = temp_dir) ?(perms = 0o700) prefix suffix f = + let dir = mkdtemp ~dir ~perms prefix suffix in + finally (fun () -> f dir) (fun () -> Unixext.rm_rec dir) + +(** name of the ISO we will use for a VM; this is not a path *) +let iso_basename ~vm_uuid = + let now = Ptime_clock.now () |> Ptime.to_rfc3339 in + Printf.sprintf "sysprep-%s-%s.iso" vm_uuid now + +(** Create an ISO in [SR.dir] with content [unattend]. [SR.dir] is + created if it not already exists. Returns the path of the ISO image *) +let make_iso ~vm_uuid ~unattend = + try + let basename = iso_basename ~vm_uuid in + let iso = SR.dir // basename in + Xapi_stdext_unix.Unixext.mkdir_rec SR.dir 0o755 ; + with_temp_dir ~dir:"/var/tmp/xapi" "sysprep-" "-iso" (fun temp_dir -> + let path = temp_dir // "unattend.xml" in + SecretString.write_to_file path unattend ; + debug "%s: written to %s" __FUNCTION__ path ; + let args = ["-r"; "-J"; "-o"; iso; temp_dir] in + Forkhelpers.execute_command_get_output genisoimage args |> ignore ; + (iso, basename) + ) + with e -> + Backtrace.is_important e ; + let msg = Printexc.to_string e in + Helpers.internal_error "%s failed: %s" __FUNCTION__ msg + +(** create a local ISO SR when necessary and update it such that it + recognises any ISO we added or removed *) +let update_sr ~__context = + let host = Helpers.get_localhost ~__context in + let hostname = Db.Host.get_hostname ~__context ~self:host in + let label = SR.name hostname in + let mib n = Int64.(n * 1024 * 1024 |> of_int) in + let sr = + match SR.find_opt ~__context ~label with + | Some sr -> + sr + | None -> + let device_config = [("location", SR.dir); ("legacy_mode", "true")] in + call ~__context @@ fun rpc session_id -> + Client.SR.create ~rpc ~session_id ~host ~name_label:label ~device_config + ~content_type:"iso" ~_type:"iso" ~name_description:"Sysprep ISOs" + ~shared:false ~sm_config:[] ~physical_size:(mib 512) + in + call ~__context @@ fun rpc session_id -> + Client.SR.scan ~rpc ~session_id ~sr ; + sr + +(** Find the VBD for the CD drive on [vm] *) +let find_cdr_vbd ~__context ~vm = + let vbds = Db.VM.get_VBDs ~__context ~self:vm in + let vbds' = + List.map (fun self -> (self, Db.VBD.get_record ~__context ~self)) vbds + in + let is_cd (_rf, rc) = + let open API in + rc.vBD_type = `CD && rc.vBD_empty + in + let uuid = Db.VM.get_uuid ~__context ~self:vm in + match List.filter is_cd vbds' with + | [] -> + fail VM_CDR_not_found + | [(rf, rc)] -> + debug "%s: for VM %s using VBD %s" __FUNCTION__ uuid rc.API.vBD_uuid ; + rf + | (rf, rc) :: _ -> + debug "%s: for VM %s using VBD %s" __FUNCTION__ uuid rc.API.vBD_uuid ; + warn "%s: for VM %s found additions VBDs" __FUNCTION__ uuid ; + rf + +(** Find the VDI that contains the unattend.xml based on its name. This + should be unique *) +let find_vdi ~__context ~label = + match Db.VDI.get_by_name_label ~__context ~label with + | [] -> + internal_error "%s: can't find VDI for %s" __FUNCTION__ label + | [vdi] -> + vdi + | vdi :: _ -> + warn "%s: more than one VDI with label %s" __FUNCTION__ label ; + vdi + +(* Ejecting the CD/VDI/ISO may fail with a timeout *) +let eject ~rpc ~session_id ~vbd ~iso = + try + Client.VBD.eject ~rpc ~session_id ~vbd ; + Sys.remove iso + with exn -> + Sys.remove iso ; + (* still remove ISO to protect it *) + warn "%s: ejecting CD failed: %s" __FUNCTION__ (Printexc.to_string exn) ; + fail VM_CDR_eject + +(** notify the VM with [domid] to run sysprep and where to find the + file. *) +let trigger ~rpc ~session_id ~domid ~uuid ~timeout ~vbd ~iso = + let open Ezxenstore_core.Xenstore in + let control = Printf.sprintf "/local/domain/%Ld/control/sysprep" domid in + let domain = Printf.sprintf "/local/domain/%Ld" domid in + with_xs (fun xs -> + xs.Xs.write (control // "filename") "D://unattend.xml" ; + xs.Xs.write (control // "vdi-uuid") uuid ; + xs.Xs.write (control // "action") "sysprep" ; + debug "%s: notified domain %Ld" __FUNCTION__ domid ; + try + finally + (fun () -> + (* wait for sysprep to start, then domain to dissapear *) + Ezxenstore_core.Watch.( + wait_for ~xs ~timeout:5.0 + (value_to_become (control // "action") "running") + ) ; + debug "%s: sysprep is running; waiting for sysprep to finish" + __FUNCTION__ ; + Ezxenstore_core.Watch.( + wait_for ~xs ~timeout (key_to_disappear (control // "action")) + ) + ) + (fun () -> eject ~rpc ~session_id ~vbd ~iso) ; + debug "%s waiting for domain to dissapear" __FUNCTION__ ; + Ezxenstore_core.Watch.(wait_for ~xs ~timeout (key_to_disappear domain)) ; + true + with Ezxenstore_core.Watch.Timeout _ -> + debug "%s: sysprep timeout" __FUNCTION__ ; + false + ) + +(* This function is executed on the host where [vm] is running *) +let sysprep ~__context ~vm ~unattend ~timeout = + debug "%s (timeout %f)" __FUNCTION__ timeout ; + if not !Xapi_globs.vm_sysprep_enabled then + fail API_not_enabled ; + let vm_uuid = Db.VM.get_uuid ~__context ~self:vm in + let domid = Db.VM.get_domid ~__context ~self:vm in + let control = Printf.sprintf "/local/domain/%Ld/control" domid in + if domid <= 0L then + fail VM_not_running ; + if SecretString.length unattend > 32 * 1024 then + fail XML_too_large ; + Ezxenstore_core.Xenstore.with_xs (fun xs -> + let open Ezxenstore_core.Xenstore in + match xs.Xs.read (control // "feature-sysprep") with + | "1" -> + debug "%s: VM %s supports sysprep" __FUNCTION__ vm_uuid + | _ -> + debug "%s: VM %s does not support sysprep" __FUNCTION__ vm_uuid ; + fail VM_misses_feature + | exception _ -> + debug "%s: VM %s does not support sysprep" __FUNCTION__ vm_uuid ; + fail VM_misses_feature + ) ; + let iso, label = make_iso ~vm_uuid ~unattend in + debug "%s: created ISO %s" __FUNCTION__ iso ; + let _sr = update_sr ~__context in + let vbd = find_cdr_vbd ~__context ~vm in + let vdi = find_vdi ~__context ~label in + let uuid = Db.VDI.get_uuid ~__context ~self:vdi in + debug "%s: inserting Sysprep VDI for VM %s" __FUNCTION__ vm_uuid ; + call ~__context @@ fun rpc session_id -> + ( try Client.VBD.insert ~rpc ~session_id ~vdi ~vbd + with e -> + debug "%s: failed to insert CD, removing ISO %s: %s" __FUNCTION__ iso + (Printexc.to_string e) ; + Sys.remove iso ; + fail VM_CDR_insert + ) ; + Thread.delay !Xapi_globs.vm_sysprep_wait ; + match trigger ~rpc ~session_id ~domid ~uuid ~timeout ~vbd ~iso with + | true -> + () + | false -> + fail VM_sysprep_timeout diff --git a/ocaml/xapi/vm_sysprep.mli b/ocaml/xapi/vm_sysprep.mli new file mode 100644 index 0000000000..76cdfb7f62 --- /dev/null +++ b/ocaml/xapi/vm_sysprep.mli @@ -0,0 +1,40 @@ +(* + * 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. + *) + +(** error message that may be passed to API clients *) +type error = + | API_not_enabled + | Other of string + | VM_CDR_not_found + | VM_CDR_eject + | VM_CDR_insert + | VM_misses_feature + | VM_not_running + | VM_sysprep_timeout + | XML_too_large + +exception Sysprep of error + +val on_startup : __context:Context.t -> unit +(** clean up on toolstart start up *) + +val sysprep : + __context:Context.t + -> vm:API.ref_VM + -> unattend:SecretString.t + -> timeout:float + -> unit +(** Execute sysprep on [vm] using script [unattend]. This requires + driver support from the VM and is checked. [unattend] must + not exceed 32kb. Raised [Failure] that must be handled, *) diff --git a/ocaml/xapi/workload_balancing.ml b/ocaml/xapi/workload_balancing.ml index 27fa184da8..7108032dbf 100644 --- a/ocaml/xapi/workload_balancing.ml +++ b/ocaml/xapi/workload_balancing.ml @@ -329,8 +329,19 @@ let wlb_request ~__context ~host ~port ~auth ~meth ~params ~handler ~enable_log with | Remote_requests.Timed_out -> raise_timeout timeout - | Http_client.Http_request_rejected _ | Http_client.Http_error _ -> - raise_authentication_failed () + | Http_client.Http_error (code, _) as e -> ( + error "%s: Caught %s when contacting WLB" __FUNCTION__ + (Printexc.to_string e) ; + match code with + | "401" | "403" -> + raise_authentication_failed () + | _ -> + raise_connection_reset () + ) + | Http_client.Http_request_rejected _ as e -> + error "%s: Caught %s when contacting WLB" __FUNCTION__ + (Printexc.to_string e) ; + raise_connection_reset () | Xmlrpc_client.Connection_reset -> raise_connection_reset () | Stunnel.Stunnel_verify_error reason -> diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index f7ac9b546d..785950c384 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -288,12 +288,9 @@ let synchronize_certificates_with_coordinator ~__context = (* Make sure the local database can be read *) let init_local_database () = - ( try - let (_ : string) = Localdb.get Constants.ha_armed in - () - with Localdb.Missing_key _ -> - Localdb.put Constants.ha_armed "false" ; - debug "%s = 'false' (by default)" Constants.ha_armed + if Option.is_none (Localdb.get_bool Constants.ha_armed) then ( + Localdb.put Constants.ha_armed "false" ; + debug "%s = 'false' (by default)" Constants.ha_armed ) ; (* Add the local session check hook *) Session_check.check_local_session_hook := @@ -327,6 +324,31 @@ let server_run_in_emergency_mode () = in wait_to_die () ; exit 0 +let remove_blocked_repositories ~__context () = + try + let blocklist = !Xapi_globs.repository_url_blocklist in + let repos = Db.Repository.get_all ~__context in + let pool = Helpers.get_pool ~__context in + let is_repo_blocked repo = + let binary_url = Db.Repository.get_binary_url ~__context ~self:repo in + let source_url = Db.Repository.get_source_url ~__context ~self:repo in + Repository_helpers.url_matches ~url:binary_url blocklist + || Repository_helpers.url_matches ~url:source_url blocklist + in + let remove_repo repo = + debug "%s Removing repository %s due to it being blocked" __FUNCTION__ + (Ref.string_of repo) ; + try + Xapi_pool.remove_repository ~__context ~self:pool ~value:repo ; + Db.Repository.destroy ~__context ~self:repo + with e -> + debug "%s Failed to remove repository for %s: %s" __FUNCTION__ + (Ref.string_of repo) (Printexc.to_string e) + in + List.filter (fun x -> is_repo_blocked x) repos + |> List.iter (fun x -> remove_repo x) + with e -> error "Exception in %s: %s" __FUNCTION__ (Printexc.to_string e) + let bring_up_management_if ~__context () = try let management_if = @@ -494,13 +516,14 @@ let start_ha () = (** Enable and load the redo log if we are the master, the local-DB flag is set * and HA is disabled *) let start_redo_log () = + let redo_log_enabled () = + Localdb.get_bool Constants.redo_log_enabled |> Option.value ~default:false + in + let ha_armed () = + Localdb.get_bool Constants.ha_armed |> Option.value ~default:false + in try - if - Pool_role.is_master () - && bool_of_string - (Localdb.get_with_default Constants.redo_log_enabled "false") - && not (bool_of_string (Localdb.get Constants.ha_armed)) - then ( + if Pool_role.is_master () && redo_log_enabled () && not (ha_armed ()) then ( debug "Redo log was enabled when shutting down, so restarting it" ; Static_vdis.reattempt_on_boot_attach () ; (* enable the use of the redo log *) @@ -585,7 +608,7 @@ let resynchronise_ha_state () = let pool = Helpers.get_pool ~__context in let pool_ha_enabled = Db.Pool.get_ha_enabled ~__context ~self:pool in let local_ha_enabled = - bool_of_string (Localdb.get Constants.ha_armed) + Localdb.get_bool Constants.ha_armed |> Option.value ~default:false in match (local_ha_enabled, pool_ha_enabled) with | true, true -> @@ -824,7 +847,11 @@ let common_http_handlers () = ; ("get_config_sync", Config_file_sync.config_file_sync_handler) ; ("get_system_status", System_status.handler) ; (Constants.get_vm_rrd, Rrdd_proxy.get_vm_rrd_forwarder) + (* For compatibility with XC < 8460, remove when out of support *) + ; ("get_vm_rrds", Rrdd_proxy.get_vm_rrd_forwarder) ; (Constants.get_host_rrd, Rrdd_proxy.get_host_rrd_forwarder) + (* For compatibility with XC < 8460, remove when out of support *) + ; ("get_host_rrds", Rrdd_proxy.get_host_rrd_forwarder) ; (Constants.get_sr_rrd, Rrdd_proxy.get_sr_rrd_forwarder) ; (Constants.get_rrd_updates, Rrdd_proxy.get_rrd_updates_forwarder) ; (Constants.put_rrd, Rrdd_proxy.put_rrd_forwarder) @@ -836,6 +863,7 @@ let common_http_handlers () = ; ("get_wlb_diagnostics", Wlb_reports.diagnostics_handler) ; ("get_audit_log", Audit_log.handler) ; ("post_root", Api_server.callback false) + ; ("post_RPC2", Api_server.callback false) ; ("post_json", Api_server.callback true) ; ("post_jsonrpc", Api_server.jsoncallback) ; ("post_root_options", Api_server.options_callback) @@ -1115,6 +1143,10 @@ let server_init () = , [Startup.OnlyMaster] , Xapi_db_upgrade.hi_level_db_upgrade_rules ~__context ) + ; ( "removing blocked repositories" + , [Startup.OnlyMaster] + , remove_blocked_repositories ~__context + ) ; ( "bringing up management interface" , [] , bring_up_management_if ~__context @@ -1351,6 +1383,10 @@ let server_init () = , cache_metadata_vdis ) ; ("Stats reporting thread", [], Xapi_stats.start) + ; ( "Remove local ISO SR" + , [Startup.OnThread] + , fun () -> Vm_sysprep.on_startup ~__context + ) ] ; if !debug_dummy_data then Startup.run ~__context @@ -1471,6 +1507,10 @@ let server_init () = Xapi_host.write_uefi_certificates_to_disk ~__context ~host:(Helpers.get_localhost ~__context) ) + ; ( "Update firewalld service status" + , [Startup.NoExnRaising] + , fun () -> Xapi_host.update_firewalld_service_status ~__context + ) ; ( "writing init complete" , [] , fun () -> Helpers.touch_file !Xapi_globs.init_complete diff --git a/ocaml/xapi/xapi_bond.ml b/ocaml/xapi/xapi_bond.ml index 72d762ff19..f0265bd50a 100644 --- a/ocaml/xapi/xapi_bond.ml +++ b/ocaml/xapi/xapi_bond.ml @@ -427,9 +427,9 @@ let create ~__context ~network ~members ~mAC ~mode ~properties = in let disallow_unplug = (* this is always true if one of the PIFs is a cluster_host.PIF *) - List.fold_left - (fun a m -> Db.PIF.get_disallow_unplug ~__context ~self:m || a) - false members + List.exists + (fun m -> Db.PIF.get_disallow_unplug ~__context ~self:m) + members in (* Validate constraints: *) (* 1. Members must not be in a bond already *) diff --git a/ocaml/xapi/xapi_cluster_helpers.ml b/ocaml/xapi/xapi_cluster_helpers.ml index a4d30bceda..1afdefb286 100644 --- a/ocaml/xapi/xapi_cluster_helpers.ml +++ b/ocaml/xapi/xapi_cluster_helpers.ml @@ -24,19 +24,23 @@ let is_allowed_concurrently ~op:_ ~current_ops:_ = false let report_concurrent_operations_error ~current_ops ~ref_str = - let current_ops_str = + let current_ops_ref_str, current_ops_str = let op_to_str = Record_util.cluster_operation_to_string in + let ( >> ) f g x = g (f x) in match current_ops with | [] -> failwith "No concurrent operation to report" - | [(_, cop)] -> - op_to_str cop + | [(op_ref, cop)] -> + (op_ref, op_to_str cop) | l -> - "{" ^ String.concat "," (List.map op_to_str (List.map snd l)) ^ "}" + ( Printf.sprintf "{%s}" (String.concat "," (List.map fst l)) + , Printf.sprintf "{%s}" + (String.concat "," (List.map (snd >> op_to_str) l)) + ) in Some ( Api_errors.other_operation_in_progress - , ["Cluster." ^ current_ops_str; ref_str] + , ["Cluster"; ref_str; current_ops_str; current_ops_ref_str] ) (** Take an internal Cluster record and a proposed operation. Return None iff the operation diff --git a/ocaml/xapi/xapi_cluster_host_helpers.ml b/ocaml/xapi/xapi_cluster_host_helpers.ml index 59e5141da7..abdaa58c28 100644 --- a/ocaml/xapi/xapi_cluster_host_helpers.ml +++ b/ocaml/xapi/xapi_cluster_host_helpers.ml @@ -22,19 +22,23 @@ let is_allowed_concurrently ~op:_ ~current_ops:_ = false let report_concurrent_operations_error ~current_ops ~ref_str = - let current_ops_str = + let current_ops_ref_str, current_ops_str = let op_to_str = Record_util.cluster_host_operation_to_string in + let ( >> ) f g x = g (f x) in match current_ops with | [] -> failwith "No concurrent operation to report" - | [(_, cop)] -> - op_to_str cop + | [(op_ref, cop)] -> + (op_ref, op_to_str cop) | l -> - "{" ^ String.concat "," (List.map op_to_str (List.map snd l)) ^ "}" + ( Printf.sprintf "{%s}" (String.concat "," (List.map fst l)) + , Printf.sprintf "{%s}" + (String.concat "," (List.map (snd >> op_to_str) l)) + ) in Some ( Api_errors.other_operation_in_progress - , ["Cluster_host." ^ current_ops_str; ref_str] + , ["Cluster_host"; ref_str; current_ops_str; current_ops_ref_str] ) (** Take an internal Cluster_host record and a proposed operation. Return None iff the operation diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index c17b5eaf39..cc66b7d012 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -250,10 +250,21 @@ module Daemon = struct | None -> ignore (Helpers.call_script script params) + let maybe_update_firewall ~__context ~status = + match Context.get_test_clusterd_rpc __context with + | Some _ -> + debug "in unit test, not update firewall" + | None -> + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Dlm status + let service = "xapi-clusterd" let enable ~__context = - let port = string_of_int !Xapi_globs.xapi_clusterd_port in debug "Enabling and starting the clustering daemon" ; ( try maybe_call_script ~__context !Xapi_globs.systemctl ["cat"; service] with _ -> @@ -262,9 +273,7 @@ module Daemon = struct raise Api_errors.(Server_error (not_implemented, ["Cluster.create"])) ) ; ( try - maybe_call_script ~__context - !Xapi_globs.firewall_port_config_script - ["open"; port] ; + 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] with _ -> Helpers.internal_error "could not start %s" service @@ -273,18 +282,16 @@ module Daemon = struct debug "Cluster daemon: enabled & started" let disable ~__context = - let port = string_of_int !Xapi_globs.xapi_clusterd_port in debug "Disabling and stopping the clustering daemon" ; Atomic.set enabled false ; maybe_call_script ~__context !Xapi_globs.systemctl ["disable"; service] ; maybe_call_script ~__context !Xapi_globs.systemctl ["stop"; service] ; - maybe_call_script ~__context - !Xapi_globs.firewall_port_config_script - ["close"; port] ; + maybe_update_firewall ~__context ~status:Firewall.Disabled ; debug "Cluster daemon: disabled & stopped" let restart ~__context = debug "Attempting to restart the clustering daemon" ; + maybe_update_firewall ~__context ~status:Firewall.Enabled ; maybe_call_script ~__context !Xapi_globs.systemctl ["restart"; service] ; debug "Cluster daemon: restarted" end @@ -338,7 +345,7 @@ let assert_cluster_host_quorate ~__context ~self = * achieved quorum yet if we have just booted and haven't seen enough hosts. * Do this via an API call rather than reading a field in the database, because the field in the * database could be out of date. - * *) + *) let result = Cluster_client.LocalClient.diagnostics (rpc ~__context) "assert_cluster_host_quorate" diff --git a/ocaml/xapi/xapi_db_upgrade.ml b/ocaml/xapi/xapi_db_upgrade.ml index f410278291..e1f0eba63f 100644 --- a/ocaml/xapi/xapi_db_upgrade.ml +++ b/ocaml/xapi/xapi_db_upgrade.ml @@ -930,7 +930,6 @@ let upgrade_ca_fingerprints = try let* certificate = Xapi_stdext_unix.Unixext.string_of_file filename - |> Cstruct.of_string |> X509.Certificate.decode_pem in let sha1 = diff --git a/ocaml/xapi/xapi_fuse.ml b/ocaml/xapi/xapi_fuse.ml index 48d0737a61..8c2b5b56d3 100644 --- a/ocaml/xapi/xapi_fuse.ml +++ b/ocaml/xapi/xapi_fuse.ml @@ -52,6 +52,8 @@ let light_fuse_and_run ?(fuse_length = !Constants.fuse_time) () = in let new_fuse_length = max 5. (fuse_length -. delay_so_far) in debug "light_fuse_and_run: current RRDs have been saved" ; + ignore + (Thread.create Tracing_export.(flush_and_exit ~max_wait:new_fuse_length) ()) ; ignore (Thread.create (fun () -> diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 8bdeac10d0..5d4fe609b5 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -151,6 +151,10 @@ let _dbv = "dbv" let _db_schema = "db_schema" +let _xapi_build_version = "xapi_build" + +let _xen_version = "xen" + (* When comparing two host versions, always treat a host that has platform_version defined as newer * than any host that does not have platform_version defined. * Substituting this default when a host does not have platform_version defined will be acceptable, @@ -174,6 +178,10 @@ let vdi_tar_export_dir = "vdi" let software_version () = (* In the case of XCP, all product_* fields will be blank. *) + let get_xapi_verstring () = + Printf.sprintf "%d.%d" Xapi_version.xapi_version_major + Xapi_version.xapi_version_minor + in List.filter (fun (_, value) -> value <> "") [ @@ -183,6 +191,7 @@ let software_version () = ; (_platform_name, Xapi_version.platform_name ()) ; (_platform_version, Xapi_version.platform_version ()) ; (_product_brand, Xapi_version.product_brand ()) + ; (_xapi_version, get_xapi_verstring ()) ; (_build_number, Xapi_version.build_number ()) ; (_git_id, Xapi_version.git_id) ; (_hostname, Xapi_version.hostname) @@ -368,6 +377,10 @@ let sync_bios_strings = "sync_bios_strings" let sync_chipset_info = "sync_chipset_info" +let sync_ssh_status = "sync_ssh_status" + +let sync_secure_boot = "sync_secure_boot" + let sync_pci_devices = "sync_pci_devices" let sync_gpus = "sync_gpus" @@ -434,6 +447,10 @@ let xapi_clusterd_port = ref 8896 *) let local_yum_repo_port = ref 8000 +(* The maximum number of start attempts for HA best-effort VMs. Each attempt is + spaced 20 seconds apart. *) +let ha_best_effort_max_retries = ref 2 + (* When a host is known to be shutting down or rebooting, we add it's reference in here. This can be used to force the Host_metrics.live flag to false. *) let hosts_which_are_shutting_down : API.ref_host list ref = ref [] @@ -629,27 +646,11 @@ let auth_type_PAM = "PAM" let event_hook_auth_on_xapi_initialize_succeeded = ref false -(** {2 CPUID feature masking} *) - -let cpu_info_vendor_key = "vendor" - -let cpu_info_features_key = "features" - -let cpu_info_features_pv_key = "features_pv" - -let cpu_info_features_hvm_key = "features_hvm" - -let cpu_info_features_pv_host_key = "features_pv_host" - -let cpu_info_features_hvm_host_key = "features_hvm_host" - (** Metrics *) let metrics_root = "/dev/shm/metrics" -let metrics_prefix_mem_host = "xcp-rrdd-mem_host" - -let metrics_prefix_mem_vms = "xcp-rrdd-mem_vms" +let metrics_prefix_mem = "xcp-rrdd-squeezed" let metrics_prefix_pvs_proxy = "pvsproxy-" @@ -755,7 +756,7 @@ let ha_default_timeout_base = ref 60. let guest_liveness_timeout = ref 300. (** The default time, in µs, in which tapdisk3 will keep polling the vbd ring buffer in expectation for extra requests from the guest *) -let default_vbd3_polling_duration = ref 1000 +let default_vbd3_polling_duration = ref 8000 (** The default % of idle dom0 cpu above which tapdisk3 will keep polling the vbd ring buffer *) let default_vbd3_polling_idle_threshold = ref 50 @@ -817,6 +818,10 @@ let sparse_dd = ref "sparse_dd" let vhd_tool = ref "vhd-tool" +let qcow_to_stdout = ref "/opt/xensource/libexec/qcow2-to-stdout.py" + +let qcow_stream_tool = ref "qcow-stream-tool" + let fence = ref "fence" let host_bugreport_upload = ref "host-bugreport-upload" @@ -853,7 +858,7 @@ let migration_https_only = ref true let cluster_stack_root = ref "/usr/libexec/xapi/cluster-stack" -let cluster_stack_default = ref "xhad" +let cluster_stack_default = ref Constants.default_cluster_stack let xen_cmdline_path = ref "/opt/xensource/libexec/xen-cmdline" @@ -871,6 +876,10 @@ let nbd_firewall_config_script = let firewall_port_config_script = ref "/etc/xapi.d/plugins/firewall-port" +let firewall_cmd = ref "/usr/bin/firewall-cmd" + +let firewall_cmd_wrapper = ref "/usr/bin/firewall-cmd-wrapper" + let nbd_client_manager_script = ref "/opt/xensource/libexec/nbd_client_manager.py" @@ -902,6 +911,8 @@ let xen_livepatch_list = ref "/usr/sbin/xen-livepatch list" let kpatch_list = ref "/usr/sbin/kpatch list" +let guest_service_keys = ref ["pvs_target/target_software_version"] + let modprobe_path = ref "/usr/sbin/modprobe" let usb_path = "usb_path" @@ -932,6 +943,13 @@ let gen_pool_secret_script = ref "/usr/bin/pool_secret_wrapper" let repository_domain_name_allowlist = ref [] +(* + This blocklist aims to prevent the creation of any repository whose URL matches an entry in the blocklist. + Additionally, if an existing repository contains a URL that matches an entry in the blocklist, + it should be removed automatically after xapi is restarted. +*) +let repository_url_blocklist = ref [] + let yum_cmd = ref "/usr/bin/yum" let dnf_cmd = ref "/usr/bin/dnf" @@ -954,6 +972,9 @@ let pvsproxy_close_cache_vdi = ref "/opt/citrix/pvsproxy/close-cache-vdi.sh" let yum_repos_config_dir = ref "/etc/yum.repos.d" +let dnf_repo_config_file = + ref "/etc/dnf/repos.override.d/99-config_manager.repo" + let remote_repository_prefix = ref "remote" let bundle_repository_prefix = ref "bundle" @@ -1010,6 +1031,8 @@ let winbind_cache_time = ref 60 let winbind_machine_pwd_timeout = ref (2. *. 7. *. 24. *. 3600.) +let winbind_dns_sync_interval = ref 3600. + let winbind_update_closest_kdc_interval = ref (3600. *. 22.) (* every 22 hours *) @@ -1052,10 +1075,14 @@ let trace_log_dir = ref "/var/log/dt/zipkinv2/json" let export_interval = ref 30. +let export_chunk_size = ref 10000 + let max_spans = ref 10000 let max_traces = ref 10000 +let max_span_depth = ref 100 + let use_xmlrpc = ref true let compress_tracing_files = ref true @@ -1094,11 +1121,18 @@ let reuse_pool_sessions = ref false let validate_reusable_pool_session = ref false (* Validate a reusable session before each use. This is slower and should not be required *) +let vm_sysprep_enabled = ref true +(* enable VM.sysprep API *) + +let vm_sysprep_wait = ref 5.0 (* seconds *) + let test_open = ref 0 let xapi_requests_cgroup = "/sys/fs/cgroup/cpu/control.slice/xapi.service/request" +let genisoimage_path = ref "/usr/bin/genisoimage" + (* Event.{from,next} batching delays *) let make_batching name ~delay_before ~delay_between = let name = Printf.sprintf "%s_delay" name in @@ -1212,6 +1246,7 @@ let xapi_globs_spec = ; ("winbind_debug_level", Int winbind_debug_level) ; ("winbind_cache_time", Int winbind_cache_time) ; ("winbind_machine_pwd_timeout", Float winbind_machine_pwd_timeout) + ; ("winbind_dns_sync_interval", Float winbind_dns_sync_interval) ; ( "winbind_update_closest_kdc_interval" , Float winbind_update_closest_kdc_interval ) @@ -1231,6 +1266,7 @@ let xapi_globs_spec = ; ("max_observer_file_size", Int max_observer_file_size) ; ("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) ] let xapi_globs_spec_with_descriptions = @@ -1300,6 +1336,28 @@ let gpumon_stop_timeout = ref 10.0 let reboot_required_hfxs = ref "/run/reboot-required.hfxs" +let console_timeout_profile_path = ref "/etc/profile.d/console_timeout.sh" + +let job_for_disable_ssh = ref "Disable SSH" + +let ssh_service = ref "sshd" + +let ssh_monitor_service = ref "xapi-ssh-monitor" + +let ssh_auto_mode_default = ref true + +type firewall_backend_type = Firewalld | Iptables + +(* Firewall backend to use. iptables in XS 8, firewalld in XS 9. *) +let firewall_backend = ref Iptables + +(* For firewalld, if dynamic control firewalld service. *) +let dynamic_control_firewalld_service = ref true + +let secure_boot_path = + ref + "/sys/firmware/efi/efivars/SecureBoot-8be4df61-93ca-11d2-aa0d-00e098032b8c" + (* Fingerprint of default patch key *) let citrix_patch_key = "NERDNTUzMDMwRUMwNDFFNDI4N0M4OEVCRUFEMzlGOTJEOEE5REUyNg==" @@ -1323,18 +1381,14 @@ let gen_list_option name desc of_string string_of opt = let sm_plugins = ref [] let accept_sm_plugin name = - List.( - fold_left ( || ) false - (map - (function - | `All -> - true - | `Sm x -> - String.lowercase_ascii x = String.lowercase_ascii name - ) - !sm_plugins + List.exists + (function + | `All -> + true + | `Sm x -> + String.lowercase_ascii x = String.lowercase_ascii name ) - ) + !sm_plugins let nvidia_multi_vgpu_enabled_driver_versions = ref ["430.42"; "430.62"; "440.00+"] @@ -1599,6 +1653,11 @@ let other_options = (fun s -> s) (fun s -> s) repository_domain_name_allowlist + ; gen_list_option "repository-url-blocklist" + "space-separated list of blocked URL patterns in base URL in repository." + (fun s -> s) + (fun s -> s) + repository_url_blocklist ; ( "repository-gpgcheck" , Arg.Set repository_gpgcheck , (fun () -> string_of_bool !repository_gpgcheck) @@ -1653,6 +1712,11 @@ let other_options = , (fun () -> string_of_float !export_interval) , "The interval for exports in Tracing" ) + ; ( "export-chunk-size" + , Arg.Set_int export_chunk_size + , (fun () -> string_of_int !export_chunk_size) + , "The span chunk size for exports in Tracing" + ) ; ( "max-spans" , Arg.Set_int max_spans , (fun () -> string_of_int !max_spans) @@ -1744,6 +1808,60 @@ let other_options = , (fun () -> string_of_bool !validate_reusable_pool_session) , "Enable validation of reusable pool sessions before use" ) + ; ( "ssh-auto-mode" + , Arg.Bool (fun b -> ssh_auto_mode_default := b) + , (fun () -> string_of_bool !ssh_auto_mode_default) + , "Defaults to true; overridden to false via \ + /etc/xapi.conf.d/ssh-auto-mode.conf(e.g., in XenServer 8)" + ) + ; ( "secure-boot-efi-path" + , Arg.Set_string secure_boot_path + , (fun () -> !secure_boot_path) + , "Path to secure boot status file" + ) + ; ( "vm-sysprep-enabled" + , Arg.Set vm_sysprep_enabled + , (fun () -> string_of_bool !vm_sysprep_enabled) + , "Enable VM.sysprep API" + ) + ; ( "vm-sysprep-wait" + , Arg.Set_float vm_sysprep_wait + , (fun () -> string_of_float !vm_sysprep_wait) + , "Time in seconds to wait for VM to recognise inserted CD" + ) + ; ( "max-span-depth" + , Arg.Set_int max_span_depth + , (fun () -> string_of_int !max_span_depth) + , "The maximum depth to which spans are recorded in a trace in Tracing" + ) + ; ( "firewall-backend" + , Arg.String + (fun s -> + firewall_backend := + match s with + | "firewalld" -> + Firewalld + | "iptables" -> + Iptables + | _ -> + D.error "Unknown firewall backend: %s" s ; + failwith "Unknown firewall backend" + ) + , (fun () -> + match !firewall_backend with + | Firewalld -> + "firewalld" + | Iptables -> + "iptables" + ) + , "Firewall backend. iptables (in XS 8) or firewalld (in XS 9 or later XS \ + version)" + ) + ; ( "dynamic-control-firewalld-service" + , Arg.Bool (fun b -> dynamic_control_firewalld_service := b) + , (fun () -> string_of_bool !dynamic_control_firewalld_service) + , "Enable dynamic control firewalld service" + ) ] (* The options can be set with the variable xapiflags in /etc/sysconfig/xapi. @@ -1790,6 +1908,8 @@ module Resources = struct ) ; ("sparse_dd", sparse_dd, "Path to sparse_dd") ; ("vhd-tool", vhd_tool, "Path to vhd-tool") + ; ("qcow_to_stdout", qcow_to_stdout, "Path to qcow-to-stdout script") + ; ("qcow_stream_tool", qcow_stream_tool, "Path to qcow-stream-tool") ; ("fence", fence, "Path to fence binary, used for HA host fencing") ; ( "host-bugreport-upload" , host_bugreport_upload @@ -1881,6 +2001,15 @@ module Resources = struct , "Executed when starting/stopping xapi-clusterd to configure firewall \ port" ) + ; ( "firewall-cmd" + , firewall_cmd + , "Executed when enable/disable a service on a firewalld zone" + ) + ; ( "firewall-cmd-wrapper" + , firewall_cmd_wrapper + , "Executed when enable/disable a service on a firewalld zone and \ + interface" + ) ; ( "nbd_client_manager" , nbd_client_manager_script , "Executed to safely connect to and disconnect from NBD devices using \ @@ -1935,6 +2064,7 @@ module Resources = struct , pvsproxy_close_cache_vdi , "Path to close-cache-vdi.sh" ) + ; ("genisoimage", genisoimage_path, "Path to genisoimage") ] let essential_files = diff --git a/ocaml/xapi/xapi_guest_agent.ml b/ocaml/xapi/xapi_guest_agent.ml index edb56d6499..9ecee4ff07 100644 --- a/ocaml/xapi/xapi_guest_agent.ml +++ b/ocaml/xapi/xapi_guest_agent.ml @@ -94,7 +94,7 @@ let ( // ) = Filename.concat * * Add support for SR-IOV VF, so there are two kinds of vif_type, either to be * `vif` or `net-sriov-vf` - * *) + *) let networks path vif_type (list : string -> string list) = (* Find all ipv6 addresses under a path. *) let find_ipv6 path prefix = @@ -345,7 +345,21 @@ let get_initial_guest_metrics (lookup : string -> string option) ; networks "xenserver/attr" "net-sriov-vf" list ] ) - and services = get_guest_services lookup list + and services = + let services = get_guest_services lookup list in + let keys = !Xapi_globs.guest_service_keys in + let res = + List.fold_left + (fun acc key -> + match lookup ("data/" ^ key) with + | Some value -> + (key, value) :: acc + | None -> + acc + ) + [] keys + in + List.rev_append services res and other = List.append (to_map (other all_control)) ts and memory = to_map memory and last_updated = Unix.gettimeofday () in @@ -488,7 +502,7 @@ let all (lookup : string -> string option) (list : string -> string list) || guest_metrics_cached.can_use_hotplug_vif <> can_use_hotplug_vif (* Nb. we're ignoring the memory updates as far as the VM_guest_metrics API object is concerned. We are putting them into an RRD instead *) (* || - guest_metrics_cached.memory <> memory)*) + guest_metrics_cached.memory <> memory)*) then ( let gm = let existing = Db.VM.get_guest_metrics ~__context ~self in diff --git a/ocaml/xapi/xapi_ha.ml b/ocaml/xapi/xapi_ha.ml index e88ecf1376..1b62a99d25 100644 --- a/ocaml/xapi/xapi_ha.ml +++ b/ocaml/xapi/xapi_ha.ml @@ -42,6 +42,10 @@ let ha_redo_log = (*********************************************************************************************) (* Interface with the low-level HA subsystem *) +exception Address_not_found of string + +exception Uuid_not_found of string + (** Returns the current live set info *) let query_liveset () = let txt = call_script ~log_output:On_failure ha_query_liveset [] in @@ -76,8 +80,11 @@ let propose_master () = (** Returns true if local failover decisions have not been disabled on this node *) let local_failover_decisions_are_ok () = - try not (bool_of_string (Localdb.get Constants.ha_disable_failover_decisions)) - with _ -> true + let disabled = + Localdb.get_bool Constants.ha_disable_failover_decisions + |> Option.value ~default:false + in + not disabled (** Since the liveset info doesn't include the host IP address, we persist these ourselves *) let write_uuid_to_ip_mapping ~__context = @@ -91,36 +98,40 @@ let write_uuid_to_ip_mapping ~__context = (** Since the liveset info doesn't include the host IP address, we persist these ourselves *) let get_uuid_to_ip_mapping () = - let v = Localdb.get Constants.ha_peers in - String_unmarshall_helper.map (fun x -> x) (fun x -> x) v + match Localdb.get Constants.ha_peers with + | Some peers -> + String_unmarshall_helper.map (fun k -> k) (fun v -> v) peers + | None -> + [] (** Without using the Pool's database, returns the IP address of a particular host named by UUID. *) let address_of_host_uuid uuid = let table = get_uuid_to_ip_mapping () in - if not (List.mem_assoc uuid table) then ( - error "Failed to find the IP address of host UUID %s" uuid ; - raise Not_found - ) else - List.assoc uuid table + let uuid_not_found = Uuid_not_found uuid in + List.assoc_opt uuid table |> Option.to_result ~none:uuid_not_found (** Without using the Pool's database, returns the UUID of a particular host named by heartbeat IP address. This is only necesary because the liveset info doesn't include the host IP address *) let uuid_of_host_address address = let table = List.map (fun (k, v) -> (v, k)) (get_uuid_to_ip_mapping ()) in - match List.assoc_opt address table with - | None -> - error "Failed to find the UUID address of host with address %s" address ; - raise Not_found - | Some uuid_str -> ( - match Uuidx.of_string uuid_str with - | None -> - error "Failed parse UUID of host with address %s" address ; - raise (Invalid_argument "Invalid UUID") - | Some uuid -> - uuid - ) + let invalid_uuid = Invalid_argument "Invalid UUID" in + let address_not_found = Address_not_found address in + let to_uuid str = + Uuidx.of_string str |> Option.to_result ~none:invalid_uuid + in + List.assoc_opt address table + |> Option.to_result ~none:address_not_found + |> Fun.flip Result.bind to_uuid + +let ok_or_raise map_error = function Ok v -> v | Error exn -> map_error exn + +let master_address_exn __FUN e = + let exn = Printexc.to_string e in + let msg = Printf.sprintf "unable to gather the coordinator's IP: %s" exn in + error "%s: %s" __FUN msg ; + raise Api_errors.(Server_error (internal_error, [msg])) (** Called in two circumstances: 1. When I started up I thought I was the master but my proposal was rejected by the @@ -139,7 +150,9 @@ let on_master_failure () = done in let become_slave_of uuid = - let address = address_of_host_uuid uuid in + let address = + address_of_host_uuid uuid |> ok_or_raise (master_address_exn __FUNCTION__) + in info "This node will become the slave of host %s (%s)" uuid address ; Xapi_pool_transition.become_another_masters_slave address ; (* XXX CA-16388: prevent blocking *) @@ -164,19 +177,17 @@ let on_master_failure () = "ha_can_not_be_master_on_next_boot set: I cannot be master; looking \ for another master" ; let liveset = query_liveset () in + let open Xha_interface.LiveSetInformation in match Hashtbl.fold (fun uuid host acc -> - if - host.Xha_interface.LiveSetInformation.Host.master - && host.Xha_interface.LiveSetInformation.Host.liveness - (* CP-25481: a dead host may still have the master lock *) - then + (* CP-25481: a dead host may still have the master lock *) + if host.Host.master && host.Host.liveness then uuid :: acc else acc ) - liveset.Xha_interface.LiveSetInformation.hosts [] + liveset.hosts [] with | [] -> info "no other master exists yet; waiting 5 seconds and retrying" ; @@ -191,6 +202,18 @@ let on_master_failure () = ) done +let master_uuid_exn __FUN e = + let exn = Printexc.to_string e in + let msg = Printf.sprintf "unable to gather the coordinator's UUID: %s" exn in + error "%s: %s" __FUN msg ; + raise Api_errors.(Server_error (internal_error, [msg])) + +let master_not_in_liveset_exn __FUN e = + let exn = Printexc.to_string e in + let msg = Printf.sprintf "unable to gather the coordinator's info: %s" exn in + error "%s: %s" __FUN msg ; + raise Api_errors.(Server_error (internal_error, [msg])) + module Timeouts = struct type t = { heart_beat_interval: int @@ -303,7 +326,7 @@ module Monitor = struct let statefiles = Xha_statefile.list_existing_statefiles () in debug "HA background thread starting" ; (* Grab the base timeout value so we can cook the reported latencies *) - let base_t = int_of_string (Localdb.get Constants.ha_base_t) in + let base_t = int_of_string (Localdb.get_exn Constants.ha_base_t) in let timeouts = Timeouts.derive base_t in (* Set up our per-host alert triggers *) let localhost_uuid = Helpers.get_localhost_uuid () in @@ -457,16 +480,20 @@ module Monitor = struct (* WARNING: must not touch the database or perform blocking I/O *) let process_liveset_on_slave liveset = let address = Pool_role.get_master_address () in - let master_uuid = uuid_of_host_address address in + let master_uuid = + uuid_of_host_address address + |> ok_or_raise (master_uuid_exn __FUNCTION__) + in + let open Xha_interface.LiveSetInformation in + let uuid_not_found = + Uuid_not_found (Uuidx.to_string master_uuid) + in let master_info = - Hashtbl.find liveset.Xha_interface.LiveSetInformation.hosts - master_uuid + Hashtbl.find_opt liveset.hosts master_uuid + |> Option.to_result ~none:uuid_not_found + |> ok_or_raise (master_not_in_liveset_exn __FUNCTION__) in - if - true - && master_info.Xha_interface.LiveSetInformation.Host.liveness - && master_info.Xha_interface.LiveSetInformation.Host.master - then + if master_info.Host.liveness && master_info.Host.master then debug "The node we think is the master is still alive and marked \ as master; this is OK" @@ -501,13 +528,19 @@ module Monitor = struct ) in - (* let planned_for = Int64.to_int (Db.Pool.get_ha_plan_exists_for ~__context ~self:pool) in *) - (* First consider whether VM failover actions need to happen. Convert the liveset into a list of Host references used by the VM failover code *) let liveset_uuids = List.sort compare (uuids_of_liveset liveset) in + let to_refs uuids = + List.map + (fun uuid -> + Db.Host.get_by_uuid ~__context ~uuid:(Uuidx.to_string uuid) + ) + uuids + in + let last_live_set = to_refs !last_liveset_uuids in if !last_liveset_uuids <> liveset_uuids then ( warn "Liveset looks different; assuming we need to rerun the \ @@ -515,17 +548,11 @@ module Monitor = struct plan_out_of_date := true ; last_liveset_uuids := liveset_uuids ) ; - let liveset_refs = - List.map - (fun uuid -> - Db.Host.get_by_uuid ~__context ~uuid:(Uuidx.to_string uuid) - ) - liveset_uuids - in + let live_set = to_refs liveset_uuids in if local_failover_decisions_are_ok () then ( try Xapi_ha_vm_failover.restart_auto_run_vms ~__context - liveset_refs to_tolerate + ~last_live_set ~live_set to_tolerate with e -> log_backtrace e ; error @@ -539,9 +566,7 @@ module Monitor = struct (* Next update the Host_metrics.live value to spot hosts coming back *) let all_hosts = Db.Host.get_all ~__context in let livemap = - List.map - (fun host -> (host, List.mem host liveset_refs)) - all_hosts + List.map (fun host -> (host, List.mem host live_set)) all_hosts in List.iter (fun (host, live) -> @@ -629,11 +654,9 @@ module Monitor = struct (* and yet has no statefile access *) in let all_live_nodes_lost_statefile = - List.fold_left ( && ) true - (List.map - (fun (_, xha_host) -> relying_on_rule_2 xha_host) - host_host_table - ) + List.for_all + (fun (_, xha_host) -> relying_on_rule_2 xha_host) + host_host_table in warning_all_live_nodes_lost_statefile all_live_nodes_lost_statefile ; @@ -704,8 +727,7 @@ module Monitor = struct in if plan_too_old || !plan_out_of_date then ( let changed = - Xapi_ha_vm_failover.update_pool_status ~__context - ~live_set:liveset_refs () + Xapi_ha_vm_failover.update_pool_status ~__context ~live_set () in (* Extremely bad: something managed to break our careful plan *) if changed && not !plan_out_of_date then @@ -967,9 +989,31 @@ let redo_log_ha_enabled_at_startup () = (* ----------------------------- *) +let update_ha_firewalld_service status = + (* Only xha needs to enable firewalld service. Other HA cluster stacks don't + need. *) + if + Localdb.get Constants.ha_cluster_stack + |> Option.value ~default:!Xapi_globs.cluster_stack_default + = Constants.Ha_cluster_stack.(to_string Xhad) + then + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Xenha status + +let ha_start_daemon () = + update_ha_firewalld_service Firewall.Enabled ; + let (_ : string) = call_script ha_start_daemon [] in + () + let on_server_restart () = - let armed = bool_of_string (Localdb.get Constants.ha_armed) in - if armed then ( + let armed () = + Localdb.get_bool Constants.ha_armed |> Option.value ~default:false + in + if armed () then ( debug "HA is supposed to be armed" ; (* Make sure daemons are up *) let finished = ref false in @@ -977,10 +1021,7 @@ let on_server_restart () = XXX we might need some kind of user-override *) while not !finished do (* If someone has called Host.emergency_ha_disable in the background then we notice the change here *) - if - not - (try bool_of_string (Localdb.get Constants.ha_armed) with _ -> false) - then ( + if not (armed ()) then ( warn "ha_start_daemon aborted because someone has called \ Host.emergency_ha_disable" ; @@ -994,7 +1035,7 @@ let on_server_restart () = failwith "simulating xha daemon startup failure" ; (* CA-21406: Try again to reattach the statefile VDI *) Static_vdis.reattempt_on_boot_attach () ; - let (_ : string) = call_script ha_start_daemon [] in + ha_start_daemon () ; finished := true with | Xha_error Xha_errno.Mtc_exit_daemon_is_present -> @@ -1126,11 +1167,12 @@ let ha_set_excluded __context _localhost = let ha_stop_daemon __context _localhost = Monitor.stop () ; let (_ : string) = call_script ha_stop_daemon [] in + update_ha_firewalld_service Firewall.Disabled ; () let emergency_ha_disable __context soft = let ha_armed = - try bool_of_string (Localdb.get Constants.ha_armed) with _ -> false + Localdb.get_bool Constants.ha_armed |> Option.value ~default:false in if not ha_armed then if soft then @@ -1219,7 +1261,8 @@ let ha_wait_for_shutdown_via_statefile __context _localhost = with Xha_error Xha_errno.Mtc_exit_daemon_is_not_present -> info "ha_wait_for_shutdown_via_statefile: daemon has exited so returning \ - success" + success" ; + update_ha_firewalld_service Firewall.Disabled (** Attach the statefile VDIs and return the resulting list of paths in dom0 *) let attach_statefiles ~__context statevdis = @@ -1367,8 +1410,9 @@ let preconfigure_host __context localhost statevdis metadata_vdi generation = Localdb.put Constants.ha_base_t (string_of_int base_t) let join_liveset __context host = + let __FUN = __FUNCTION__ in info "Host.ha_join_liveset host = %s" (Ref.string_of host) ; - let (_ : string) = call_script ha_start_daemon [] in + ha_start_daemon () ; Localdb.put Constants.ha_disable_failover_decisions "false" ; Localdb.put Constants.ha_armed "true" ; info "Local flag ha_armed <- true" ; @@ -1384,7 +1428,10 @@ let join_liveset __context host = (* If this host is a slave then we must wait to confirm that the master manages to assert itself, otherwise our monitoring thread might attempt a hostile takeover *) let master_address = Pool_role.get_master_address () in - let master_uuid = uuid_of_host_address master_address in + let master_uuid = + uuid_of_host_address master_address + |> ok_or_raise (master_uuid_exn __FUN) + in let master_found = ref false in while not !master_found do (* It takes a non-trivial amount of time for the master to assert itself: we might @@ -1392,30 +1439,24 @@ let join_liveset __context host = should wait. *) Thread.delay 5. ; let liveset = query_liveset () in - debug "Liveset: %s" - (Xha_interface.LiveSetInformation.to_summary_string liveset) ; - if - liveset.Xha_interface.LiveSetInformation.status - = Xha_interface.LiveSetInformation.Status.Online - then + let open Xha_interface.LiveSetInformation in + debug "Liveset: %s" (to_summary_string liveset) ; + if liveset.status = Status.Online then (* 'master' is the node we believe should become the xHA-level master initially *) let master = - Hashtbl.find liveset.Xha_interface.LiveSetInformation.hosts - master_uuid + Hashtbl.find_opt liveset.hosts master_uuid + |> Option.to_result ~none:Not_found + |> ok_or_raise (master_not_in_liveset_exn __FUN) in - if master.Xha_interface.LiveSetInformation.Host.master then ( + if master.Host.master then ( info "existing master has successfully asserted itself" ; master_found := true (* loop will terminate *) ) else if false - || (not master.Xha_interface.LiveSetInformation.Host.liveness) - || master - .Xha_interface.LiveSetInformation.Host.state_file_corrupted - || (not - master - .Xha_interface.LiveSetInformation.Host.state_file_access - ) - || master.Xha_interface.LiveSetInformation.Host.excluded + || (not master.Host.liveness) + || master.Host.state_file_corrupted + || (not master.Host.state_file_access) + || master.Host.excluded then ( error "Existing master has failed during HA enable process" ; failwith "Existing master failed during HA enable process" @@ -1851,10 +1892,7 @@ let enable __context heartbeat_srs configuration = with _ -> false in if not alive then - raise - (Api_errors.Server_error - (Api_errors.host_offline, [Ref.string_of host]) - ) + raise Api_errors.(Server_error (host_offline, [Ref.string_of host])) ) (Db.Host.get_all ~__context) ; let pool = Helpers.get_pool ~__context in @@ -1879,20 +1917,23 @@ let enable __context heartbeat_srs configuration = else heartbeat_srs in - if possible_srs = [] then - raise (Api_errors.Server_error (Api_errors.cannot_create_state_file, [])) ; - (* For the moment we'll create a state file in one compatible SR since the xHA component only handles one *) - let srs = [List.hd possible_srs] in + (* For the moment we'll create a state file in one compatible SR since the + xHA component only handles one *) + let sr = + match possible_srs with + | [] -> + raise Api_errors.(Server_error (cannot_create_state_file, [])) + | sr :: _ -> + sr + in List.iter (fun sr -> let vdi = Xha_statefile.find_or_create ~__context ~sr ~cluster_stack in statefile_vdis := vdi :: !statefile_vdis ) - srs ; + [sr] ; (* For storing the database, assume there is only one SR *) - let database_vdi = - Xha_metadata_vdi.find_or_create ~__context ~sr:(List.hd srs) - in + let database_vdi = Xha_metadata_vdi.find_or_create ~__context ~sr in database_vdis := database_vdi :: !database_vdis ; (* Record the statefile UUIDs in the Pool.ha_statefile set *) Db.Pool.set_ha_statefiles ~__context ~self:pool @@ -1973,14 +2014,16 @@ let enable __context heartbeat_srs configuration = (ExnHelper.string_of_exn e) ) errors ; - if errors <> [] then ( - (* Perform a disable since the pool HA state isn't consistent *) - error "Attempting to disable HA pool-wide" ; - Helpers.log_exn_continue - "Disabling HA after a failure joining all hosts to the liveset" - disable_internal __context ; - raise (snd (List.hd errors)) - ) ; + List.iter + (fun (_, exn) -> + (* Perform a disable since the pool HA state isn't consistent *) + error "Attempting to disable HA pool-wide" ; + Helpers.log_exn_continue + "Disabling HA after a failure joining all hosts to the liveset" + disable_internal __context ; + raise exn + ) + errors ; (* We have to set the HA enabled flag before forcing a database resynchronisation *) Db.Pool.set_ha_enabled ~__context ~self:pool ~value:true ; debug "HA enabled" ; @@ -2018,13 +2061,16 @@ let enable __context heartbeat_srs configuration = (ExnHelper.string_of_exn e) ) errors ; - if errors <> [] then ( - (* Perform a disable since the pool HA state isn't consistent *) - error "Attempting to disable HA pool-wide" ; - Helpers.log_exn_continue "Disabling HA after a failure during enable" - disable_internal __context ; - raise (snd (List.hd errors)) - ) ; + List.iter + (fun (_, exn) -> + (* Perform a disable since the pool HA state isn't consistent *) + error "Attempting to disable HA pool-wide" ; + Helpers.log_exn_continue + "Disabling HA after a failure during enable" disable_internal + __context ; + raise exn + ) + errors ; (* Update the allowed_operations on the HA volumes to prevent people thinking they can mess with them *) List.iter (fun vdi -> Xapi_vdi.update_allowed_operations ~__context ~self:vdi) diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 5cbb946b15..998088d8f5 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -112,7 +112,7 @@ end = struct k x | Task (task, next) -> (* similar reasoning as above, when we get the result we need to chain the computations, - * refer to http://okmij.org/ftp/Computation/free-monad.html for a deeper theoretical explanation *) + * refer to http://okmij.org/ftp/Computation/free-monad.html for a deeper theoretical explanation *) Task (task, fun x -> next x >>= k) end @@ -1223,9 +1223,6 @@ let assert_configuration_change_preserves_ha_plan ~__context c = "assert_configuration_change_preserves_ha_plan: plan exists after \ change" | Plan_exists_excluding_non_agile_VMs | No_plan_exists -> - debug - "assert_configuration_change_preserves_ha_plan: proposed change \ - breaks plan" ; raise (Api_errors.Server_error (Api_errors.ha_operation_would_break_failover_plan, []) @@ -1259,9 +1256,26 @@ let restart_failed : (API.ref_VM, unit) Hashtbl.t = Hashtbl.create 10 (* We also limit the rate we attempt to retry starting the VM. *) let last_start_attempt : (API.ref_VM, float) Hashtbl.t = Hashtbl.create 10 +module VMRefOrd = struct + type t = [`VM] Ref.t + + let compare = Ref.compare +end + +module VMMap = Map.Make (VMRefOrd) + +(* When a host is up, it will be added in the HA live set. But it may be still + in disabled state so that starting best-effort VMs on it would fail. + Meanwhile we don't want to retry on starting them forever. + This data is to remember the best-effort VMs which failed to start due to + this and the key of the map is the VM ref. And its value is the count of the + attempts of starting. This is to avoid retrying for ever and can be adjusted + according to how hong the host becomes enabled since it is in HA live set. *) +let tried_best_eff_vms = ref VMMap.empty + (* Takes the current live_set and number of hosts we're planning to handle, updates the host records in the database and restarts any offline protected VMs *) -let restart_auto_run_vms ~__context live_set n = +let restart_auto_run_vms ~__context ~last_live_set ~live_set n = (* ensure we have live=false on the host_metrics for those hosts not in the live_set; and force state to Halted for all VMs that are "running" or "paused" with resident_on set to one of the hosts that is now dead *) @@ -1396,8 +1410,9 @@ let restart_auto_run_vms ~__context live_set n = let open TaskChains.Infix in (* execute the plan *) Helpers.call_api_functions ~__context (fun rpc session_id -> - (* Helper function to start a VM somewhere. If the HA overcommit protection stops us then disable it and try once more. - Returns true if the VM was restarted and false otherwise. *) + (* Helper function to start a VM somewhere. If the HA overcommit + protection stops us then disable it and try once more. Returns true if + the VM was restarted and false otherwise. *) let restart_vm vm ?host () = let go () = ( if Xapi_fist.simulate_restart_failure () then @@ -1562,36 +1577,95 @@ let restart_auto_run_vms ~__context live_set n = in gc_table last_start_attempt ; gc_table restart_failed ; - (* Consider restarting the best-effort VMs we *think* have failed (but we might get this wrong -- - ok since this is 'best-effort'). NOTE we do not use the restart_vm function above as this will mark the - pool as overcommitted if an HA_OPERATION_WOULD_BREAK_FAILOVER_PLAN is received (although this should never - happen it's better safe than sorry) *) - map_parallel - ~order_f:(fun vm -> order_f (vm, Db.VM.get_record ~__context ~self:vm)) - (fun vm -> + (* Consider restarting the best-effort VMs we *think* have failed (but we + might get this wrong -- ok since this is 'best-effort'). NOTE we do + not use the restart_vm function above as this will mark the pool as + overcommitted if an HA_OPERATION_WOULD_BREAK_FAILOVER_PLAN is received + (although this should never happen it's better safe than sorry) *) + let is_best_effort r = + r.API.vM_ha_restart_priority = Constants.ha_restart_best_effort + && r.API.vM_power_state = `Halted + in + let resets = + !reset_vms + |> List.map (fun self -> (self, Db.VM.get_record ~__context ~self)) + in + let revalidate_tried m = + let valid, invalid = + VMMap.bindings m + |> List.partition_map (fun (self, _) -> + match Db.VM.get_record ~__context ~self with + | r -> + Left (self, r) + | exception _ -> + Right self + ) + in + let to_retry, to_remove = + List.partition (fun (_, r) -> is_best_effort r) valid + in + let m' = + List.map fst to_remove + |> List.rev_append invalid + |> List.fold_left (fun acc vm -> VMMap.remove vm acc) m + in + (to_retry, m') + in + let best_effort_vms = + (* Carefully decide which best-effort VMs should attempt to start. *) + let all_prot_is_ok = List.for_all (fun (_, r) -> r = Ok ()) started in + let is_better = List.compare_lengths live_set last_live_set > 0 in + ( match (all_prot_is_ok, is_better, last_live_set = live_set) with + | true, true, _ -> + (* Try to start all the best-effort halted VMs when HA is being + enabled or some hosts are transiting to HA live. + The DB has been updated by Xapi_vm_lifecycle.force_state_reset. + Read again. *) + tried_best_eff_vms := VMMap.empty ; + Db.VM.get_all_records ~__context + | true, false, true -> + (* Retry for best-effort VMs which attepmted but failed last time. *) + let to_retry, m = revalidate_tried !tried_best_eff_vms in + tried_best_eff_vms := m ; + List.rev_append to_retry resets + | true, false, false | false, _, _ -> + (* Try to start only the reset VMs. They were observed as residing + on the non-live hosts in this run. + Give up starting tried VMs as the HA situation changes. *) + tried_best_eff_vms := VMMap.empty ; + resets + ) + |> List.filter (fun (_, r) -> is_best_effort r) + in + map_parallel ~order_f + (fun (vm, _) -> ( vm - , if - Db.VM.get_power_state ~__context ~self:vm = `Halted - && Db.VM.get_ha_restart_priority ~__context ~self:vm - = Constants.ha_restart_best_effort - then - TaskChains.task (fun () -> - Client.Client.Async.VM.start ~rpc ~session_id ~vm - ~start_paused:false ~force:true - ) - else - TaskChains.ok Rpc.Null + , TaskChains.task (fun () -> + Client.Client.Async.VM.start ~rpc ~session_id ~vm + ~start_paused:false ~force:true + ) ) ) - !reset_vms + best_effort_vms |> List.iter (fun (vm, result) -> match result with | Error e -> + tried_best_eff_vms := + VMMap.update vm + (Option.fold ~none:(Some 1) ~some:(fun n -> + if n < !Xapi_globs.ha_best_effort_max_retries then + Some (n + 1) + else + None + ) + ) + !tried_best_eff_vms ; error "Failed to restart best-effort VM %s (%s): %s" (Db.VM.get_uuid ~__context ~self:vm) (Db.VM.get_name_label ~__context ~self:vm) (ExnHelper.string_of_exn e) | Ok _ -> + tried_best_eff_vms := VMMap.remove vm !tried_best_eff_vms ; () ) ) diff --git a/ocaml/xapi/xapi_ha_vm_failover.mli b/ocaml/xapi/xapi_ha_vm_failover.mli index 20eb3b6b84..abf6374822 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.mli +++ b/ocaml/xapi/xapi_ha_vm_failover.mli @@ -18,7 +18,11 @@ val all_protected_vms : __context:Context.t -> (API.ref_VM * API.vM_t) list val restart_auto_run_vms : - __context:Context.t -> API.ref_host list -> int -> unit + __context:Context.t + -> last_live_set:API.ref_host list + -> live_set:API.ref_host list + -> int + -> unit (** Take a set of live VMs and attempt to restart all protected VMs which have failed *) val compute_evacuation_plan : diff --git a/ocaml/xapi/xapi_hooks.ml b/ocaml/xapi/xapi_hooks.ml index 2f9edaff07..a7ba2d7554 100644 --- a/ocaml/xapi/xapi_hooks.ml +++ b/ocaml/xapi/xapi_hooks.ml @@ -102,13 +102,11 @@ let execute_hook ~__context ~script_name ~args ~reason = ) scripts -let execute_vm_hook ~__context ~reason ~vm = - let vmuuid = Db.VM.get_uuid ~__context ~self:vm in - execute_hook ~__context ~args:["-vmuuid"; vmuuid] ~reason +let execute_vm_hook ~__context ~reason ~vm_uuid = + execute_hook ~__context ~args:["-vmuuid"; vm_uuid] ~reason -let execute_host_hook ~__context ~reason ~host = - let uuid = Db.Host.get_uuid ~__context ~self:host in - execute_hook ~__context ~args:["-hostuuid"; uuid] ~reason +let execute_host_hook ~__context ~reason ~host_uuid = + execute_hook ~__context ~args:["-hostuuid"; host_uuid] ~reason let execute_pool_hook ~__context ~reason = execute_hook ~__context ~args:[] ~reason @@ -116,8 +114,9 @@ let execute_pool_hook ~__context ~reason = let host_pre_declare_dead ~__context ~host ~reason = info "Running host pre declare dead hook for %s" (Ref.string_of host) ; (* this could use power fencing *) + let host_uuid = Db.Host.get_uuid ~__context ~self:host in execute_host_hook ~__context ~script_name:scriptname__host_pre_declare_dead - ~reason ~host ; + ~reason ~host_uuid ; if String.equal reason reason__dbdestroy then log_and_ignore_exn (fun () -> (* declare it as dead to the clustering daemon if any *) @@ -132,11 +131,10 @@ let host_pre_declare_dead ~__context ~host ~reason = () ) -let xapi_pre_shutdown ~__context ~host ~reason = - info "%s Running xapi pre shutdown hooks for %s" __FUNCTION__ - (Ref.string_of host) ; +let xapi_pre_shutdown ~__context ~host_uuid ~reason = + info "%s Running xapi pre shutdown hooks for %s" __FUNCTION__ host_uuid ; execute_host_hook ~__context ~script_name:scriptname__xapi_pre_shutdown - ~reason ~host + ~reason ~host_uuid (* Called when host died -- !! hook code in here to abort outstanding forwarded ops *) let internal_host_dead_hook __context host = @@ -159,8 +157,9 @@ let internal_host_dead_hook __context host = let host_post_declare_dead ~__context ~host ~reason = (* Cancel outstanding tasks first-- should release necessary locks *) internal_host_dead_hook __context host ; + let host_uuid = Db.Host.get_uuid ~__context ~self:host in execute_host_hook ~__context ~script_name:scriptname__host_post_declare_dead - ~reason ~host + ~reason ~host_uuid let pool_ha_overcommitted_hook ~__context = execute_pool_hook ~__context ~script_name:scriptname__pool_ha_overcommitted diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index e2cece5cb5..ee446592bb 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -74,19 +74,27 @@ let set_power_on_mode ~__context ~self ~power_on_mode ~power_on_config = + HA is enabled and this host has broken storage or networking which would cause protected VMs to become non-agile *) -let assert_safe_to_reenable ~__context ~self = +let assert_safe_to_reenable ~__context ~self ~user_request = assert_startup_complete () ; Repository_helpers.assert_no_host_pending_mandatory_guidance ~__context ~host:self ; let host_disabled_until_reboot = - try bool_of_string (Localdb.get Constants.host_disabled_until_reboot) - with _ -> false + Localdb.get_bool Constants.host_disabled_until_reboot + |> Option.value ~default:false in if host_disabled_until_reboot then raise (Api_errors.Server_error (Api_errors.host_disabled_until_reboot, [Ref.string_of self]) ) ; + let host_auto_enable = + Localdb.get_bool Constants.host_auto_enable |> Option.value ~default:true + in + if (not host_auto_enable) && not user_request then + raise + (Api_errors.Server_error + (Api_errors.host_disabled_indefinitely, [Ref.string_of self]) + ) ; if Db.Pool.get_ha_enabled ~__context ~self:(Helpers.get_pool ~__context) then ( let pbds = Db.Host.get_PBDs ~__context ~self in let unplugged_pbds = @@ -101,17 +109,17 @@ let assert_safe_to_reenable ~__context ~self = ) unplugged_pbds ; let pifs = Db.Host.get_PIFs ~__context ~self in - let unplugged_pifs = + let non_pluggable_pifs = List.filter - (fun pif -> not (Db.PIF.get_currently_attached ~__context ~self:pif)) + (fun pif -> not (Xapi_pif_helpers.is_pluggable ~__context pif)) pifs in - (* Make sure it is 'ok' to have these PIFs remain unplugged *) + (* Make sure it is 'ok' that these PIFs cannot be plugged *) List.iter (fun self -> Xapi_pif.abort_if_network_attached_to_protected_vms ~__context ~self ) - unplugged_pifs + non_pluggable_pifs ) (* The maximum pool size allowed must be restricted to 3 hosts for the pool which does not have Pool_size feature *) @@ -119,6 +127,8 @@ let pool_size_is_restricted ~__context = not (Pool_features.is_enabled ~__context Features.Pool_size) let bugreport_upload ~__context ~host:_ ~url ~options = + if url = "" then + raise Api_errors.(Server_error (invalid_value, ["url"; ""])) ; let proxy = if List.mem_assoc "http_proxy" options then List.assoc "http_proxy" options @@ -285,14 +295,20 @@ let compute_evacuation_plan_no_wlb ~__context ~host ?(ignore_ha = false) () = the source host. So as long as host versions aren't decreasing, we're allowed to migrate VMs between hosts. *) debug "evacuating host version: %s" - (Helpers.version_string_of ~__context (Helpers.LocalObject host)) ; + (Helpers.Checks.Migration.get_software_versions ~__context + (Helpers.LocalObject host) + |> Helpers.Checks.versions_string_of + ) ; let target_hosts = List.filter (fun target -> debug "host %s version: %s" (Db.Host.get_hostname ~__context ~self:target) - (Helpers.version_string_of ~__context (Helpers.LocalObject target)) ; - Helpers.host_versions_not_decreasing ~__context + Helpers.Checks.( + Migration.get_software_versions ~__context (LocalObject target) + |> versions_string_of + ) ; + Helpers.Checks.Migration.host_versions_not_decreasing ~__context ~host_from:(Helpers.LocalObject host) ~host_to:(Helpers.LocalObject target) ) @@ -487,7 +503,8 @@ let compute_evacuation_plan_wlb ~__context ~self = if Db.Host.get_control_domain ~__context ~self:target_host <> v && Db.Host.get_uuid ~__context ~self:resident_h = target_uuid - then (* resident host and migration host are the same. Reject this plan *) + (* resident host and migration host are the same. Reject this plan *) + then raise (Api_errors.Server_error ( Api_errors.wlb_malformed_response @@ -649,8 +666,9 @@ let evacuate ~__context ~host ~network ~evacuate_batch_size = raise (Api_errors.Server_error (code, params)) in - (* execute [n] asynchronous API calls [api_fn] for [xs] and wait for them to - finish before executing the next batch. *) + (* execute [plans_length] asynchronous API calls [api_fn] for [xs] in batches + of [n] at a time, scheduling a new call as soon as one of the tasks from + the previous batch is completed *) let batch ~__context n api_fn xs = let finally = Xapi_stdext_pervasives.Pervasiveext.finally in let destroy = Client.Client.Task.destroy in @@ -675,27 +693,55 @@ let evacuate ~__context ~host ~network ~evacuate_batch_size = fail task "unexpected status of migration task" in - let rec loop xs = - match take n xs with - | [], _ -> - () - | head, tail -> - Helpers.call_api_functions ~__context @@ fun rpc session_id -> - let tasks = List.map (api_fn ~rpc ~session_id) head in - finally - (fun () -> - Tasks.wait_for_all ~rpc ~session_id ~tasks ; - List.iter assert_success tasks ; - let tail_length = List.length tail |> float in - let progress = 1.0 -. (tail_length /. plans_length) in - TaskHelper.set_progress ~__context progress + Helpers.call_api_functions ~__context @@ fun rpc session_id -> + ( match take n xs with + | [], _ -> + () + | head, tasks_left -> + let tasks_left = ref tasks_left in + let initial_task_batch = List.map (api_fn ~rpc ~session_id) head in + let tasks_pending = + ref + (List.fold_left + (fun task_set' task -> Tasks.TaskSet.add task task_set') + Tasks.TaskSet.empty initial_task_batch ) - (fun () -> - List.iter (fun self -> destroy ~rpc ~session_id ~self) tasks - ) ; - loop tail - in - loop xs ; + in + + let single_task_progress = 1.0 /. plans_length in + let on_each_task_completion completed_task_count completed_task = + (* Clean up the completed task *) + assert_success completed_task ; + destroy ~rpc ~session_id ~self:completed_task ; + tasks_pending := Tasks.TaskSet.remove completed_task !tasks_pending ; + + (* Update progress *) + let progress = + Int.to_float completed_task_count *. single_task_progress + in + TaskHelper.set_progress ~__context progress ; + + (* Schedule a new task, if there are any left *) + match !tasks_left with + | [] -> + [] + | task_to_schedule :: left -> + tasks_left := left ; + let new_task = api_fn ~rpc ~session_id task_to_schedule in + tasks_pending := Tasks.TaskSet.add new_task !tasks_pending ; + [new_task] + in + finally + (fun () -> + Tasks.wait_for_all_with_callback ~rpc ~session_id + ~tasks:initial_task_batch ~callback:on_each_task_completion + ) + (fun () -> + Tasks.TaskSet.iter + (fun self -> destroy ~rpc ~session_id ~self) + !tasks_pending + ) + ) ; TaskHelper.set_progress ~__context 1.0 in @@ -764,26 +810,29 @@ let restart_agent ~__context ~host:_ = ) let shutdown_agent ~__context = - debug "Host.restart_agent: Host agent will shutdown in 1s!!!!" ; - let localhost = Helpers.get_localhost ~__context in - Xapi_hooks.xapi_pre_shutdown ~__context ~host:localhost + 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 ; Xapi_fuse.light_fuse_and_dont_restart ~fuse_length:1. () -let disable ~__context ~host = +let disable ~__context ~host ~auto_enable = if Db.Host.get_enabled ~__context ~self:host then ( info "Host.enabled: setting host %s (%s) to disabled because of user request" (Ref.string_of host) (Db.Host.get_hostname ~__context ~self:host) ; Db.Host.set_enabled ~__context ~self:host ~value:false ; - Xapi_host_helpers.user_requested_host_disable := true + Xapi_host_helpers.user_requested_host_disable := true ; + if not auto_enable then + Localdb.put Constants.host_auto_enable "false" ) let enable ~__context ~host = if not (Db.Host.get_enabled ~__context ~self:host) then ( - assert_safe_to_reenable ~__context ~self:host ; + assert_safe_to_reenable ~__context ~self:host ~user_request:true ; Xapi_host_helpers.user_requested_host_disable := false ; + Localdb.put Constants.host_auto_enable "true" ; info "Host.enabled: setting host %s (%s) to enabled because of user request" (Ref.string_of host) (Db.Host.get_hostname ~__context ~self:host) ; @@ -978,7 +1027,9 @@ let is_host_alive ~__context ~host = let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address ~external_auth_type ~external_auth_service_name ~external_auth_configuration ~license_params ~edition ~license_server ~local_cache_sr ~chipset_info - ~ssl_legacy:_ ~last_software_update ~last_update_hash = + ~ssl_legacy:_ ~last_software_update ~last_update_hash ~ssh_enabled + ~ssh_enabled_timeout ~ssh_expiry ~console_idle_timeout ~ssh_auto_mode + ~secure_boot ~software_version = (* fail-safe. We already test this on the joining host, but it's racy, so multiple concurrent pool-join might succeed. Note: we do it in this order to avoid a problem checking restrictions during the initial setup of the database *) @@ -1013,9 +1064,8 @@ let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address (* no or multiple pools *) in Db.Host.create ~__context ~ref:host ~current_operations:[] - ~allowed_operations:[] ~https_only:false - ~software_version:(Xapi_globs.software_version ()) - ~enabled:false ~aPI_version_major:Datamodel_common.api_version_major + ~allowed_operations:[] ~https_only:false ~software_version ~enabled:false + ~aPI_version_major:Datamodel_common.api_version_major ~aPI_version_minor:Datamodel_common.api_version_minor ~aPI_version_vendor:Datamodel_common.api_version_vendor ~aPI_version_vendor_implementation: @@ -1042,7 +1092,9 @@ let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address ~multipathing:false ~uefi_certificates:"" ~editions:[] ~pending_guidances:[] ~tls_verification_enabled ~last_software_update ~last_update_hash ~recommended_guidances:[] ~latest_synced_updates_applied:`unknown - ~pending_guidances_recommended:[] ~pending_guidances_full:[] ; + ~pending_guidances_recommended:[] ~pending_guidances_full:[] ~ssh_enabled + ~ssh_enabled_timeout ~ssh_expiry ~console_idle_timeout ~ssh_auto_mode + ~secure_boot ; (* If the host we're creating is us, make sure its set to live *) Db.Host_metrics.set_last_updated ~__context ~self:metrics ~value:(Date.now ()) ; Db.Host_metrics.set_live ~__context ~self:metrics ~value:host_is_us ; @@ -1313,8 +1365,8 @@ let get_thread_diagnostics ~__context ~host:_ = let sm_dp_destroy ~__context ~host:_ ~dp ~allow_leak = Storage_access.dp_destroy ~__context dp allow_leak -let get_diagnostic_timing_stats ~__context ~host:_ = - Xapi_database.Stats.summarise () +let get_diagnostic_timing_stats ~__context ~host:_ ~counts = + Xapi_database.Stats.summarise ~counts () (* CP-825: Serialize execution of host-enable-extauth and host-disable-extauth *) (* We need to protect against concurrent execution of the extauth-hook script and host.enable/disable extauth, *) @@ -1738,7 +1790,6 @@ let enable_external_auth ~__context ~host ~config ~service_name ~auth_type = raise (Api_errors.Server_error (Api_errors.auth_unknown_type, [msg])) ) else (* if no auth_type is currently defined (it is an empty string), then we can set up a new one *) - (* we try to use the configuration to set up the new external authentication service *) (* we persist as much set up configuration now as we can *) @@ -2048,8 +2099,8 @@ let apply_edition_internal ~__context ~host ~edition ~additional = raise Api_errors.(Server_error (license_processing_error, [])) | V6_interface.(V6_error Missing_connection_details) -> raise Api_errors.(Server_error (missing_connection_details, [])) - | V6_interface.(V6_error (License_checkout_error s)) -> - raise Api_errors.(Server_error (license_checkout_error, [s])) + | V6_interface.(V6_error (License_checkout_error (code, msg))) -> + raise Api_errors.(Server_error (license_checkout_error, [code; msg])) | V6_interface.(V6_error (Internal_error e)) -> Helpers.internal_error "%s" e in @@ -2154,19 +2205,19 @@ let reset_networking ~__context ~host = (Db.PIF.get_all ~__context) in let bond_is_local bond = - List.fold_left - (fun a pif -> Db.Bond.get_master ~__context ~self:bond = pif || a) - false local_pifs + List.exists + (fun pif -> Db.Bond.get_master ~__context ~self:bond = pif) + local_pifs in let vlan_is_local vlan = - List.fold_left - (fun a pif -> Db.VLAN.get_untagged_PIF ~__context ~self:vlan = pif || a) - false local_pifs + List.exists + (fun pif -> Db.VLAN.get_untagged_PIF ~__context ~self:vlan = pif) + local_pifs in let tunnel_is_local tunnel = - List.fold_left - (fun a pif -> Db.Tunnel.get_access_PIF ~__context ~self:tunnel = pif || a) - false local_pifs + List.exists + (fun pif -> Db.Tunnel.get_access_PIF ~__context ~self:tunnel = pif) + local_pifs in let bonds = List.filter bond_is_local (Db.Bond.get_all ~__context) in List.iter @@ -2738,7 +2789,7 @@ let write_uefi_certificates_to_disk ~__context ~host = ["KEK.auth"; "db.auth"] |> List.iter (fun cert -> let log_of found = - (if found then info else error) + (if found then info else warn) "check_valid_uefi_certs: %s %s in %s" (if found then "found" else "missing") cert path @@ -2790,6 +2841,7 @@ let set_uefi_certificates ~__context ~host:_ ~value:_ = let set_iscsi_iqn ~__context ~host ~value = if value = "" then raise Api_errors.(Server_error (invalid_value, ["value"; value])) ; + D.debug "%s: iqn=%S" __FUNCTION__ value ; (* Note, the following sequence is carefully written - see the other-config watcher thread in xapi_host_helpers.ml *) Db.Host.remove_from_other_config ~__context ~self:host ~key:"iscsi_iqn" ; @@ -2802,7 +2854,7 @@ let set_iscsi_iqn ~__context ~host ~value = * when you update the `iscsi_iqn` field we want to update `other_config`, * but when updating `other_config` we want to update `iscsi_iqn` too. * we have to be careful not to introduce an infinite loop of updates. - * *) + *) Db.Host.set_iscsi_iqn ~__context ~self:host ~value ; Db.Host.add_to_other_config ~__context ~self:host ~key:"iscsi_iqn" ~value ; Xapi_host_helpers.Configuration.set_initiator_name value @@ -3055,7 +3107,7 @@ let apply_updates ~__context ~self ~hash = if Db.Pool.get_ha_enabled ~__context ~self:pool then raise Api_errors.(Server_error (ha_is_enabled, [])) ; if Db.Host.get_enabled ~__context ~self then ( - disable ~__context ~host:self ; + disable ~__context ~host:self ~auto_enable:true ; Xapi_host_helpers.update_allowed_operations ~__context ~self ) ; Xapi_host_helpers.with_host_operation ~__context ~self @@ -3084,13 +3136,17 @@ let cc_prep () = true let set_https_only ~__context ~self ~value = - let state = match value with true -> "close" | false -> "open" in match cc_prep () with | false -> - ignore - @@ Helpers.call_script - !Xapi_globs.firewall_port_config_script - [state; "80"] ; + let status = + match value with true -> Firewall.Disabled | false -> Firewall.Enabled + in + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Http status ; Db.Host.set_https_only ~__context ~self ~value | true when value = Db.Host.get_https_only ~__context ~self -> (* the new value is the same as the old value *) @@ -3110,22 +3166,269 @@ let emergency_clear_mandatory_guidance ~__context = ) ; Db.Host.set_pending_guidances ~__context ~self ~value:[] +let set_ssh_auto_mode ~__context ~self ~value = + debug "Setting SSH auto mode for host %s to %B" + (Helpers.get_localhost_uuid ()) + value ; + + Db.Host.set_ssh_auto_mode ~__context ~self ~value ; + + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + try + (* When enabled, the ssh_monitor_service regularly checks XAPI status to manage SSH availability. + During normal operation when XAPI is running properly, SSH is automatically disabled. + SSH is only enabled during emergency scenarios + (e.g., when XAPI is down) to allow administrative access for troubleshooting. *) + if value then ( + (* Ensure SSH is always enabled when SSH auto mode is on*) + Fw.update_firewall_status Firewall.Ssh Firewall.Enabled ; + Xapi_systemctl.enable ~wait_until_success:false !Xapi_globs.ssh_service ; + Xapi_systemctl.enable ~wait_until_success:false + !Xapi_globs.ssh_monitor_service ; + Xapi_systemctl.start ~wait_until_success:false + !Xapi_globs.ssh_monitor_service + ) else ( + Xapi_systemctl.stop ~wait_until_success:false + !Xapi_globs.ssh_monitor_service ; + Xapi_systemctl.disable ~wait_until_success:false + !Xapi_globs.ssh_monitor_service ; + Fw.update_firewall_status Firewall.Ssh Firewall.Disabled + ) + with e -> + error "Failed to configure SSH auto mode: %s" (Printexc.to_string e) ; + Helpers.internal_error "Failed to configure SSH auto mode: %s" + (Printexc.to_string e) + +let disable_ssh_internal ~__context ~self = + try + debug "Disabling SSH for host %s" (Helpers.get_localhost_uuid ()) ; + if not (Db.Host.get_ssh_auto_mode ~__context ~self) then + Xapi_systemctl.disable ~wait_until_success:false !Xapi_globs.ssh_service ; + Xapi_systemctl.stop ~wait_until_success:false !Xapi_globs.ssh_service ; + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Ssh Firewall.Disabled ; + Db.Host.set_ssh_enabled ~__context ~self ~value:false + with e -> + error "Failed to disable SSH for host %s: %s" (Ref.string_of self) + (Printexc.to_string e) ; + Helpers.internal_error "Failed to disable SSH access, host: %s" + (Ref.string_of self) + +let set_expiry ~__context ~self ~timeout = + let expiry_time = + match + Ptime.add_span (Ptime_clock.now ()) + (Ptime.Span.of_int_s (Int64.to_int timeout)) + with + | None -> + error "Invalid SSH timeout: %Ld" timeout ; + raise + (Api_errors.Server_error + ( Api_errors.invalid_value + , ["ssh_enabled_timeout"; Int64.to_string timeout] + ) + ) + | Some t -> + Ptime.to_float_s t |> Date.of_unix_time + in + Db.Host.set_ssh_expiry ~__context ~self ~value:expiry_time + +let schedule_disable_ssh_job ~__context ~self ~timeout ~auto_mode = + let host_uuid = Helpers.get_localhost_uuid () in + + debug "Scheduling SSH disable job for host %s with timeout %Ld seconds" + host_uuid timeout ; + + (* Remove any existing job first *) + Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue + !Xapi_globs.job_for_disable_ssh ; + + Xapi_stdext_threads_scheduler.Scheduler.add_to_queue + !Xapi_globs.job_for_disable_ssh + Xapi_stdext_threads_scheduler.Scheduler.OneShot (Int64.to_float timeout) + (fun () -> + disable_ssh_internal ~__context ~self ; + (* re-enable SSH auto mode if it was enabled before calling host.enable_ssh *) + if auto_mode then + set_ssh_auto_mode ~__context ~self ~value:true + ) + let enable_ssh ~__context ~self = try - Xapi_systemctl.enable ~wait_until_success:false "sshd" ; - Xapi_systemctl.start ~wait_until_success:false "sshd" - with _ -> - raise - (Api_errors.Server_error - (Api_errors.enable_ssh_failed, [Ref.string_of self]) - ) + debug "Enabling SSH for host %s" (Helpers.get_localhost_uuid ()) ; + + let cached_ssh_auto_mode = Db.Host.get_ssh_auto_mode ~__context ~self in + (* Disable SSH auto mode when SSH is enabled manually *) + set_ssh_auto_mode ~__context ~self ~value:false ; + + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Ssh Firewall.Enabled ; + Xapi_systemctl.enable ~wait_until_success:false !Xapi_globs.ssh_service ; + Xapi_systemctl.start ~wait_until_success:false !Xapi_globs.ssh_service ; + + let timeout = Db.Host.get_ssh_enabled_timeout ~__context ~self in + ( match timeout with + | 0L -> + Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue + !Xapi_globs.job_for_disable_ssh ; + Db.Host.set_ssh_expiry ~__context ~self ~value:Date.epoch + | t -> + set_expiry ~__context ~self ~timeout:t ; + schedule_disable_ssh_job ~__context ~self ~timeout:t + ~auto_mode:cached_ssh_auto_mode + ) ; + + Db.Host.set_ssh_enabled ~__context ~self ~value:true + with e -> + error "Failed to enable SSH on host %s: %s" (Ref.string_of self) + (Printexc.to_string e) ; + Helpers.internal_error "Failed to enable SSH access, host: %s" + (Ref.string_of self) let disable_ssh ~__context ~self = + Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue + !Xapi_globs.job_for_disable_ssh ; + disable_ssh_internal ~__context ~self ; + Db.Host.set_ssh_expiry ~__context ~self ~value:(Date.now ()) + +let set_ssh_enabled_timeout ~__context ~self ~value = + let validate_timeout value = + (* the max timeout is two days: 172800L = 2*24*60*60 *) + if value < 0L || value > 172800L then + raise + (Api_errors.Server_error + ( Api_errors.invalid_value + , ["ssh_enabled_timeout"; Int64.to_string value] + ) + ) + in + validate_timeout value ; + debug "Setting SSH timeout for host %s to %Ld seconds" + (Db.Host.get_uuid ~__context ~self) + value ; + Db.Host.set_ssh_enabled_timeout ~__context ~self ~value ; + if Db.Host.get_ssh_enabled ~__context ~self then + match value with + | 0L -> + Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue + !Xapi_globs.job_for_disable_ssh ; + Db.Host.set_ssh_expiry ~__context ~self ~value:Date.epoch + | t -> + set_expiry ~__context ~self ~timeout:t ; + schedule_disable_ssh_job ~__context ~self ~timeout:t ~auto_mode:false + +let set_console_idle_timeout ~__context ~self ~value = + let assert_timeout_valid timeout = + if timeout < 0L then + raise + (Api_errors.Server_error + ( Api_errors.invalid_value + , ["console_timeout"; Int64.to_string timeout] + ) + ) + in + + assert_timeout_valid value ; try - Xapi_systemctl.disable ~wait_until_success:false "sshd" ; - Xapi_systemctl.stop ~wait_until_success:false "sshd" - with _ -> - raise - (Api_errors.Server_error - (Api_errors.disable_ssh_failed, [Ref.string_of self]) + let content = + match value with + | 0L -> + "# Console timeout is disabled\n" + | timeout -> + Printf.sprintf "# Console timeout configuration\nexport TMOUT=%Ld\n" + timeout + in + + Unixext.atomic_write_to_file !Xapi_globs.console_timeout_profile_path 0o0644 + (fun fd -> + Unix.write fd (Bytes.of_string content) 0 (String.length content) + |> ignore + ) ; + + Db.Host.set_console_idle_timeout ~__context ~self ~value + with e -> + error "Failed to configure console timeout: %s" (Printexc.to_string e) ; + Helpers.internal_error "Failed to set console timeout: %Ld: %s" value + (Printexc.to_string e) + +let get_tracked_user_agents ~__context ~self = + let _ : [`host] Ref.t = self in + Xapi_tracked_user_agents.get () + +let get_nbd_interfaces ~__context ~self = + let pifs = Db.Host.get_PIFs ~__context ~self in + let allowed_connected_networks = + (* We use Valid_ref_list to continue processing the list in case some + network refs are null or invalid *) + Valid_ref_list.filter_map + (fun pif -> + let network = Db.PIF.get_network ~__context ~self:pif in + let purpose = Db.Network.get_purpose ~__context ~self:network in + if List.mem `nbd purpose || List.mem `insecure_nbd purpose then + Some network + else + None ) + pifs + in + let interfaces = + List.map + (fun network -> Db.Network.get_bridge ~__context ~self:network) + allowed_connected_networks + in + Xapi_stdext_std.Listext.List.setify interfaces + +let update_firewalld_service_status ~__context = + let open Firewall in + let enable_firewalld_service service = + try Firewalld.update_firewall_status service Enabled with _ -> () + in + match !Xapi_globs.firewall_backend with + | Firewalld -> + let self = Helpers.get_localhost ~__context in + let is_enabled = function + | Dlm -> + Xapi_clustering.Daemon.is_enabled () + | Http -> + not (Db.Host.get_https_only ~__context ~self) + | Nbd -> + get_nbd_interfaces ~__context ~self <> [] + | Ssh -> + Db.Host.get_ssh_enabled ~__context ~self + | Vxlan -> + List.exists + (fun tunnel -> + Db.PIF.get_currently_attached ~__context + ~self:(Db.Tunnel.get_access_PIF ~__context ~self:tunnel) + ) + (Db.Tunnel.get_all ~__context) + | Xenha -> + (* Only xha needs to enable firewalld service. Other HA cluster + stacks don't need. *) + let is_armed () = + Localdb.get_bool Constants.ha_armed |> Option.value ~default:false + in + let uses_xhad () = + Localdb.get Constants.ha_cluster_stack + |> Option.value ~default:!Xapi_globs.cluster_stack_default + = Constants.Ha_cluster_stack.(to_string Xhad) + in + is_armed () && uses_xhad () + in + List.iter + (fun s -> if is_enabled s then enable_firewalld_service s) + all_service_types + | Iptables -> + debug "No need to update firewalld service status when using iptables" diff --git a/ocaml/xapi/xapi_host.mli b/ocaml/xapi/xapi_host.mli index e1dc46c91a..316ee9f6ed 100644 --- a/ocaml/xapi/xapi_host.mli +++ b/ocaml/xapi/xapi_host.mli @@ -79,7 +79,8 @@ val restart_agent : __context:'a -> host:'b -> unit val shutdown_agent : __context:Context.t -> unit -val disable : __context:Context.t -> host:[`host] Ref.t -> unit +val disable : + __context:Context.t -> host:[`host] Ref.t -> auto_enable:bool -> unit val enable : __context:Context.t -> host:[`host] Ref.t -> unit @@ -130,6 +131,13 @@ val create : -> ssl_legacy:bool -> last_software_update:API.datetime -> last_update_hash:string + -> ssh_enabled:bool + -> ssh_enabled_timeout:int64 + -> ssh_expiry:API.datetime + -> console_idle_timeout:int64 + -> ssh_auto_mode:bool + -> secure_boot:bool + -> software_version:(string * string) list -> [`host] Ref.t val destroy : __context:Context.t -> self:API.ref_host -> unit @@ -200,7 +208,7 @@ val get_system_status_capabilities : __context:Context.t -> host:API.ref_host -> string val get_diagnostic_timing_stats : - __context:Context.t -> host:'b -> (string * string) list + __context:Context.t -> host:'b -> counts:bool -> (string * string) list val set_hostname_live : __context:Context.t -> host:[`host] Ref.t -> hostname:string -> unit @@ -567,3 +575,35 @@ val emergency_clear_mandatory_guidance : __context:Context.t -> unit val enable_ssh : __context:Context.t -> self:API.ref_host -> unit val disable_ssh : __context:Context.t -> self:API.ref_host -> unit + +val set_ssh_enabled_timeout : + __context:Context.t -> self:API.ref_host -> value:int64 -> unit + +val set_console_idle_timeout : + __context:Context.t -> self:API.ref_host -> value:int64 -> unit + +val schedule_disable_ssh_job : + __context:Context.t + -> self:API.ref_host + -> timeout:int64 + -> auto_mode:bool + -> unit + +val set_ssh_auto_mode : + __context:Context.t -> self:API.ref_host -> value:bool -> unit + +val get_tracked_user_agents : + __context:Context.t -> self:API.ref_host -> (string * string) list + +val get_nbd_interfaces : __context:Context.t -> self:API.ref_host -> string list + +val update_firewalld_service_status : __context:Context.t -> unit +(* Update the status of all the firewalld services to match the state of the + corresponding services. + This function is used in 2 scenarios: + 1. When xapi starts, to ensure that all the firewalld services are in the + correct state. + 2. When the firewalld restarts, all firewalld services are reset to the + default status. This function should be called to update these firewalld + services to the correct status. Xapi will expose an xe command line for + this scenario. *) diff --git a/ocaml/xapi/xapi_host_crashdump.ml b/ocaml/xapi/xapi_host_crashdump.ml index 645e1e6fc3..b7e9eedd74 100644 --- a/ocaml/xapi/xapi_host_crashdump.ml +++ b/ocaml/xapi/xapi_host_crashdump.ml @@ -71,8 +71,8 @@ let resynchronise ~__context ~host = let gone_away = Listext.List.set_difference db_filenames real_filenames and arrived = Listext.List.set_difference real_filenames db_filenames in let was_shutdown_cleanly = - try bool_of_string (Localdb.get Constants.host_restarted_cleanly) - with _ -> false + Localdb.get_bool Constants.host_restarted_cleanly + |> Option.value ~default:false in Localdb.put Constants.host_restarted_cleanly "false" ; (* If HA is enabled AND no crashdump appeared AND we weren't shutdown cleanly then assume it was a fence. *) @@ -149,5 +149,6 @@ let destroy ~__context ~self = let upload ~__context ~self ~url ~options = let filename = Db.Host_crashdump.get_filename ~__context ~self in - let url = if url = "" then upload_url filename else url in + if url = "" then + raise Api_errors.(Server_error (invalid_value, ["url"; ""])) ; do_upload "host-crash-upload" (crash_dir ^ "/" ^ filename) url options diff --git a/ocaml/xapi/xapi_host_driver_tool.ml b/ocaml/xapi/xapi_host_driver_tool.ml index 80fe5d208b..0dd837dda4 100644 --- a/ocaml/xapi/xapi_host_driver_tool.ml +++ b/ocaml/xapi/xapi_host_driver_tool.ml @@ -243,6 +243,15 @@ module Mock = struct set -o errexit set -o pipefail +function deselect { + cat <&2 #>&2 redirects error message to stderr exit 1 @@ -656,6 +670,11 @@ if $s_flag; then selection "$n_value" "$v_value" exit 0 fi + +if [ -n "$d_value" ]; then + deselect "$d_value" + exit 0 +fi |} let install () = diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 834b34beb4..2a40426483 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -31,7 +31,7 @@ let all_operations = API.host_allowed_operations__all (** Returns a table of operations -> API error options (None if the operation would be ok) *) let valid_operations ~__context record _ref' = let _ref = Ref.string_of _ref' in - let current_ops = List.map snd record.Db_actions.host_current_operations in + let current_ops = record.Db_actions.host_current_operations in let table = Hashtbl.create 10 in List.iter (fun x -> Hashtbl.replace table x None) all_operations ; let set_errors (code : string) (params : string list) @@ -49,40 +49,53 @@ let valid_operations ~__context record _ref' = let is_creating_new x = List.mem x [`provision; `vm_resume; `vm_migrate] in let is_removing x = List.mem x [`evacuate; `reboot; `shutdown] in let creating_new = - List.fold_left (fun acc op -> acc || is_creating_new op) false current_ops - in - let removing = - List.fold_left (fun acc op -> acc || is_removing op) false current_ops + List.find_opt (fun (_, op) -> is_creating_new op) current_ops in + let removing = List.find_opt (fun (_, op) -> is_removing op) current_ops in List.iter (fun op -> - if (is_creating_new op && removing) || (is_removing op && creating_new) - then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string (List.hd current_ops)] - [op] + match (is_creating_new op, removing, is_removing op, creating_new) with + | true, Some (op_ref, op_type), _, _ | _, _, true, Some (op_ref, op_type) + -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string op_type; op_ref] + [op] + | _ -> + () ) (List.filter (fun x -> x <> `power_on) all_operations) ; (* reboot, shutdown and apply_updates cannot run concurrently *) - if List.mem `reboot current_ops then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string `reboot] - [`shutdown; `apply_updates] ; - if List.mem `shutdown current_ops then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string `shutdown] - [`reboot; `apply_updates] ; - if List.mem `apply_updates current_ops then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string `apply_updates] - [`reboot; `shutdown; `enable] ; + Option.iter + (fun (op_ref, _op_type) -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string `reboot; op_ref] + [`shutdown; `apply_updates] + ) + (List.find_opt (fun (_, op) -> op = `reboot) current_ops) ; + Option.iter + (fun (op_ref, _op_type) -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string `shutdown; op_ref] + [`reboot; `apply_updates] + ) + (List.find_opt (fun (_, op) -> op = `shutdown) current_ops) ; + Option.iter + (fun (op_ref, _op_type) -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string `apply_updates; op_ref] + [`reboot; `shutdown; `enable] + ) + (List.find_opt (fun (_, op) -> op = `apply_updates) current_ops) ; (* Prevent more than one provision happening at a time to prevent extreme dom0 load (in the case of the debian template). Once the template becomes a 'real' template we can relax this. *) - if List.mem `provision current_ops then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string `provision] - [`provision] ; + Option.iter + (fun (op_ref, _op_type) -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string `provision; op_ref] + [`provision] + ) + (List.find_opt (fun (_, op) -> op = `provision) current_ops) ; (* The host must be disabled before reboots or shutdowns are permitted *) if record.Db_actions.host_enabled then set_errors Api_errors.host_not_disabled [] @@ -168,20 +181,24 @@ let assert_operation_valid ~__context ~self ~(op : API.host_allowed_operations) throw_error table op let update_allowed_operations ~__context ~self : unit = - let all = Db.Host.get_record_internal ~__context ~self in - let valid = valid_operations ~__context all self in - let keys = - Hashtbl.fold (fun k v acc -> if v = None then k :: acc else acc) valid [] - in - (* CA-18377: If there's a rolling upgrade in progress, only send Miami keys across the wire. *) - let keys = - if Helpers.rolling_upgrade_in_progress ~__context then - Xapi_stdext_std.Listext.List.intersect keys - Xapi_globs.host_operations_miami - else - keys - in - Db.Host.set_allowed_operations ~__context ~self ~value:keys + try + (* This might fail if the coordinator has been updated *) + let all = Db.Host.get_record_internal ~__context ~self in + let valid = valid_operations ~__context all self in + let keys = + Hashtbl.fold (fun k v acc -> if v = None then k :: acc else acc) valid [] + in + (* CA-18377: If there's a rolling upgrade in progress, only send Miami keys across the wire. *) + let keys = + if Helpers.rolling_upgrade_in_progress ~__context then + Xapi_stdext_std.Listext.List.intersect keys + Xapi_globs.host_operations_miami + else + keys + in + Db.Host.set_allowed_operations ~__context ~self ~value:keys + with e -> + error "Failed to update host.allowed_operations: %s" (Printexc.to_string e) let update_allowed_operations_all_hosts ~__context : unit = let hosts = Db.Host.get_all ~__context in @@ -367,7 +384,7 @@ let consider_enabling_host_nolock ~__context = Disabled hosts are excluded from the HA planning calculations. Otherwise a host may boot, fail to plug in a PBD and cause all protected VMs to suddenly become non-agile. *) let ha_enabled = - try bool_of_string (Localdb.get Constants.ha_armed) with _ -> false + Localdb.get_bool Constants.ha_armed |> Option.value ~default:false in let localhost = Helpers.get_localhost ~__context in let pbds = Db.Host.get_PBDs ~__context ~self:localhost in @@ -409,21 +426,36 @@ let consider_enabling_host_nolock ~__context = else f () in + let host_auto_enable = + Localdb.get_bool Constants.host_auto_enable |> Option.value ~default:true + in if !Xapi_globs.on_system_boot then ( debug "Host.enabled: system has just restarted" ; if_no_pending_guidances (fun () -> debug "Host.enabled: system has just restarted and no pending mandatory \ - guidances: setting localhost to enabled" ; - Db.Host.set_enabled ~__context ~self:localhost ~value:true ; - update_allowed_operations ~__context ~self:localhost ; + guidances: clearing host_disabled_until_reboot" ; Localdb.put Constants.host_disabled_until_reboot "false" ; - (* Start processing pending VM powercycle events *) - Local_work_queue.start_vm_lifecycle_queue () + + (* If the host was persistently disabled, honour it *) + if host_auto_enable then ( + debug + "Host.enabled: system has just restarted, no pending mandatory \ + guidances and host_auto_enable=true: setting localhost to \ + enabled" ; + Db.Host.set_enabled ~__context ~self:localhost ~value:true ; + update_allowed_operations ~__context ~self:localhost ; + (* Start processing pending VM powercycle events *) + Local_work_queue.start_vm_lifecycle_queue () + ) else + debug + "Host.enabled: system has just restarted, no pending mandatory \ + guidances, but host_auto_enable=false: Leaving host disabled \ + until manually re-enabled by the user" ) ) else if - try bool_of_string (Localdb.get Constants.host_disabled_until_reboot) - with _ -> false + Localdb.get_bool Constants.host_disabled_until_reboot + |> Option.value ~default:false then debug "Host.enabled: system not just rebooted but host_disabled_until_reboot \ @@ -433,14 +465,22 @@ let consider_enabling_host_nolock ~__context = "Host.enabled: system not just rebooted && host_disabled_until_reboot \ not set" ; if_no_pending_guidances (fun () -> - debug - "Host.enabled: system not just rebooted && \ - host_disabled_until_reboot not set and no pending mandatory \ - guidances: setting localhost to enabled" ; - Db.Host.set_enabled ~__context ~self:localhost ~value:true ; - update_allowed_operations ~__context ~self:localhost ; - (* Start processing pending VM powercycle events *) - Local_work_queue.start_vm_lifecycle_queue () + if host_auto_enable then ( + debug + "Host.enabled: system not just rebooted && \ + host_disabled_until_reboot not set and no pending mandatory \ + guidances and host_auto_enable=true: setting localhost to \ + enabled" ; + Db.Host.set_enabled ~__context ~self:localhost ~value:true ; + update_allowed_operations ~__context ~self:localhost ; + (* Start processing pending VM powercycle events *) + Local_work_queue.start_vm_lifecycle_queue () + ) else + debug + "Host.enabled: system not just rebooted && \ + host_disabled_until_reboot not set and no pending mandatory \ + guidances but host_auto_enable=false: Leaving host disabled \ + until manually re-enabled by the user" ) ) ; (* If Host has been enabled and HA is also enabled then tell the master to recompute its plan *) @@ -497,10 +537,13 @@ module Configuration = struct [iqn; hostname_chopped] let set_initiator_name iqn = + if iqn = "" then + raise Api_errors.(Server_error (invalid_value, ["iqn"; iqn])) ; let hostname = Unix.gethostname () in (* CA-377454 - robustness, create dir if necessary *) Unixext.mkdir_rec "/var/lock/sm/iscsiadm" 0o700 ; let args = make_set_initiator_args iqn hostname in + D.debug "%s: iqn=%S" __FUNCTION__ iqn ; ignore (Helpers.call_script !Xapi_globs.set_iSCSI_initiator_script args) let set_multipathing enabled = @@ -541,6 +584,7 @@ module Configuration = struct | Some "" -> () | Some iqn when iqn <> host_rec.API.host_iscsi_iqn -> + D.debug "%s: iqn=%S" __FUNCTION__ iqn ; Client.Client.Host.set_iscsi_iqn ~rpc ~session_id ~host:host_ref ~value:iqn | _ -> diff --git a/ocaml/xapi/xapi_host_helpers.mli b/ocaml/xapi/xapi_host_helpers.mli index 519aa34a56..84cc271c65 100644 --- a/ocaml/xapi/xapi_host_helpers.mli +++ b/ocaml/xapi/xapi_host_helpers.mli @@ -79,7 +79,8 @@ val consider_enabling_host : __context:Context.t -> unit {ul {- the user asked the host to be disabled and there was a problem} {- HA is enabled and one-or-more PBDs failed to plug} - {- `disabled_until_next_reboot` is set in the local DB}} + {- `host_disabled_until_reboot` is set in the local DB and the system + hasn't just booted up}} *) val consider_enabling_host_request : __context:Context.t -> unit diff --git a/ocaml/xapi/xapi_local_session.ml b/ocaml/xapi/xapi_local_session.ml index e356ae8725..709275077b 100644 --- a/ocaml/xapi/xapi_local_session.ml +++ b/ocaml/xapi/xapi_local_session.ml @@ -31,12 +31,9 @@ let create ~__context ~pool = with_lock m (fun () -> Hashtbl.replace table r session) ; r -let get_record ~__context ~self = with_lock m (fun () -> Hashtbl.find table self) +let has_record ~__context ~self = with_lock m (fun () -> Hashtbl.mem table self) let destroy ~__context ~self = with_lock m (fun () -> Hashtbl.remove table self) let local_session_hook ~__context ~session_id = - try - ignore (get_record ~__context ~self:session_id) ; - true - with _ -> false + has_record ~__context ~self:session_id diff --git a/ocaml/xapi/xapi_local_session.mli b/ocaml/xapi/xapi_local_session.mli index ca8c181001..8e7c4d31bc 100644 --- a/ocaml/xapi/xapi_local_session.mli +++ b/ocaml/xapi/xapi_local_session.mli @@ -19,8 +19,6 @@ val get_all : __context:Context.t -> API.ref_session list val create : __context:Context.t -> pool:bool -> API.ref_session -val get_record : __context:Context.t -> self:API.ref_session -> t - val destroy : __context:Context.t -> self:API.ref_session -> unit val local_session_hook : diff --git a/ocaml/xapi/xapi_message.ml b/ocaml/xapi/xapi_message.ml index 408ba7acf0..5eb5b09764 100644 --- a/ocaml/xapi/xapi_message.ml +++ b/ocaml/xapi/xapi_message.ml @@ -28,7 +28,7 @@ *) module Date = Clock.Date -module Encodings = Xapi_stdext_encodings.Encodings +module Encodings = Xapi_stdext_encodings module Listext = Xapi_stdext_std.Listext module Pervasiveext = Xapi_stdext_pervasives.Pervasiveext module Unixext = Xapi_stdext_unix.Unixext @@ -414,7 +414,7 @@ let create ~__context ~name ~priority ~cls ~obj_uuid ~body = debug "Message.create %s %Ld %s %s" name priority (Record_util.cls_to_string cls) obj_uuid ; - if not (Encodings.UTF8_XML.is_valid body) then + if not (Encodings.Utf8.is_valid body) then raise (Api_errors.Server_error (Api_errors.invalid_value, ["UTF8 expected"])) ; if not (check_uuid ~__context ~cls ~uuid:obj_uuid) then raise @@ -837,7 +837,7 @@ let handler (req : Http.Request.t) fd _ = Uri.( make ~scheme:"https" ~host:(Pool_role.get_master_address ()) - ~path:req.Http.Request.uri + ~path:req.Http.Request.path ~query:(List.map (fun (k, v) -> (k, [v])) req.Http.Request.query) () |> to_string diff --git a/ocaml/xapi/xapi_observer.ml b/ocaml/xapi/xapi_observer.ml index 404c4496f2..2ed022aac4 100644 --- a/ocaml/xapi/xapi_observer.ml +++ b/ocaml/xapi/xapi_observer.ml @@ -48,10 +48,14 @@ module type ObserverInterface = sig val set_export_interval : __context:Context.t -> interval:float -> unit + val set_export_chunk_size : __context:Context.t -> size:int -> unit + val set_max_spans : __context:Context.t -> spans:int -> unit val set_max_traces : __context:Context.t -> traces:int -> unit + val set_max_depth : __context:Context.t -> depth:int -> unit + val set_max_file_size : __context:Context.t -> file_size:int -> unit val set_host_id : __context:Context.t -> host_id:string -> unit @@ -61,56 +65,64 @@ end module Observer : ObserverInterface = struct let create ~__context ~uuid ~name_label ~attributes ~endpoints ~enabled = - debug "Observer.create %s" uuid ; + debug "xapi Observer.create %s" uuid ; Tracing.TracerProvider.create ~uuid ~name_label ~attributes ~endpoints ~enabled let destroy ~__context ~uuid = - debug "Observer.destroy %s" uuid ; + debug "xapi Observer.destroy %s" uuid ; Tracing.TracerProvider.destroy ~uuid let set_enabled ~__context ~uuid ~enabled = - debug "Observer.set_enabled %s" uuid ; + debug "xapi Observer.set_enabled %s" uuid ; Tracing.TracerProvider.set ~uuid ~enabled () let set_attributes ~__context ~uuid ~attributes = - debug "Observer.set_attributes %s" uuid ; + debug "xapi Observer.set_attributes %s" uuid ; Tracing.TracerProvider.set ~uuid ~attributes () let set_endpoints ~__context ~uuid ~endpoints = - debug "Observer.set_endpoints %s" uuid ; + debug "xapi Observer.set_endpoints %s" uuid ; Tracing.TracerProvider.set ~uuid ~endpoints () let init ~__context = - debug "Observer.init" ; + debug "xapi Observer.init" ; ignore @@ Tracing_export.main () let set_trace_log_dir ~__context ~dir = - debug "Observer.set_trace_log_dir" ; + debug "xapi Observer.set_trace_log_dir" ; Tracing_export.Destination.File.set_trace_log_dir dir let set_export_interval ~__context ~interval = - debug "Observer.set_export_interval" ; + debug "xapi Observer.set_export_interval" ; Tracing_export.set_export_interval interval + let set_export_chunk_size ~__context ~size = + debug "xapi Observer.set_export_chunk_size" ; + Tracing_export.set_export_chunk_size size + let set_max_spans ~__context ~spans = - debug "Observer.set_max_spans" ; + debug "xapi Observer.set_max_spans" ; Tracing.Spans.set_max_spans spans let set_max_traces ~__context ~traces = - debug "Observer.set_max_traces" ; + debug "xapi Observer.set_max_traces" ; Tracing.Spans.set_max_traces traces + let set_max_depth ~__context ~depth = + debug "xapi Observer.set_max_depth" ; + Tracing.Spans.set_max_depth depth + let set_max_file_size ~__context ~file_size = - debug "Observer.set_max_file_size" ; + debug "xapi Observer.set_max_file_size" ; Tracing_export.Destination.File.set_max_file_size file_size let set_host_id ~__context ~host_id = - debug "Observer.set_host_id" ; + debug "xapi Observer.set_host_id" ; Tracing_export.set_host_id host_id let set_compress_tracing_files ~__context ~enabled = - debug "Observer.set_compress_tracing_files" ; + debug "xapi Observer.set_compress_tracing_files" ; Tracing_export.Destination.File.set_compress_tracing_files enabled end @@ -142,95 +154,110 @@ module Xapi_cluster = struct module Observer = struct let create ~__context ~uuid ~name_label ~attributes ~endpoints ~enabled = - debug "Observer.create %s" uuid ; + debug "xapi_cluster Observer.create %s" uuid ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.create dbg uuid name_label attributes endpoints enabled let destroy ~__context ~uuid = - debug "Observer.destroy %s" uuid ; + debug "xapi_cluster Observer.destroy %s" uuid ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.destroy dbg uuid let set_enabled ~__context ~uuid ~enabled = - debug "Observer.set_enabled %s" uuid ; + debug "xapi_cluster Observer.set_enabled %s" uuid ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_enabled dbg uuid enabled let set_attributes ~__context ~uuid ~attributes = - debug "Observer.set_attributes %s" uuid ; + debug "xapi_cluster Observer.set_attributes %s" uuid ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_attributes dbg uuid attributes let set_endpoints ~__context ~uuid ~endpoints = - debug "Observer.set_endpoints %s" uuid ; + debug "xapi_cluster Observer.set_endpoints %s" uuid ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_endpoints dbg uuid endpoints let init ~__context = - debug "Observer.init" ; + debug "xapi_cluster Observer.init" ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.init dbg let set_trace_log_dir ~__context ~dir = - debug "Observer.set_trace_log_dir" ; + debug "xapi_cluster Observer.set_trace_log_dir" ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_trace_log_dir dbg dir let set_export_interval ~__context ~interval = - debug "Observer.set_export_interval" ; + debug "xapi_cluster Observer.set_export_interval" ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_export_interval dbg interval + let set_export_chunk_size ~__context ~size = + debug "xapi_cluster Observer.set_export_chunk_size" ; + let module S = (val local_client ~__context : XAPI_CLUSTER) in + let dbg = Context.string_of_task __context in + S.Observer.set_export_chunk_size dbg size + let set_max_spans ~__context ~spans = - debug "Observer.set_max_spans" ; + debug "xapi_cluster Observer.set_max_spans" ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_max_spans dbg spans let set_max_traces ~__context ~traces = - debug "Observer.set_max_traces" ; + debug "xapi_cluster Observer.set_max_traces" ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_max_traces dbg traces + let set_max_depth ~__context ~depth = + debug "xapi_cluster Observer.set_max_depth" ; + let module S = (val local_client ~__context : XAPI_CLUSTER) in + let dbg = Context.string_of_task __context in + S.Observer.set_max_depth dbg depth + let set_max_file_size ~__context ~file_size = - debug "Observer.set_max_file_size" ; + debug "xapi_cluster Observer.set_max_file_size" ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_max_file_size dbg file_size let set_host_id ~__context ~host_id = - debug "Observer.set_host_id" ; + debug "xapi_cluster Observer.set_host_id" ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_host_id dbg host_id let set_compress_tracing_files ~__context ~enabled = - debug "Observer.set_compress_tracing_files" ; + debug "xapi_cluster Observer.set_compress_tracing_files" ; let module S = (val local_client ~__context : XAPI_CLUSTER) in let dbg = Context.string_of_task __context in S.Observer.set_compress_tracing_files dbg enabled end end -let default_attributes ~__context ~host ~name_label ~component = +let default_attributes ~__context ~host ~observer ~component = let pool = Helpers.get_pool ~__context in let host_label = Db.Host.get_name_label ~__context ~self:host in let host_uuid = Db.Host.get_uuid ~__context ~self:host in let pool_uuid = Db.Pool.get_uuid ~__context ~self:pool in + let name_label = Db.Observer.get_name_label ~__context ~self:observer in + let observer_uuid = Db.Observer.get_uuid ~__context ~self:observer in [ ("xs.pool.uuid", pool_uuid) ; ("xs.host.name", host_label) ; ("xs.host.uuid", host_uuid) ; ("xs.observer.name", name_label) + ; ("xs.observer.uuid", observer_uuid) ; ("service.name", to_string component) ] @@ -265,13 +292,12 @@ module ObserverConfig = struct from and updated instead of being regenerated. *) let endpoints = Db.Observer.get_endpoints ~__context ~self:observer in let host = Helpers.get_localhost ~__context in - let name_label = Db.Observer.get_name_label ~__context ~self:observer in { otel_service_name= to_string component ; otel_resource_attributes= attributes_to_W3CBaggage (Db.Observer.get_attributes ~__context ~self:observer - @ default_attributes ~__context ~host ~name_label ~component + @ default_attributes ~__context ~host ~observer ~component ) ; xs_exporter_zipkin_endpoints= zipkin_endpoints endpoints ; xs_exporter_bugtool_endpoint= bugtool_endpoint endpoints @@ -331,37 +357,53 @@ module Dom0ObserverConfig (ObserverComponent : OBSERVER_COMPONENT) : let create ~__context ~uuid ~name_label:_ ~attributes:_ ~endpoints:_ ~enabled:_ = + debug "%s config Observer.create" (to_string ObserverComponent.component) ; let observer = Db.Observer.get_by_uuid ~__context ~uuid in update_config ~__context ~observer ~uuid - let destroy ~__context ~uuid = remove_config ~uuid + let destroy ~__context ~uuid = + debug "%s config Observer.destroy" (to_string ObserverComponent.component) ; + remove_config ~uuid let set_enabled ~__context ~uuid ~enabled:_ = + debug "%s config Observer.set_enabled" + (to_string ObserverComponent.component) ; let observer = Db.Observer.get_by_uuid ~__context ~uuid in update_config ~__context ~observer ~uuid let set_attributes ~__context ~uuid ~attributes:_ = + debug "%s config Observer.set_attributes" + (to_string ObserverComponent.component) ; let observer = Db.Observer.get_by_uuid ~__context ~uuid in update_config ~__context ~observer ~uuid let set_endpoints ~__context ~uuid ~endpoints:_ = + debug "%s config Observer.set_endpoints" + (to_string ObserverComponent.component) ; let observer = Db.Observer.get_by_uuid ~__context ~uuid in update_config ~__context ~observer ~uuid let init ~__context = + debug "%s config Observer.init" (to_string ObserverComponent.component) ; let observer_all = Db.Observer.get_all ~__context in update_all_configs ~__context ~observer_all let set_trace_log_dir ~__context ~dir:_ = + debug "%s config Observer.set_trace_log_dir" + (to_string ObserverComponent.component) ; let observer_all = Db.Observer.get_all ~__context in update_all_configs ~__context ~observer_all let set_export_interval ~__context:_ ~interval:_ = () + let set_export_chunk_size ~__context:_ ~size:_ = () + let set_max_spans ~__context:_ ~spans:_ = () let set_max_traces ~__context:_ ~traces:_ = () + let set_max_depth ~__context:_ ~depth:_ = () + let set_max_file_size ~__context:_ ~file_size:_ = () let set_host_id ~__context:_ ~host_id:_ = () @@ -371,6 +413,30 @@ end module SMObserverConfig = Dom0ObserverConfig (struct let component = SMApi end) +module SMObserver = struct + include SMObserverConfig + open Observer_helpers + + let create ~__context ~uuid ~name_label ~attributes ~endpoints ~enabled = + debug "SMObserver Observer.create %s" uuid ; + SMObserverConfig.create ~__context ~uuid ~name_label ~attributes ~endpoints + ~enabled ; + let dbg = Context.string_of_task __context in + Client.create dbg uuid name_label attributes endpoints enabled + + let destroy ~__context ~uuid = + debug "SMObserver Observer.destroy %s" uuid ; + SMObserverConfig.destroy ~__context ~uuid ; + let dbg = Context.string_of_task __context in + Client.destroy dbg uuid + + let set_enabled ~__context ~uuid ~enabled = + debug "SMObserver Observer.set_enabled %s" uuid ; + SMObserverConfig.set_enabled ~__context ~uuid ~enabled ; + let dbg = Context.string_of_task __context in + Client.set_enabled dbg uuid enabled +end + let get_forwarder c = let module Forwarder = ( val match c with @@ -381,7 +447,7 @@ let get_forwarder c = | Xapi_clusterd -> (module Xapi_cluster.Observer) | SMApi -> - (module SMObserverConfig) + (module SMObserver) : ObserverInterface ) in @@ -449,11 +515,11 @@ let assert_valid_attributes attributes = attributes let register_component ~__context ~self ~host ~component = - let name_label = Db.Observer.get_name_label ~__context ~self in let attributes = - default_attributes ~__context ~host ~name_label ~component + default_attributes ~__context ~host ~observer:self ~component @ Db.Observer.get_attributes ~__context ~self in + let name_label = Db.Observer.get_name_label ~__context ~self in let uuid = Db.Observer.get_uuid ~__context ~self in let endpoints = Db.Observer.get_endpoints ~__context ~self in let enabled = Db.Observer.get_enabled ~__context ~self in @@ -506,6 +572,10 @@ let set_export_interval ~__context interval component = let module Forwarder = (val get_forwarder component : ObserverInterface) in Forwarder.set_export_interval ~__context ~interval +let set_export_chunk_size ~__context size component = + let module Forwarder = (val get_forwarder component : ObserverInterface) in + Forwarder.set_export_chunk_size ~__context ~size + let set_max_spans ~__context spans component = let module Forwarder = (val get_forwarder component : ObserverInterface) in Forwarder.set_max_spans ~__context ~spans @@ -514,6 +584,10 @@ let set_max_traces ~__context traces component = let module Forwarder = (val get_forwarder component : ObserverInterface) in Forwarder.set_max_traces ~__context ~traces +let set_max_depth ~__context depth component = + let module Forwarder = (val get_forwarder component : ObserverInterface) in + Forwarder.set_max_depth ~__context ~depth + let set_max_file_size ~__context file_size component = let module Forwarder = (val get_forwarder component : ObserverInterface) in Forwarder.set_max_file_size ~__context ~file_size @@ -549,8 +623,10 @@ let initialise_observer_component ~__context component = let initialise_observer_meta ~__context component = set_trace_log_dir ~__context !Xapi_globs.trace_log_dir component ; set_export_interval ~__context !Xapi_globs.export_interval component ; + set_export_chunk_size ~__context !Xapi_globs.export_chunk_size component ; set_max_spans ~__context !Xapi_globs.max_spans component ; set_max_traces ~__context !Xapi_globs.max_traces component ; + set_max_depth ~__context !Xapi_globs.max_span_depth component ; set_max_file_size ~__context !Xapi_globs.max_observer_file_size component ; set_host_id ~__context (Helpers.get_localhost_uuid ()) component ; set_compress_tracing_files ~__context @@ -617,14 +693,13 @@ let set_attributes ~__context ~self ~value = assert_valid_attributes value ; let uuid = Db.Observer.get_uuid ~__context ~self in let host = Helpers.get_localhost ~__context in - let name_label = Db.Observer.get_name_label ~__context ~self in let observation_fn () = List.iter (fun c -> let module Forwarder = (val get_forwarder c : ObserverInterface) in Forwarder.set_attributes ~__context ~uuid ~attributes: - (default_attributes ~__context ~host ~name_label ~component:c + (default_attributes ~__context ~host ~observer:self ~component:c @ value ) ) diff --git a/ocaml/xapi/xapi_pbd.ml b/ocaml/xapi/xapi_pbd.ml index a9625dc3c6..86d9b7fabc 100644 --- a/ocaml/xapi/xapi_pbd.ml +++ b/ocaml/xapi/xapi_pbd.ml @@ -114,13 +114,18 @@ let abort_if_storage_attached_to_protected_vms ~__context ~self = (fun vbd -> let vdi = Db.VBD.get_VDI ~__context ~self:vbd in if List.mem vdi vdis then ( - warn - "PBD.unplug will make protected VM %s not agile since it has a \ - VBD attached to VDI %s" - (Ref.string_of vm_ref) (Ref.string_of vdi) ; + let vm = Ref.string_of vm_ref in + let pbd = Ref.string_of self in + let sr = Ref.string_of sr in + info + "The protected VM %s must remain agile and blocked the \ + operation. The PBD %s of must be plugged to ensure this. This \ + happened because the SR %s is used by both the VM and the \ + PBD." + vm pbd sr ; raise - (Api_errors.Server_error - (Api_errors.ha_operation_would_break_failover_plan, []) + Api_errors.( + Server_error (ha_constraint_violation_sr_not_shared, [sr]) ) ) ) diff --git a/ocaml/xapi/xapi_periodic_scheduler_init.ml b/ocaml/xapi/xapi_periodic_scheduler_init.ml index 1bd13d5f6d..00680ae82e 100644 --- a/ocaml/xapi/xapi_periodic_scheduler_init.ml +++ b/ocaml/xapi/xapi_periodic_scheduler_init.ml @@ -13,6 +13,8 @@ *) (** Periodic scheduler for background tasks. *) +module Date = Clock.Date + module D = Debug.Make (struct let name = "backgroundscheduler" end) open D @@ -73,6 +75,37 @@ let register ~__context = (fun __context -> Xapi_subject.update_all_subjects ~__context ) in + let sync_ssh_status ~__context = + let self = Helpers.get_localhost ~__context in + let timeout = Db.Host.get_ssh_enabled_timeout ~__context ~self in + + if timeout > 0L then + let expiry_time = + Db.Host.get_ssh_expiry ~__context ~self + |> Date.to_unix_time + |> Int64.of_float + in + let current_time = Unix.time () |> Int64.of_float in + + if Int64.compare expiry_time current_time > 0 then + let remaining = Int64.sub expiry_time current_time in + Xapi_host.schedule_disable_ssh_job ~__context ~self ~timeout:remaining + ~auto_mode:true + (* Handle the case where XAPI is not active when the SSH timeout expires. + This typically occurs when XAPI has been down for an extended period that + exceeds the timeout duration. In this scenario, we need to enable SSH auto + mode to ensure the SSH service remains continuously available. *) + else if Fe_systemctl.is_active ~service:!Xapi_globs.ssh_service then ( + let module Fw = + ( val Firewall.firewall_provider !Xapi_globs.firewall_backend + : Firewall.FIREWALL + ) + in + Fw.update_firewall_status Firewall.Ssh Firewall.Disabled ; + Xapi_host.disable_ssh ~__context ~self ; + Xapi_host.set_ssh_auto_mode ~__context ~self ~value:true + ) + in let update_all_subjects_delay = 10.0 in (* initial delay = 10 seconds *) if master then @@ -133,6 +166,7 @@ let register ~__context = "Check stunnel cache expiry" (Xapi_stdext_threads_scheduler.Scheduler.Periodic stunnel_period) stunnel_period Stunnel_cache.gc ; + sync_ssh_status ~__context ; if master && Db.Pool.get_update_sync_enabled ~__context diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index 163e1f31d5..881c51091f 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -38,7 +38,112 @@ let get_device_pci ~__context ~host ~device = | _ -> Ref.null -let refresh_internal ~__context ~self = +let bridge_naming_convention (device : string) (pos_opt : int option) = + match pos_opt with + | Some index -> + "xenbr" ^ string_of_int index + | None -> + "br" ^ device + +type tables = { + device_to_position_table: (string * int) list + ; device_to_mac_table: (string * string) list + ; pif_to_device_table: (API.ref_PIF * string) list +} + +let get_physical_pif_device ~__context ~interface_tables ~pif_rec = + let dbg = Context.string_of_task __context in + let find_name_by_position position original_name = + match + List.find_map + (fun (name, pos) -> if pos = position then Some name else None) + interface_tables.device_to_position_table + with + | Some name -> + if name <> original_name then + info "PIF: device name changed from %s to %s" original_name name ; + name + | None -> ( + (* This clause should be unlikely to happen, if enter this, check the if + we can get mac from networkd. If yes there may be a bug *) + warn "PIF %s: no device found for position %d" original_name position ; + try + let mac = Net.Interface.get_mac dbg original_name in + error + "PIF %s: no device found for position %d, but get MAC address %s , \ + there may be a bug in networkd sorting." + original_name position mac ; + original_name + with _ -> original_name + ) + in + if pif_rec.API.pIF_physical then ( + match Xapi_pif_helpers.get_pif_position ~__context ~pif_rec with + | Some position -> + find_name_by_position position pif_rec.API.pIF_device + | None -> + info "PIF %s: no position found for this device" pif_rec.API.pIF_device ; + pif_rec.API.pIF_device + ) else + pif_rec.API.pIF_device + +(* For different pif types, get the proper device name + - Physical: maybe change, need to lookup device_to_position_table + - VLAN_untagged: get the underlying physical PIF device + - Network_sriov_logical: get the underlying physical PIF device + - Tunnel_access: tunnel, no need to change + - Bond_master: bond, no need to change +*) +let get_pif_device ~__context ~interface_tables ~pif_rec = + match Xapi_pif_helpers.get_pif_topo ~__context ~pif_rec with + | VLAN_untagged _ :: Network_sriov_logical _ :: Physical pif :: _ + | VLAN_untagged _ :: Physical pif :: _ + | Network_sriov_logical _ :: Physical pif :: _ + | Physical pif :: _ -> + get_physical_pif_device ~__context ~interface_tables ~pif_rec:pif + | _ -> + pif_rec.API.pIF_device + +let make_tables ~__context ~host = + let dbg = Context.string_of_task __context in + let device_to_position_table = Net.Interface.get_interface_positions dbg () in + let device_to_mac_table = + List.filter_map + (fun name -> + if Net.Interface.is_physical dbg name then + Some (name, Net.Interface.get_mac dbg name) + else + None + ) + (Net.Interface.get_all dbg ()) + in + (* Get all PIFs on this host *) + let pif_to_device_table = + Db.PIF.get_records_where ~__context + ~expr: + (And + ( Eq (Field "host", Literal (Ref.string_of host)) + , Eq (Field "physical", Literal "true") + ) + ) + |> List.map (fun (pref, prec) -> (pref, prec.API.pIF_device)) + in + debug "tables: device_to_position_table = %s" + (String.concat "; " + (List.map + (fun (d, p) -> d ^ ":" ^ string_of_int p) + device_to_position_table + ) + ) ; + debug "tables: device_to_mac_table = %s" + (String.concat "; " + (List.map (fun (d, m) -> d ^ ":" ^ m) device_to_mac_table) + ) ; + debug "tables: pif_to_device_table = %s" + (String.concat "; " (List.map snd pif_to_device_table)) ; + {device_to_position_table; device_to_mac_table; pif_to_device_table} + +let refresh_internal ~__context ~interface_tables ~self = let dbg = Context.string_of_task __context in let pif = Db.PIF.get_record ~__context ~self in let network = @@ -51,11 +156,16 @@ let refresh_internal ~__context ~self = pif.API.pIF_network in let bridge = Db.Network.get_bridge ~__context ~self:network in + (* Pif device name maybe change. Look up device_to_position table to get the + new device name. *) + let pif_device_name = + get_pif_device ~__context ~interface_tables ~pif_rec:pif + in (* Update the specified PIF field in the database, if - * and only if a corresponding value can be read from - * the underlying network device and if that value is - * different from the current field value. - *) + * and only if a corresponding value can be read from + * the underlying network device and if that value is + * different from the current field value. + *) let maybe_update_database field_name db_value set_field get_value print_value = Option.iter @@ -68,57 +178,42 @@ let refresh_internal ~__context ~self = ) (try Some (get_value ()) with _ -> None) in - if pif.API.pIF_physical then + maybe_update_database "device" pif.API.pIF_device Db.PIF.set_device + (fun () -> pif_device_name) + Fun.id ; + if pif.API.pIF_physical then ( maybe_update_database "MAC" pif.API.pIF_MAC Db.PIF.set_MAC - (fun () -> Net.Interface.get_mac dbg pif.API.pIF_device) - (fun x -> x) ; - maybe_update_database "PCI" pif.API.pIF_PCI Db.PIF.set_PCI - (fun () -> - get_device_pci ~__context ~host:pif.API.pIF_host - ~device:pif.API.pIF_device - ) - Ref.string_of ; - maybe_update_database "MTU" pif.API.pIF_MTU Db.PIF.set_MTU - (fun () -> Int64.of_int (Net.Interface.get_mtu dbg bridge)) - Int64.to_string ; - if pif.API.pIF_physical then + (fun () -> Net.Interface.get_mac dbg pif_device_name) + Fun.id ; maybe_update_database "capabilities" pif.API.pIF_capabilities Db.PIF.set_capabilities - (fun () -> Net.Interface.get_capabilities dbg pif.API.pIF_device) + (fun () -> Net.Interface.get_capabilities dbg pif_device_name) (String.concat "; ") - -let refresh ~__context ~host ~self = - let localhost = Helpers.get_localhost ~__context in - if not (host = localhost) then - Helpers.internal_error "refresh: Host mismatch, expected %s but got %s" - (Ref.string_of host) (Ref.string_of localhost) ; - refresh_internal ~__context ~self + ) ; + if pif.API.pIF_physical || pif.API.pIF_currently_attached then ( + maybe_update_database "PCI" pif.API.pIF_PCI Db.PIF.set_PCI + (fun () -> + get_device_pci ~__context ~host:pif.API.pIF_host ~device:pif_device_name + ) + Ref.string_of ; + maybe_update_database "MTU" pif.API.pIF_MTU Db.PIF.set_MTU + (fun () -> Int64.of_int (Net.Interface.get_mtu dbg bridge)) + Int64.to_string + ) let refresh_all ~__context ~host = let localhost = Helpers.get_localhost ~__context in if not (host = localhost) then Helpers.internal_error "refresh_all: Host mismatch, expected %s but got %s" (Ref.string_of host) (Ref.string_of localhost) ; - (* Only refresh physical or attached PIFs *) let pifs = Db.PIF.get_refs_where ~__context - ~expr: - (And - ( Eq (Field "host", Literal (Ref.string_of host)) - , Or - ( Eq (Field "physical", Literal "true") - , Eq (Field "currently_attached", Literal "true") - ) - ) - ) + ~expr:(Eq (Field "host", Literal (Ref.string_of host))) in - List.iter (fun self -> refresh_internal ~__context ~self) pifs - -let bridge_naming_convention (device : string) = - if String.starts_with ~prefix:"eth" device then - "xenbr" ^ String.sub device 3 (String.length device - 3) - else - "br" ^ device + let interface_tables = make_tables ~__context ~host in + List.iter + (fun self -> refresh_internal ~__context ~interface_tables ~self) + pifs let read_bridges_from_inventory () = try String.split ' ' (Xapi_inventory.lookup Xapi_inventory._current_interfaces) @@ -271,13 +366,17 @@ let abort_if_network_attached_to_protected_vms ~__context ~self = List.iter (fun vm -> if Helpers.is_xha_protected ~__context ~self:vm then ( - warn - "PIF.unplug will make protected VM %s not agile since it has a VIF \ - attached to network %s" - (Ref.string_of vm) (Ref.string_of net) ; + let vm = Ref.string_of vm in + let pif = Ref.string_of self in + let net = Ref.string_of net in + info + "The protected VM %s must remain agile and blocked the operation. \ + PIF %s must be plugged this. This happened because network %s is \ + used by both the VM and the PIF" + vm pif net ; raise - (Api_errors.Server_error - (Api_errors.ha_operation_would_break_failover_plan, []) + Api_errors.( + Server_error (ha_constraint_violation_network_not_shared, [net]) ) ) ) @@ -337,8 +436,8 @@ let assert_fcoe_not_in_use ~__context ~self = () ) -let find_or_create_network (bridge : string) (device : string) ~managed - ~__context = +let find_or_create_network (bridge : string) (device : string) + (pos_opt : int option) ~managed ~__context = let nets = Db.Network.get_refs_where ~__context ~expr:(Eq (Field "bridge", Literal bridge)) @@ -352,42 +451,13 @@ let find_or_create_network (bridge : string) (device : string) ~managed let () = Db.Network.create ~__context ~ref:net_ref ~uuid:net_uuid ~current_operations:[] ~allowed_operations:[] - ~name_label:(Helpers.choose_network_name_for_pif device) + ~name_label:(Helpers.choose_network_name_for_pif device pos_opt) ~name_description:"" ~mTU:1500L ~purpose:[] ~bridge ~managed ~other_config:[] ~blobs:[] ~tags:[] ~default_locking_mode:`unlocked ~assigned_ips:[] in net_ref -type tables = { - device_to_mac_table: (string * string) list - ; pif_to_device_table: (API.ref_PIF * string) list -} - -let make_tables ~__context ~host = - let dbg = Context.string_of_task __context in - let devices = - List.filter - (fun name -> Net.Interface.is_physical dbg name) - (Net.Interface.get_all dbg ()) - in - let pifs = - Db.PIF.get_records_where ~__context - ~expr: - (And - ( Eq (Field "host", Literal (Ref.string_of host)) - , Eq (Field "physical", Literal "true") - ) - ) - in - { - device_to_mac_table= - List.combine devices - (List.map (fun name -> Net.Interface.get_mac dbg name) devices) - ; pif_to_device_table= - List.map (fun (pref, prec) -> (pref, prec.API.pIF_device)) pifs - } - let is_my_management_pif ~__context ~self = let net = Db.PIF.get_network ~__context ~self in let management_if = @@ -445,16 +515,19 @@ let db_introduce = pool_introduce let db_forget ~__context ~self = Db.PIF.destroy ~__context ~self (* Internal [introduce] is passed a pre-built table [t] *) -let introduce_internal ?network ?(physical = true) ~t:_ ~__context ~host ~mAC - ~mTU ~device ~vLAN ~vLAN_master_of ?metrics ~managed - ?(disallow_unplug = false) () = - let bridge = if managed then bridge_naming_convention device else "" in +let introduce_internal ?network ?(physical = true) ~t ~__context ~host ~mAC ~mTU + ~device ~vLAN ~vLAN_master_of ?metrics ~managed ?(disallow_unplug = false) + () = + let pos_opt = List.assoc_opt device t.device_to_position_table in + let bridge = + if managed then bridge_naming_convention device pos_opt else "" + in (* If we are not told which network to use, * apply the default convention *) let net_ref = match network with | None -> - find_or_create_network bridge device ~managed ~__context + find_or_create_network bridge device pos_opt ~managed ~__context | Some x -> x in @@ -926,17 +999,25 @@ let assert_cluster_host_operation_not_in_progress ~__context = match Db.Cluster.get_all ~__context with | [] -> () - | cluster :: _ -> - let ops = - Db.Cluster.get_current_operations ~__context ~self:cluster - |> List.map snd - in - if List.mem `enable ops || List.mem `add ops then - raise - Api_errors.( - Server_error - (other_operation_in_progress, ["Cluster"; Ref.string_of cluster]) - ) + | cluster :: _ -> ( + let ops = Db.Cluster.get_current_operations ~__context ~self:cluster in + match List.find_opt (fun (_, op) -> op = `enable || op = `add) ops with + | Some (op_ref, op_type) -> + raise + Api_errors.( + Server_error + ( other_operation_in_progress + , [ + "Cluster" + ; Ref.string_of cluster + ; API.cluster_operation_to_string op_type + ; op_ref + ] + ) + ) + | None -> + () + ) (* Block allowing unplug if - a cluster host is enabled on this PIF @@ -963,9 +1044,6 @@ let rec unplug ~__context ~self = assert_no_protection_enabled ~__context ~self ; assert_not_management_pif ~__context ~self ; let pif_rec = Db.PIF.get_record ~__context ~self in - let host = pif_rec.API.pIF_host in - if Db.Host.get_enabled ~__context ~self:host then - abort_if_network_attached_to_protected_vms ~__context ~self ; let network = Db.PIF.get_network ~__context ~self in Xapi_network_attach_helpers.assert_network_has_no_vifs_in_use_on_me ~__context ~host:(Helpers.get_localhost ~__context) @@ -1126,7 +1204,7 @@ let start_of_day_best_effort_bring_up ~__context () = debug "Configured network backend: %s" (Network_interface.string_of_kind (Net.Bridge.get_kind dbg ())) ; (* Clear the state of the network daemon, before refreshing it by plugging - * the most important PIFs (see above). *) + * the most important PIFs (see above). *) Net.clear_state () ; List.iter (fun (pif, pifr) -> diff --git a/ocaml/xapi/xapi_pif.mli b/ocaml/xapi/xapi_pif.mli index 6c83936c1a..388d974c5f 100644 --- a/ocaml/xapi/xapi_pif.mli +++ b/ocaml/xapi/xapi_pif.mli @@ -43,10 +43,6 @@ (** {2 API functions} *) -val refresh : - __context:Context.t -> host:[`host] Ref.t -> self:[`PIF] Ref.t -> unit -(** Refresh the metadata of an existing PIF on the current host. *) - val refresh_all : __context:Context.t -> host:[`host] Ref.t -> unit (** Refresh the metadata of all existing PIFs on the current host. *) @@ -160,9 +156,10 @@ val plug : __context:Context.t -> self:[`PIF] Ref.t -> unit (** {2 Miscellaneous Helper Functions} *) -val bridge_naming_convention : string -> string -(** Constructs a bridge name from a device (network interface) name by replacing - * [eth] by [xenbr], or prepending [br] if the device name does not start with [eth]. +val bridge_naming_convention : string -> int option -> string +(** Constructs a bridge name from a [device] (network interface) name and an optional + position [pos_opt]. If [pos_opt] is Some [pos], the bridge name will be + "xenbr" ^ [pos], else "br" ^ [device]. *) val read_bridges_from_inventory : unit -> string list diff --git a/ocaml/xapi/xapi_pif_helpers.ml b/ocaml/xapi/xapi_pif_helpers.ml index fac7593b7d..b43891b935 100644 --- a/ocaml/xapi/xapi_pif_helpers.ml +++ b/ocaml/xapi/xapi_pif_helpers.ml @@ -246,6 +246,15 @@ let is_device_underneath_same_type ~__context pif1 pif2 = in get_device_info pif1 = get_device_info pif2 +let is_pluggable ~__context pif_ref = + let pif_rec = Db.PIF.get_record ~__context ~self:pif_ref in + (* If the root pif is a bond slave, it is not pluggable *) + match List.rev (get_pif_topo ~__context ~pif_rec) with + | Physical pif_rec :: _ -> + not (Db.is_valid_ref __context pif_rec.API.pIF_bond_slave_of) + | _ -> + true + let get_non_link_ipv6 ~__context ~pif = let valid_nonlink ipv6 = let open Ipaddr.V6 in @@ -265,3 +274,10 @@ let get_primary_address ~__context ~pif = ) | `IPv6 -> List.nth_opt (get_non_link_ipv6 ~__context ~pif) 0 + +let get_pif_position ~__context ~pif_rec = + let n_of_xenbrn_opt bridge = + try Scanf.sscanf bridge "xenbr%d%!" Option.some with _ -> None + in + let bridge = Db.Network.get_bridge ~__context ~self:pif_rec.API.pIF_network in + n_of_xenbrn_opt bridge diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index b2d6da1122..cbb39e28ad 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -112,6 +112,95 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = ) ) in + let one_ip_configured_on_joining_cluster_network () = + let one_ip_configured_on_joining_cluster_network' cluster_host = + match Client.Cluster_host.get_PIF ~rpc ~session_id ~self:cluster_host with + | pif when pif = Ref.null -> + () + | pif -> ( + match + ( Client.PIF.get_VLAN ~rpc ~session_id ~self:pif + , Client.PIF.get_management ~rpc ~session_id ~self:pif + ) + with + | vlan, false when vlan > 0L -> + error + "Cannot join pool whose clustering is enabled on a \ + non-management VLAN network" ; + raise + (Api_errors.Server_error + ( Api_errors + .pool_joining_pool_cannot_enable_clustering_on_vlan_network + , [Int64.to_string vlan] + ) + ) + | _ -> ( + let clustering_bridges_in_pool = + ( match + Client.PIF.get_bond_master_of ~rpc ~session_id ~self:pif + with + | [] -> + [pif] + | bonds -> + List.concat_map + (fun bond -> + Client.Bond.get_slaves ~rpc ~session_id ~self:bond + ) + bonds + ) + |> List.map (fun self -> + Client.PIF.get_network ~rpc ~session_id ~self + ) + |> List.map (fun self -> + Client.Network.get_bridge ~rpc ~session_id ~self + ) + in + match + Db.Host.get_PIFs ~__context + ~self:(Helpers.get_localhost ~__context) + |> List.filter (fun p -> + List.exists + (fun b -> + let network = Db.PIF.get_network ~__context ~self:p in + Db.Network.get_bridge ~__context ~self:network = b + ) + clustering_bridges_in_pool + && Db.PIF.get_IP ~__context ~self:p <> "" + ) + with + | [_] -> + () + | _ -> + error + "Cannot join pool as the joining host needs to have one (and \ + only one) IP address on the network that will be used for \ + clustering." ; + raise + (Api_errors.Server_error + ( Api_errors + .pool_joining_host_must_have_only_one_IP_on_clustering_network + , [] + ) + ) + ) + ) + in + match Client.Cluster_host.get_all ~rpc ~session_id with + | [] -> + () + | ch :: _ -> ( + let cluster = + Client.Cluster_host.get_cluster ~rpc ~session_id ~self:ch + in + match + Client.Cluster.get_pool_auto_join ~rpc ~session_id ~self:cluster + with + | false -> + () + | true -> + one_ip_configured_on_joining_cluster_network' ch + ) + in (* CA-26975: Pool edition MUST match *) let assert_restrictions_match () = let my_edition = @@ -888,6 +977,7 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = assert_management_interface_exists () ; ha_is_not_enable_on_me () ; clustering_is_not_enabled_on_me () ; + one_ip_configured_on_joining_cluster_network () ; ha_is_not_enable_on_the_distant_pool () ; assert_not_joining_myself () ; assert_i_know_of_no_other_hosts () ; @@ -963,6 +1053,13 @@ let rec create_or_get_host_on_master __context rpc session_id (host_ref, host) : ~ssl_legacy:false ~last_software_update:host.API.host_last_software_update ~last_update_hash:host.API.host_last_update_hash + ~ssh_enabled:host.API.host_ssh_enabled + ~ssh_enabled_timeout:host.API.host_ssh_enabled_timeout + ~ssh_expiry:host.API.host_ssh_expiry + ~console_idle_timeout:host.API.host_console_idle_timeout + ~ssh_auto_mode:host.API.host_ssh_auto_mode + ~secure_boot:host.API.host_secure_boot + ~software_version:host.API.host_software_version in (* Copy other-config into newly created host record: *) no_exn @@ -1556,6 +1653,7 @@ let join_common ~__context ~master_address ~master_username ~master_password ) in + let remote_coordinator = get_master ~rpc ~session_id in (* If management is on a VLAN, then get the Pool master management network bridge before we logout the session *) let pool_master_bridge, mgmt_pif = @@ -1566,7 +1664,7 @@ let join_common ~__context ~master_address ~master_username ~master_password if Db.PIF.get_VLAN_master_of ~__context ~self:my_pif <> Ref.null then let pif = Client.Host.get_management_interface ~rpc ~session_id - ~host:(get_master ~rpc ~session_id) + ~host:remote_coordinator in let network = Client.PIF.get_network ~rpc ~session_id ~self:pif in (Some (Client.Network.get_bridge ~rpc ~session_id ~self:network), my_pif) @@ -1656,8 +1754,44 @@ let join_common ~__context ~master_address ~master_username ~master_password "Unable to set the write the new pool certificates to the disk : %s" (ExnHelper.string_of_exn e) ) ; - Db.Host.set_latest_synced_updates_applied ~__context ~self:me - ~value:`unknown ; + ( try + let ssh_enabled_timeout = + Client.Host.get_ssh_enabled_timeout ~rpc ~session_id + ~self:remote_coordinator + in + let console_idle_timeout = + Client.Host.get_console_idle_timeout ~rpc ~session_id + ~self:remote_coordinator + in + let ssh_auto_mode = + Client.Host.get_ssh_auto_mode ~rpc ~session_id + ~self:remote_coordinator + in + Xapi_host.set_console_idle_timeout ~__context ~self:me + ~value:console_idle_timeout ; + Xapi_host.set_ssh_enabled_timeout ~__context ~self:me + ~value:ssh_enabled_timeout ; + Xapi_host.set_ssh_auto_mode ~__context ~self:me ~value:ssh_auto_mode ; + let ssh_enabled = + Client.Host.get_ssh_enabled ~rpc ~session_id + ~self:remote_coordinator + in + (* As ssh_expiry will be updated by host.enable_ssh and host.disable_ssh, + there is a corner case when the joiner's SSH state will not match SSH + service state in its new coordinator exactly: if the joiner joins when + SSH service has been enabled in the new coordinator, while not timed + out yet, the joiner will start SSH service with timeout + host.ssh_enabled_timeout, which means SSH service in the joiner will + be disabled later than in the new coordinator. *) + match ssh_enabled with + | true -> + Xapi_host.enable_ssh ~__context ~self:me + | false -> + Xapi_host.disable_ssh ~__context ~self:me + with e -> + error "Unable to configure SSH service on local host: %s" + (ExnHelper.string_of_exn e) + ) ; (* 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 @@ -1746,15 +1880,14 @@ let exchange_ca_certificates_on_join ~__context ~import ~export : in Cert_distrib.exchange_ca_certificates_with_joiner ~__context ~import ~export -(* Assume that db backed up from master will be there and ready to go... *) let emergency_transition_to_master ~__context = - if Localdb.get Constants.ha_armed = "true" then - raise (Api_errors.Server_error (Api_errors.ha_is_enabled, [])) ; + if Localdb.get_bool Constants.ha_armed |> Option.value ~default:false then + raise Api_errors.(Server_error (ha_is_enabled, [])) ; Xapi_pool_transition.become_master () let emergency_reset_master ~__context ~master_address = - if Localdb.get Constants.ha_armed = "true" then - raise (Api_errors.Server_error (Api_errors.ha_is_enabled, [])) ; + if Localdb.get_bool Constants.ha_armed |> Option.value ~default:false then + raise Api_errors.(Server_error (ha_is_enabled, [])) ; let master_address = Helpers.gethostbyname master_address in Xapi_pool_transition.become_another_masters_slave master_address @@ -2004,7 +2137,6 @@ let eject_self ~__context ~host = configuration_file in write_first_boot_management_interface_configuration_file () ; - Net.reset_state () ; Xapi_inventory.update Xapi_inventory._current_interfaces "" ; (* Destroy my control domains, since you can't do this from the API [operation not allowed] *) ( try @@ -2013,6 +2145,25 @@ let eject_self ~__context ~host = control_domains_to_destroy with _ -> () ) ; + ( try + (* Restore console idle timeout *) + Xapi_host.set_console_idle_timeout ~__context ~self:host + ~value:Constants.default_console_idle_timeout ; + (* Restore SSH service to default state *) + Xapi_host.set_ssh_enabled_timeout ~__context ~self:host + ~value:Constants.default_ssh_enabled_timeout ; + Xapi_host.set_ssh_auto_mode ~__context ~self:host + ~value:!Xapi_globs.ssh_auto_mode_default ; + match Constants.default_ssh_enabled with + | true -> + Xapi_host.enable_ssh ~__context ~self:host + | false -> + Xapi_host.disable_ssh ~__context ~self:host + with e -> + warn "Caught %s while restoring ssh service. Ignoring" + (Printexc.to_string e) + ) ; + debug "Pool.eject: setting our role to be master" ; Xapi_pool_transition.set_role Pool_role.Master ; debug "Pool.eject: forgetting pool secret" ; @@ -2064,15 +2215,10 @@ let eject_self ~__context ~host = (!Xapi_globs.remote_db_conf_fragment_path ^ ".bak") ) () ; - (* Reset the domain 0 network interface naming configuration - * back to a fresh-install state for the currently-installed - * hardware. - *) - ignore - (Forkhelpers.execute_command_get_output - "/etc/sysconfig/network-scripts/interface-rename.py" - ["--reset-to-install"] - ) + (* Reset the domain 0 network interface order back to a fresh-install + * state for the currently-installed hardware and reset networkd config. + *) + Net.reset_state () ) (fun () -> Xapi_fuse.light_fuse_and_reboot_after_eject ()) ; Xapi_hooks.pool_eject_hook ~__context @@ -2466,7 +2612,9 @@ let create_VLAN_from_PIF ~__context ~pif ~network ~vLAN = let enable_disable_m = Mutex.create () let enable_ha ~__context ~heartbeat_srs ~configuration = - if not (Helpers.pool_has_different_host_platform_versions ~__context) then + if + not (Helpers.Checks.RPU.pool_has_different_host_platform_versions ~__context) + then with_lock enable_disable_m (fun () -> Xapi_ha.enable __context heartbeat_srs configuration ) @@ -2915,8 +3063,10 @@ let disable_external_auth ~__context ~pool:_ ~config = debug "Failed to disable the external authentication of at least one \ host in the pool" ; - if String.starts_with ~prefix:Api_errors.auth_disable_failed err - then (* tagged exception *) + if + String.starts_with ~prefix:Api_errors.auth_disable_failed err + (* tagged exception *) + then raise (Api_errors.Server_error (Api_errors.pool_auth_prefix ^ err, [Ref.string_of host; msg]) @@ -4004,8 +4154,35 @@ module Ssh = struct let disable ~__context ~self:_ = operate ~__context ~action:Client.Host.disable_ssh ~error:Api_errors.disable_ssh_partially_failed + + let set_enabled_timeout ~__context ~self:_ ~value = + operate ~__context + ~action:(fun ~rpc ~session_id ~self -> + Client.Host.set_ssh_enabled_timeout ~rpc ~session_id ~self ~value + ) + ~error:Api_errors.set_ssh_timeout_partially_failed + + let set_console_timeout ~__context ~self:_ ~value = + operate ~__context + ~action:(fun ~rpc ~session_id ~self -> + Client.Host.set_console_idle_timeout ~rpc ~session_id ~self ~value + ) + ~error:Api_errors.set_console_timeout_partially_failed + + let set_ssh_auto_mode ~__context ~self:_ ~value = + operate ~__context + ~action:(fun ~rpc ~session_id ~self -> + Client.Host.set_ssh_auto_mode ~rpc ~session_id ~self ~value + ) + ~error:Api_errors.set_ssh_auto_mode_partially_failed end let enable_ssh = Ssh.enable let disable_ssh = Ssh.disable + +let set_ssh_enabled_timeout = Ssh.set_enabled_timeout + +let set_console_idle_timeout = Ssh.set_console_timeout + +let set_ssh_auto_mode = Ssh.set_ssh_auto_mode diff --git a/ocaml/xapi/xapi_pool.mli b/ocaml/xapi/xapi_pool.mli index 7d00d33980..dc87e90a18 100644 --- a/ocaml/xapi/xapi_pool.mli +++ b/ocaml/xapi/xapi_pool.mli @@ -437,3 +437,12 @@ val put_bundle_handler : Http.Request.t -> Unix.file_descr -> 'a -> unit val enable_ssh : __context:Context.t -> self:API.ref_pool -> unit val disable_ssh : __context:Context.t -> self:API.ref_pool -> unit + +val set_ssh_enabled_timeout : + __context:Context.t -> self:API.ref_pool -> value:int64 -> unit + +val set_console_idle_timeout : + __context:Context.t -> self:API.ref_pool -> value:int64 -> unit + +val set_ssh_auto_mode : + __context:Context.t -> self:API.ref_pool -> value:bool -> unit diff --git a/ocaml/xapi/xapi_pool_helpers.ml b/ocaml/xapi/xapi_pool_helpers.ml index 14f4c37d03..bdd4e0454b 100644 --- a/ocaml/xapi/xapi_pool_helpers.ml +++ b/ocaml/xapi/xapi_pool_helpers.ml @@ -99,7 +99,7 @@ type validity = Unknown | Allowed | Disallowed of string * string list let compute_valid_operations ~__context record pool : API.pool_allowed_operations -> validity = let ref = Ref.string_of pool in - let current_ops = List.map snd record.Db_actions.pool_current_operations in + let current_ops = record.Db_actions.pool_current_operations in let table = (Hashtbl.create 32 : (all_operations, validity) Hashtbl.t) in let set_validity = Hashtbl.replace table in (* Start by assuming all operations are allowed. *) @@ -118,30 +118,45 @@ let compute_valid_operations ~__context record pool : in List.iter populate ops in - let other_operation_in_progress = - (Api_errors.other_operation_in_progress, [Datamodel_common._pool; ref]) + let other_operation_in_progress waiting_op = + let additional_info = + match waiting_op with + | Some (op_ref, op_type) -> + [API.pool_allowed_operations_to_string op_type; op_ref] + | _ -> + [] + in + ( Api_errors.other_operation_in_progress + , [Datamodel_common._pool; ref] @ additional_info + ) + in + let is_current_op op = + List.exists (fun (_, current_op) -> op = current_op) current_ops in - let is_current_op = Fun.flip List.mem current_ops in let blocking = List.find_opt (fun (op, _) -> is_current_op op) blocking_ops_table in - let waiting = List.find_opt is_current_op waiting_ops in + let waiting = + List.find_opt + (fun (_, current_op) -> List.mem current_op waiting_ops) + current_ops + in ( match (blocking, waiting) with - | Some (_, reason), _ -> + | Some (_, reason), waiting_current_op -> (* Mark all potentially blocking operations as invalid due to the specific blocking operation's "in progress" error. *) set_errors blocking_ops (reason, []) ; (* Mark all waiting operations as invalid for the generic "OTHER_OPERATION_IN_PROGRESS" reason. *) - set_errors waiting_ops other_operation_in_progress + set_errors waiting_ops (other_operation_in_progress waiting_current_op) (* Note that all_operations ⊆ blocking_ops ∪ waiting_ops, so this invalidates all operations (with the reason partitioned between whether the operation is blocking or waiting). *) - | None, Some _ -> + | None, (Some _ as waiting_current_op) -> (* If there's no blocking operation in current operations, but there is a waiting operation, invalidate all operations for the generic reason. Again, this covers every operation. *) - set_errors all_operations other_operation_in_progress + set_errors all_operations (other_operation_in_progress waiting_current_op) | None, None -> ( (* If there's no blocking or waiting operation in current operations (i.e. current operations is empty), we can report diff --git a/ocaml/xapi/xapi_pool_patch.ml b/ocaml/xapi/xapi_pool_patch.ml index 4c30792b7f..a1d006e688 100644 --- a/ocaml/xapi/xapi_pool_patch.ml +++ b/ocaml/xapi/xapi_pool_patch.ml @@ -61,7 +61,7 @@ let pool_patch_upload_handler (req : Http.Request.t) s _ = | Some _ -> query (* There was already an SR specified *) | None -> - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let default_SR = Db.Pool.get_default_SR ~__context ~self:pool in ("sr_id", Ref.string_of default_SR) :: query in diff --git a/ocaml/xapi/xapi_pool_transition.ml b/ocaml/xapi/xapi_pool_transition.ml index 8f6a315f59..a35b736c3f 100644 --- a/ocaml/xapi/xapi_pool_transition.ml +++ b/ocaml/xapi/xapi_pool_transition.ml @@ -62,7 +62,7 @@ let run_external_scripts becoming_master = order in let already_run = - try bool_of_string (Localdb.get Constants.master_scripts) with _ -> false + Localdb.get_bool Constants.master_scripts |> Option.value ~default:false in (* Only do anything if we're switching mode *) if already_run <> becoming_master then ( @@ -228,8 +228,8 @@ let become_another_masters_slave master_address = (** If we just transitioned slave -> master (as indicated by the localdb flag) then generate a single alert *) let consider_sending_alert __context () = if - try bool_of_string (Localdb.get Constants.this_node_just_became_master) - with _ -> false + Localdb.get_bool Constants.this_node_just_became_master + |> Option.value ~default:false then let obj_uuid = Helpers.get_localhost_uuid () in let name, priority = Api_messages.pool_master_transition in diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index 426db45cbc..6aa1ea0fd7 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -809,10 +809,10 @@ let proxy_request req s host_uuid = ) let pool_update_download_handler (req : Request.t) s _ = - debug "pool_update.pool_update_download_handler URL %s" req.Request.uri ; + debug "pool_update.pool_update_download_handler URL %s" req.Request.path ; req.Request.close <- true ; let localhost_uuid = Helpers.get_localhost_uuid () in - let host_uuid, filepath = path_and_host_from_uri req.Request.uri in + let host_uuid, filepath = path_and_host_from_uri req.Request.path in debug "pool_update.pool_update_download_handler %s" filepath ; if host_uuid <> localhost_uuid then proxy_request req s host_uuid diff --git a/ocaml/xapi/xapi_services.ml b/ocaml/xapi/xapi_services.ml index 1612c5050f..54f84373d9 100644 --- a/ocaml/xapi/xapi_services.ml +++ b/ocaml/xapi/xapi_services.ml @@ -92,7 +92,7 @@ let hand_over_connection req s path = try debug "hand_over_connection %s %s to %s" (Http.string_of_method_t req.Http.Request.m) - req.Http.Request.uri path ; + req.Http.Request.path path ; let control_fd = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in finally (fun () -> @@ -153,7 +153,7 @@ let http_proxy_to_plugin req from name = let post_handler (req : Http.Request.t) s _ = Xapi_http.with_context ~dummy:true "Querying services" req s (fun __context -> - match String.split_on_char '/' req.Http.Request.uri with + match String.split_on_char '/' req.Http.Request.path with | "" :: services :: "xenops" :: _ when services = _services -> (* over the network we still use XMLRPC *) let request = Http_svr.read_body req s in @@ -186,7 +186,7 @@ let post_handler (req : Http.Request.t) s _ = let put_handler (req : Http.Request.t) s _ = Xapi_http.with_context ~dummy:true "Querying services" req s (fun __context -> - match String.split_on_char '/' req.Http.Request.uri with + match String.split_on_char '/' req.Http.Request.path with | "" :: services :: "xenops" :: _ when services = _services -> ignore (hand_over_connection req s @@ -207,8 +207,9 @@ let put_handler (req : Http.Request.t) s _ = -> Storage_migrate.nbd_handler req s ~vm sr vdi dp | [""; services; "SM"; "nbdproxy"; vm; sr; vdi; dp] + | [""; services; "SM"; "nbdproxy"; "import"; vm; sr; vdi; dp] when services = _services -> - Storage_migrate.nbd_proxy req s vm sr vdi dp + Storage_migrate.import_nbd_proxy req s vm sr vdi dp | _ -> Http_svr.headers s (Http.http_404_missing ~version:"1.0" ()) ; req.Http.Request.close <- true @@ -216,8 +217,8 @@ let put_handler (req : Http.Request.t) s _ = let get_handler (req : Http.Request.t) s _ = Xapi_http.with_context ~dummy:true "Querying services" req s (fun __context -> - debug "uri = %s" req.Http.Request.uri ; - match String.split_on_char '/' req.Http.Request.uri with + debug "uri = %s" req.Http.Request.path ; + match String.split_on_char '/' req.Http.Request.path with | "" :: services :: "xenops" :: _ when services = _services -> ignore (hand_over_connection req s diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index f7fcfdac7e..f63b01c377 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -32,6 +32,7 @@ module Listext = Xapi_stdext_std.Listext open Client open Auth_signature open Extauth +module SessionValidateMap = Map.Make (String) module AuthFail : sig (* stats are reset each time you query, so if there hasn't @@ -420,18 +421,18 @@ let destroy_db_session ~__context ~self = (* CP-703: ensure that activate sessions are invalidated in a bounded time *) (* in response to external authentication/directory services updates, such as *) (* e.g. group membership changes, or even account disabled *) -let revalidate_external_session ~__context ~session = +let revalidate_external_session ~__context acc session = Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> try (* guard: we only want to revalidate external sessions, where is_local_superuser is false *) (* Neither do we want to revalidate the special read-only external database sessions, since they can exist independent of external authentication. *) + (* 1. is the external authentication disabled in the pool? *) if not (Db.Session.get_is_local_superuser ~__context ~self:session || Xapi_database.Db_backend.is_session_registered (Ref.string_of session) ) - then ( - (* 1. is the external authentication disabled in the pool? *) + then let master = Helpers.get_master ~__context in let auth_type = Db.Host.get_external_auth_type ~__context ~self:master in if auth_type = "" then ( @@ -442,45 +443,54 @@ let revalidate_external_session ~__context ~session = (trackid session) in debug "%s" msg ; - destroy_db_session ~__context ~self:session + destroy_db_session ~__context ~self:session ; + acc ) else (* otherwise, we try to revalidate it against the external authentication service *) let session_lifespan = 60.0 *. 30.0 in (* allowed session lifespan = 30 minutes *) let random_lifespan = Random.float 60.0 *. 10.0 in - (* extra random (up to 10min) lifespan to spread access to external directory *) - (* 2. has the external session expired/does it need revalidation? *) let session_last_validation_time = Date.to_unix_time (Db.Session.get_validation_time ~__context ~self:session) in let now = Date.now () in - let session_needs_revalidation = + let session_timed_out = Date.to_unix_time now > session_last_validation_time +. session_lifespan +. random_lifespan in - if session_needs_revalidation then ( + + (* extra random (up to 10min) lifespan to spread access to external directory *) + let authenticated_user_sid = + Db.Session.get_auth_user_sid ~__context ~self:session + in + let validate_with_memo acc f = + match SessionValidateMap.find_opt authenticated_user_sid acc with + | None -> + f acc + | Some false -> + debug "Destory session %s as previous check for user %s not pass" + (trackid session) authenticated_user_sid ; + destroy_db_session ~__context ~self:session ; + acc + | Some true -> + debug "Skip check session %s as previous check for user %s pass" + (trackid session) authenticated_user_sid ; + acc + in + + if session_timed_out then ( (* if so, then:*) + validate_with_memo acc @@ fun acc -> debug "session %s needs revalidation" (trackid session) ; - let authenticated_user_sid = - Db.Session.get_auth_user_sid ~__context ~self:session - in (* 2a. revalidate external authentication *) (* CP-827: if the user was suspended (disabled,expired,locked-out), then we must destroy the session *) let suspended, _ = - is_subject_suspended ~__context ~cache:true authenticated_user_sid - in - let suspended = - if suspended then - is_subject_suspended ~__context ~cache:false - authenticated_user_sid - |> fst - else - suspended + is_subject_suspended ~__context ~cache:false authenticated_user_sid in if suspended then ( debug @@ -488,7 +498,8 @@ let revalidate_external_session ~__context ~session = %s" authenticated_user_sid (trackid session) ; (* we must destroy the session in this case *) - destroy_db_session ~__context ~self:session + destroy_db_session ~__context ~self:session ; + SessionValidateMap.add authenticated_user_sid false acc ) else try (* if the user is not in the external directory service anymore, this call raises Not_found *) @@ -525,7 +536,8 @@ let revalidate_external_session ~__context ~session = in debug "%s" msg ; (* we must destroy the session in this case *) - destroy_db_session ~__context ~self:session + destroy_db_session ~__context ~self:session ; + SessionValidateMap.add authenticated_user_sid false acc ) else ( (* non-empty intersection: externally-authenticated subject still has login rights in the pool *) @@ -552,7 +564,9 @@ let revalidate_external_session ~__context ~session = ~value:subject_in_intersection ; debug "updated subject for session %s, sid %s " (trackid session) authenticated_user_sid - ) + ) ; + debug "end revalidation of session %s " (trackid session) ; + SessionValidateMap.add authenticated_user_sid true acc with Not_found -> (* subject ref for intersection's sid does not exist in our metadata!!! *) (* this should never happen, it's an internal metadata inconsistency between steps 2b and 2c *) @@ -564,7 +578,8 @@ let revalidate_external_session ~__context ~session = in debug "%s" msg ; (* we must destroy the session in this case *) - destroy_db_session ~__context ~self:session + destroy_db_session ~__context ~self:session ; + SessionValidateMap.add authenticated_user_sid false acc ) with Auth_signature.Subject_cannot_be_resolved | Not_found -> (* user was not found in external directory in order to obtain group membership *) @@ -577,15 +592,18 @@ let revalidate_external_session ~__context ~session = in debug "%s" msg ; (* user is not in the external directory anymore: we must destroy the session in this case *) - destroy_db_session ~__context ~self:session - ) ; - debug "end revalidation of session %s " (trackid session) - ) + destroy_db_session ~__context ~self:session ; + SessionValidateMap.add authenticated_user_sid false acc + ) else + acc + else + acc with e -> (*unexpected exception: we absorb it and print out a debug line *) debug "Unexpected exception while revalidating session %s: %s" (trackid session) - (ExnHelper.string_of_exn e) + (ExnHelper.string_of_exn e) ; + acc (* CP-703: ensure that activate sessions are invalidated in a bounded time *) (* in response to external authentication/directory services updates, such as *) @@ -595,21 +613,18 @@ let revalidate_all_sessions ~__context = try debug "revalidating all external sessions in the local host" ; (* obtain all sessions in the pool *) - let sessions = Db.Session.get_all ~__context in + Db.Session.get_all ~__context (* filter out those sessions where is_local_superuser or client_certificate is true *) (* we only want to revalidate the sessions created using the external authentication service *) - let external_sessions = - List.filter - (fun session -> - (not (Db.Session.get_is_local_superuser ~__context ~self:session)) - && not (Db.Session.get_client_certificate ~__context ~self:session) - ) - sessions - in - (* revalidate each external session *) - List.iter - (fun session -> revalidate_external_session ~__context ~session) - external_sessions + |> List.filter (fun session -> + (not (Db.Session.get_is_local_superuser ~__context ~self:session)) + && not (Db.Session.get_client_certificate ~__context ~self:session) + ) + |> (* revalidate each external session *) + List.fold_left + (revalidate_external_session ~__context) + SessionValidateMap.empty + |> ignore with e -> (*unexpected exception: we absorb it and print out a debug line *) debug "Unexpected exception while revalidating external sessions: %s" @@ -664,6 +679,7 @@ let login_no_password_common_create_session ~__context ~uname ~originator ~host (* Force the time to be updated by calling an API function with this session *) let rpc = Helpers.make_rpc ~__context in ignore (Client.Pool.get_all ~rpc ~session_id) ; + Xapi_tracked_user_agents.track ~__context ; session_id let login_no_password_common ~__context ~uname ~originator ~host ~pool @@ -801,12 +817,12 @@ module Caching = struct and type password = string and type session = external_auth_result - let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) + let () = Mirage_crypto_rng_unix.use_default () let create_salt () = (* Creates a Cstruct of length 8. *) let data = Mirage_crypto_rng.generate 8 in - let bytes = Cstruct.to_bytes data in + let bytes = Bytes.of_string data in (* Encode the salt as a hex string. Each byte becomes 2 hexadecimal digits, so the length is 16 (the maximum for crypt_r). *) @@ -1569,5 +1585,5 @@ let create_from_db_file ~__context ~filename = Xapi_database.Db_xml.From.file (Datamodel_schema.of_datamodel ()) filename |> Xapi_database.Db_upgrade.generic_database_upgrade in - let db_ref = Some (Xapi_database.Db_ref.in_memory (ref (ref db))) in + let db_ref = Some (Xapi_database.Db_ref.in_memory (Atomic.make db)) in create_readonly_session ~__context ~uname:"db-from-file" ~db_ref diff --git a/ocaml/xapi/xapi_sr.ml b/ocaml/xapi/xapi_sr.ml index 4a0684147a..3cd0588038 100644 --- a/ocaml/xapi/xapi_sr.ml +++ b/ocaml/xapi/xapi_sr.ml @@ -357,7 +357,7 @@ let create ~__context ~host ~device_config ~(physical_size : int64) ~name_label __LOC__ (fun () -> Xapi_clustering.assert_cluster_host_is_enabled_for_matching_sms ~__context ~host ~sr_sm_type:_type ; - Helpers.assert_rolling_upgrade_not_in_progress ~__context ; + Helpers.Checks.RPU.assert_rolling_upgrade_not_in_progress ~__context ; debug "SR.create name_label=%s sm_config=[ %s ]" name_label (String.concat "; " (List.map (fun (k, v) -> k ^ " = " ^ v) sm_config)) ; let sr_uuid = Uuidx.make () in @@ -1080,3 +1080,15 @@ let get_live_hosts ~__context ~sr = Xapi_vm_helpers.assert_can_see_specified_SRs ~__context ~reqd_srs:[sr] ~host in Xapi_vm_helpers.possible_hosts ~__context ~choose_fn () + +let required_api_version_of_sr ~__context ~sr = + let sr_type = Db.SR.get_type ~__context ~self:sr in + let expr = + Xapi_database.Db_filter_types.(Eq (Field "type", Literal sr_type)) + in + match Db.SM.get_records_where ~__context ~expr with + | (_, sm) :: _ -> + Some sm.API.sM_required_api_version + | [] -> + warn "Couldn't find SM with type %s" sr_type ; + None diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index 75a3c695af..b08a82c20f 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -200,24 +200,35 @@ let valid_operations ~__context ?op record _ref' : table = let check_parallel_ops ~__context _record = let safe_to_parallelise = [`plug] in let current_ops = - Xapi_stdext_std.Listext.List.setify (List.map snd current_ops) + List.sort_uniq + (fun (_ref1, op1) (_ref2, op2) -> compare op1 op2) + current_ops in (* If there are any current operations, all the non_parallelisable operations must definitely be stopped *) - if current_ops <> [] then - set_errors Api_errors.other_operation_in_progress - ["SR"; _ref; sr_operation_to_string (List.hd current_ops)] - (Xapi_stdext_std.Listext.List.set_difference all_ops safe_to_parallelise) ; - let all_are_parallelisable = - List.fold_left ( && ) true - (List.map (fun op -> List.mem op safe_to_parallelise) current_ops) - in - (* If not all are parallelisable (eg a vdi_resize), ban the otherwise - parallelisable operations too *) - if not all_are_parallelisable then - set_errors Api_errors.other_operation_in_progress - ["SR"; _ref; sr_operation_to_string (List.hd current_ops)] - safe_to_parallelise + match current_ops with + | (current_op_ref, current_op_type) :: _ -> + set_errors Api_errors.other_operation_in_progress + ["SR"; _ref; sr_operation_to_string current_op_type; current_op_ref] + (Xapi_stdext_std.Listext.List.set_difference all_ops + safe_to_parallelise + ) ; + let non_parallelisable_op = + List.find_opt + (fun (_, op) -> not (List.mem op safe_to_parallelise)) + current_ops + in + (* If not all are parallelisable (eg a vdi_resize), ban the otherwise + parallelisable operations too *) + Option.iter + (fun (op_ref, op_type) -> + set_errors Api_errors.other_operation_in_progress + ["SR"; _ref; sr_operation_to_string op_type; op_ref] + safe_to_parallelise + ) + non_parallelisable_op + | [] -> + () in let check_cluster_stack_compatible ~__context _record = (* Check whether there are any conflicts with HA that prevent us from diff --git a/ocaml/xapi/xapi_stats.ml b/ocaml/xapi/xapi_stats.ml index 2c94ca6497..f39b5ae88f 100644 --- a/ocaml/xapi/xapi_stats.ml +++ b/ocaml/xapi/xapi_stats.ml @@ -16,6 +16,10 @@ module D = Debug.Make (struct let name = "xapi_stats" end) let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute +let pool_vgpu_migration_count : int Atomic.t = Atomic.make 0 + +let incr_pool_vgpu_migration_count () = Atomic.incr pool_vgpu_migration_count + let generate_master_stats ~__context = let session_count = Db.Session.get_all ~__context |> List.length |> Int64.of_int @@ -44,7 +48,23 @@ let generate_master_stats ~__context = ~min:0.0 ~units:"sessions/s" () ) in - [session_count_ds; task_count_ds; session_count_change_ds] + let vgpu_migration_count = + Atomic.exchange pool_vgpu_migration_count 0 |> Int64.of_int + in + let vgpu_migration_count_ds = + ( Rrd.Host + , Ds.ds_make ~name:"pool_vgpu_migration_rate" + ~description:"Number of vGPU migrations occurred per second" + ~value:(Rrd.VT_Int64 vgpu_migration_count) ~ty:Rrd.Absolute + ~default:true ~min:0. ~units:"migrations/s" () + ) + in + [ + session_count_ds + ; task_count_ds + ; session_count_change_ds + ; vgpu_migration_count_ds + ] let gc_debug = ref true diff --git a/ocaml/xapi/xapi_stats.mli b/ocaml/xapi/xapi_stats.mli index 5282dca6db..4e1b20750d 100644 --- a/ocaml/xapi/xapi_stats.mli +++ b/ocaml/xapi/xapi_stats.mli @@ -18,3 +18,6 @@ val start : unit -> unit val stop : unit -> unit (** Stop the stats reporting thread. *) + +val incr_pool_vgpu_migration_count : unit -> unit +(** Increments the pool_vgpu_migration_count by 1 . *) diff --git a/ocaml/xapi/xapi_support.ml b/ocaml/xapi/xapi_support.ml index 5e65d58677..13666dc09e 100644 --- a/ocaml/xapi/xapi_support.ml +++ b/ocaml/xapi/xapi_support.ml @@ -14,14 +14,6 @@ module D = Debug.Make (struct let name = "xapi_support" end) open D - -let support_url = "ftp://support.xensource.com/uploads/" - -(* URL to which the crashdump/whatever will be uploaded *) -let upload_url name = - let uuid = Xapi_inventory.lookup Xapi_inventory._installation_uuid in - Printf.sprintf "%s%s-%s" support_url uuid name - open Forkhelpers let do_upload label file url options = diff --git a/ocaml/xapi/xapi_tracked_user_agents.ml b/ocaml/xapi/xapi_tracked_user_agents.ml new file mode 100644 index 0000000000..f4b27109d8 --- /dev/null +++ b/ocaml/xapi/xapi_tracked_user_agents.ml @@ -0,0 +1,84 @@ +(* + * 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. + *) + +module D = Debug.Make (struct let name = __MODULE__ end) + +let max_user_agent_strlen = 64 + +let max_num = 128 + +let t = Hashtbl.create max_num + +let q = Queue.create () + +let m = Mutex.create () + +let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute + +let update name version = + with_lock m @@ fun () -> + match Hashtbl.find_opt t name with + | Some v -> + if v <> version then Hashtbl.replace t name version + | None -> + ( if Queue.length q >= max_num then + let to_remove = Queue.pop q in + Hashtbl.remove t to_remove + ) ; + Queue.push name q ; Hashtbl.add t name version + +let get () = with_lock m @@ fun () -> Hashtbl.to_seq t |> List.of_seq + +let reset () = with_lock m @@ fun () -> Hashtbl.clear t ; Queue.clear q + +(* Record the user agent in memory hash table and exposed (name, version) list + by the interface get. + User-Agent format is like "name/version comment", see rfc2616. + Parse it as + - name: the first part of the string, up to the first space or slash, and + in the whitelist + - version: the part after the slash, up to the next space or end of string, + if no slash is found, then the version is empty + - comment: the rest of the string, which is ignored + Example: + "XAPI/1.0" -> ("XAPI", "1.0") + "XAPI/1.0 comment" -> ("XAPI", "1.0") + "XAPI" -> ("XAPI", "") + "XAPI 1.0 comment" -> ("XAPI", "") + "XAPI1.0" -> ("XAPI1.0", "") + When different versions of the same name are seen, keep the last-seen version. + Safety: + - Drop the user agent if its length exceeds max_user_agent_strlen. + - Remove the oldest entry if the record list length exceeds max_num. +*) +let track ~__context = + let ( let@ ) o f = Option.iter f o in + let@ user_agent = Context.get_user_agent __context in + let user_agent_strlen = String.length user_agent in + if user_agent_strlen <= max_user_agent_strlen then + let@ name, coming_version = + match String.split_on_char ' ' user_agent with + | name_version :: _ -> ( + match String.split_on_char '/' name_version with + | name :: version :: _ -> + Some (name, version) + | name :: [] -> + Some (name, "") + | [] -> + None + ) + | [] -> + None + in + update name coming_version diff --git a/ocaml/xapi/xapi_tracked_user_agents.mli b/ocaml/xapi/xapi_tracked_user_agents.mli new file mode 100644 index 0000000000..dc9522ac02 --- /dev/null +++ b/ocaml/xapi/xapi_tracked_user_agents.mli @@ -0,0 +1,24 @@ +(* + * 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. + *) + +val track : __context:Context.t -> unit +(** [track ~__context] parses and records the user agent from the context. + Only the name/version part is kept, and only if the string is not too long. + Oldest entries are evicted if the table is full. *) + +val get : unit -> (string * string) list +(** [get ()] returns the list of (name, version) pairs currently tracked. *) + +val reset : unit -> unit +(** [reset ()] clears all tracked user agents and the queue. *) diff --git a/ocaml/xapi/xapi_vbd.ml b/ocaml/xapi/xapi_vbd.ml index cf7ab17388..331284eb34 100644 --- a/ocaml/xapi/xapi_vbd.ml +++ b/ocaml/xapi/xapi_vbd.ml @@ -184,19 +184,26 @@ let create ~__context ~vM ~vDI ~device ~userdevice ~bootable ~mode ~_type (* CA-75697: Disallow VBD.create on a VM that's in the middle of a migration *) debug "Checking whether there's a migrate in progress..." ; let vm_current_ops = - Xapi_stdext_std.Listext.List.setify - (List.map snd (Db.VM.get_current_operations ~__context ~self:vM)) + List.sort_uniq + (fun (_ref1, op1) (_ref2, op2) -> compare op1 op2) + (Db.VM.get_current_operations ~__context ~self:vM) in + let migrate_ops = [`migrate_send; `pool_migrate] in let migrate_ops_in_progress = - List.filter (fun op -> List.mem op vm_current_ops) migrate_ops + List.filter (fun (_, op) -> List.mem op migrate_ops) vm_current_ops in match migrate_ops_in_progress with - | op :: _ -> + | (op_ref, op_type) :: _ -> raise (Api_errors.Server_error ( Api_errors.other_operation_in_progress - , ["VM"; Ref.string_of vM; Record_util.vm_operation_to_string op] + , [ + "VM" + ; Ref.string_of vM + ; Record_util.vm_operation_to_string op_type + ; op_ref + ] ) ) | _ -> diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index 3e74dfe1f8..07d6b012da 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -42,7 +42,9 @@ type table = (API.vbd_operations, (string * string list) option) Hashtbl.t let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = let _ref = Ref.string_of _ref' in let current_ops = - Listext.List.setify (List.map snd record.Db_actions.vBD_current_operations) + List.sort_uniq + (fun (_ref1, op1) (_ref2, op2) -> compare op1 op2) + record.Db_actions.vBD_current_operations in (* Policy: * current_ops must be empty [ will make exceptions later for eg eject/unplug of attached vbd ] @@ -74,30 +76,48 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = let safe_to_parallelise = [`pause; `unpause] in (* Any current_operations preclude everything that isn't safe to parallelise *) ( if current_ops <> [] then - let concurrent_op = List.hd current_ops in + let concurrent_op_ref, concurrent_op_type = List.hd current_ops in set_errors Api_errors.other_operation_in_progress - ["VBD"; _ref; vbd_operations_to_string concurrent_op] + [ + "VBD" + ; _ref + ; vbd_operations_to_string concurrent_op_type + ; concurrent_op_ref + ] (Listext.List.set_difference all_ops safe_to_parallelise) ) ; (* If not all operations are parallisable then preclude pause *) - let all_are_parallelisable = - List.fold_left ( && ) true - (List.map (fun op -> List.mem op safe_to_parallelise) current_ops) + let non_parallelisable_op = + List.find_opt + (fun (_, op) -> not (List.mem op safe_to_parallelise)) + current_ops in (* If not all are parallelisable, ban the otherwise parallelisable operations too *) - if not all_are_parallelisable then - set_errors Api_errors.other_operation_in_progress - ["VBD"; _ref; vbd_operations_to_string (List.hd current_ops)] - [`pause] ; + ( match non_parallelisable_op with + | Some (concurrent_op_ref, concurrent_op_type) -> + set_errors Api_errors.other_operation_in_progress + [ + "VBD" + ; _ref + ; vbd_operations_to_string concurrent_op_type + ; concurrent_op_ref + ] + [`pause] + | None -> + () + ) ; + (* If something other than `pause `unpause *and* `attach (for VM.reboot, see CA-24282) then disallow unpause *) - if - Listext.List.set_difference current_ops (`attach :: safe_to_parallelise) - <> [] - then - set_errors Api_errors.other_operation_in_progress - ["VBD"; _ref; vbd_operations_to_string (List.hd current_ops)] - [`unpause] ; + let set_difference a b = List.filter (fun (_, x) -> not (List.mem x b)) a in + ( match set_difference current_ops (`attach :: safe_to_parallelise) with + | (op_ref, op_type) :: _ -> + set_errors Api_errors.other_operation_in_progress + ["VBD"; _ref; vbd_operations_to_string op_type; op_ref] + [`unpause] + | [] -> + () + ) ; (* Drives marked as not unpluggable cannot be unplugged *) if not record.Db_actions.vBD_unpluggable then set_errors Api_errors.vbd_not_unpluggable [_ref] [`unplug; `unplug_force] ; @@ -128,7 +148,10 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = let bad_ops = [`plug; `unplug; `unplug_force] in (* However allow VBD pause and unpause if the VM is paused: *) let bad_ops' = - if power_state = `Paused then bad_ops else `pause :: `unpause :: bad_ops + if power_state = `Paused then + bad_ops + else + `pause :: `unpause :: bad_ops in set_errors Api_errors.vm_bad_power_state [Ref.string_of vm; expected; actual] @@ -226,17 +249,23 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = | _ -> true in - List.exists + List.find_opt (fun (_, operation) -> is_illegal_operation operation) vdi_record.Db_actions.vDI_current_operations in - ( if vdi_operations_besides_copy then - let concurrent_op = - snd (List.hd vdi_record.Db_actions.vDI_current_operations) - in + + ( match vdi_operations_besides_copy with + | Some (concurrent_op_ref, concurrent_op_type) -> set_errors Api_errors.other_operation_in_progress - ["VDI"; Ref.string_of vdi; vdi_operations_to_string concurrent_op] + [ + "VDI" + ; Ref.string_of vdi + ; vdi_operations_to_string concurrent_op_type + ; concurrent_op_ref + ] [`attach; `plug; `insert] + | None -> + () ) ; if (not record.Db_actions.vBD_currently_attached) && expensive_sharing_checks @@ -329,24 +358,17 @@ let assert_attachable ~__context ~self = let assert_doesnt_make_vm_non_agile ~__context ~vm ~vdi = let pool = Helpers.get_pool ~__context in - let properly_shared = - Agility.is_sr_properly_shared ~__context - ~self:(Db.VDI.get_SR ~__context ~self:vdi) - in + let sr = Db.VDI.get_SR ~__context ~self:vdi in + let properly_shared = Agility.is_sr_properly_shared ~__context ~self:sr in if true && Db.Pool.get_ha_enabled ~__context ~self:pool && (not (Db.Pool.get_ha_allow_overcommit ~__context ~self:pool)) && Helpers.is_xha_protected ~__context ~self:vm && not properly_shared - then ( - warn "Attaching VDI %s makes VM %s not agile" (Ref.string_of vdi) - (Ref.string_of vm) ; - raise - (Api_errors.Server_error - (Api_errors.ha_operation_would_break_failover_plan, []) - ) - ) + then + let sr = Ref.string_of sr in + raise Api_errors.(Server_error (ha_constraint_violation_sr_not_shared, [sr])) let update_allowed_operations ~__context ~self : unit = let all = Db.VBD.get_record_internal ~__context ~self in diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index 15dff1df4d..1148efe09c 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -63,51 +63,13 @@ let check_sm_feature_error (op : API.vdi_operations) sm_features sr = specified, it should contain at least all the VBD records from the database that are linked to this VDI. *) let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) - ?vbd_records ha_enabled record _ref' op = + ?vbd_records ha_enabled record _ref' = let ( let* ) = Result.bind in let _ref = Ref.string_of _ref' in let current_ops = record.Db_actions.vDI_current_operations in let reset_on_boot = record.Db_actions.vDI_on_boot = `reset in - (* Policy: - 1. any current_operation besides copy implies exclusivity; fail everything - else; except vdi mirroring is in current operations and destroy is performed - as part of vdi_pool_migrate. - 2. if a copy is ongoing, don't fail with other_operation_in_progress, as - blocked operations could then get stuck behind a long-running copy. - Instead, rely on the blocked_by_attach check further down to decide - whether an operation should be allowed. - 3. if doing a VM start then assume the sharing check is done elsewhere - (so VMs may share disks but our operations cannot) - 4. for other operations, fail if any VBD has currently-attached=true or any VBD - has a current_operation itself - 5. HA prevents you from deleting statefiles or metadata volumes - 6. During rolling pool upgrade, only operations known by older releases are allowed - *) - let* () = - if - Helpers.rolling_upgrade_in_progress ~__context - && not - (Xapi_globs.Vdi_operations_set.mem op - Xapi_globs.rpu_allowed_vdi_operations - ) - then - Error (Api_errors.not_supported_during_upgrade, []) - else - Ok () - in - let* () = - (* Don't fail with other_operation_in_progress if VDI mirroring is in - progress and destroy is called as part of VDI mirroring *) - let is_vdi_mirroring_in_progress = - op = `destroy && List.exists (fun (_, op) -> op = `mirror) current_ops - in - if - List.exists (fun (_, op) -> op <> `copy) current_ops - && not is_vdi_mirroring_in_progress - then - Error (Api_errors.other_operation_in_progress, ["VDI"; _ref]) - else - Ok () + let rolling_upgrade_in_progress = + Helpers.rolling_upgrade_in_progress ~__context in (* check to see whether it's a local cd drive *) let sr = record.Db_actions.vDI_SR in @@ -132,14 +94,6 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) ) pbd_records in - let* () = - if pbds_attached = [] && op = `resize then - Error (Api_errors.sr_no_pbds, [Ref.string_of sr]) - else - Ok () - in - - (* check to see whether VBDs exist which are using this VDI *) (* Only a 'live' operation can be performed if there are active (even RO) devices *) let my_active_vbd_records = @@ -191,252 +145,315 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) ) records in - (* If the VBD is currently_attached then some operations can still be - performed ie: VDI.clone (if the VM is suspended we have to have the - 'allow_clone_suspended_vm' flag); VDI.snapshot; VDI.resize_online; - 'blocked' (CP-831); VDI.data_destroy: it is not allowed on VDIs linked - to a VM, but the implementation first waits for the VDI's VBDs to be - unplugged and destroyed, and the checks are performed there. + + (* Policy: + 1. any current_operation besides copy implies exclusivity; fail everything + else; except vdi mirroring is in current operations and destroy is performed + as part of vdi_pool_migrate. + 2. if a copy is ongoing, don't fail with other_operation_in_progress, as + blocked operations could then get stuck behind a long-running copy. + Instead, rely on the blocked_by_attach check further down to decide + whether an operation should be allowed. + 3. if doing a VM start then assume the sharing check is done elsewhere + (so VMs may share disks but our operations cannot) + 4. for other operations, fail if any VBD has currently-attached=true or any VBD + has a current_operation itself + 5. HA prevents you from deleting statefiles or metadata volumes + 6. During rolling pool upgrade, only operations known by older releases are allowed *) - let operation_can_be_performed_live = - match op with - | `snapshot - | `resize_online - | `blocked - | `clone - | `mirror - | `enable_cbt - | `disable_cbt - | `data_destroy -> - true - | _ -> - false + let sm_features = + Xapi_sr_operations.features_of_sr_internal ~__context ~_type:sr_type in - let operation_can_be_performed_with_ro_attach = - operation_can_be_performed_live - || match op with `copy -> true | _ -> false + let vdi_is_ha_state_or_redolog = + List.mem record.Db_actions.vDI_type [`ha_statefile; `redo_log] in - (* NB RO vs RW sharing checks are done in xapi_vbd.ml *) - let blocked_by_attach = - let blocked_by_attach = - if operation_can_be_performed_live then - false - else if operation_can_be_performed_with_ro_attach then - my_active_rw_vbd_records <> [] + + fun op -> + let* () = + if + rolling_upgrade_in_progress + && not + (Xapi_globs.Vdi_operations_set.mem op + Xapi_globs.rpu_allowed_vdi_operations + ) + then + Error (Api_errors.not_supported_during_upgrade, []) else - my_active_vbd_records <> [] + Ok () in - let allow_attached_vbds = - (* We use Valid_ref_list.list to ignore exceptions due to invalid - references that could propagate to the message forwarding layer, which - calls this function to check for errors - these exceptions would - prevent the actual XenAPI function from being run. Checks called from - the message forwarding layer should not fail with an exception. *) - let true_for_all_active_vbds f = - Valid_ref_list.for_all f my_active_vbd_records + let* () = + (* Don't fail with other_operation_in_progress if VDI mirroring is in + progress and destroy is called as part of VDI mirroring *) + let is_vdi_mirroring_in_progress = + op = `destroy && List.exists (fun (_, op) -> op = `mirror) current_ops in - match op with - | `list_changed_blocks -> - let vbd_connected_to_vm_snapshot vbd = - let vm = vbd.Db_actions.vBD_VM in - Db.is_valid_ref __context vm - && Db.VM.get_is_a_snapshot ~__context ~self:vm - in - (* We allow list_changed_blocks on VDIs attached to snapshot VMs, - because VM.checkpoint may set the currently_attached fields of the - snapshot's VBDs to true, and this would block list_changed_blocks. *) - true_for_all_active_vbds vbd_connected_to_vm_snapshot + match + ( is_vdi_mirroring_in_progress + , List.find_opt (fun (_, op) -> op <> `copy) current_ops + ) + with + | false, Some (op_ref, op_type) -> + Error + ( Api_errors.other_operation_in_progress + , ["VDI"; _ref; API.vdi_operations_to_string op_type; op_ref] + ) | _ -> - false + Ok () in - blocked_by_attach && not allow_attached_vbds - in - let* () = - if blocked_by_attach then - Error - (Api_errors.vdi_in_use, [_ref; Record_util.vdi_operations_to_string op]) - else if - (* data_destroy first waits for all the VBDs to disappear in its - implementation, so it is harmless to allow it when any of the VDI's - VBDs have operations in progress. This ensures that we avoid the retry - mechanism of message forwarding and only use the event loop. *) - my_has_current_operation_vbd_records <> [] && op <> `data_destroy - then - Error (Api_errors.other_operation_in_progress, ["VDI"; _ref]) - else - Ok () - in - let sm_features = - Xapi_sr_operations.features_of_sr_internal ~__context ~_type:sr_type - in - let* () = check_sm_feature_error op sm_features sr in - let allowed_for_cbt_metadata_vdi = - match op with - | `clone - | `copy - | `disable_cbt - | `enable_cbt - | `mirror - | `resize - | `resize_online - | `snapshot - | `set_on_boot -> - false - | `blocked - | `data_destroy - | `destroy - | `list_changed_blocks - | `force_unlock - | `forget - | `generate_config - | `update -> - true - in - let* () = - if - (not allowed_for_cbt_metadata_vdi) - && record.Db_actions.vDI_type = `cbt_metadata - then - Error - ( Api_errors.vdi_incompatible_type - , [_ref; Record_util.vdi_type_to_string `cbt_metadata] - ) - else - Ok () - in - let allowed_when_cbt_enabled = - match op with - | `mirror | `set_on_boot -> - false - | `blocked - | `clone - | `copy - | `data_destroy - | `destroy - | `disable_cbt - | `enable_cbt - | `list_changed_blocks - | `force_unlock - | `forget - | `generate_config - | `resize - | `resize_online - | `snapshot - | `update -> - true - in - let* () = - if (not allowed_when_cbt_enabled) && record.Db_actions.vDI_cbt_enabled then - Error (Api_errors.vdi_cbt_enabled, [_ref]) - else - Ok () - in - let check_destroy () = - if sr_type = "udev" then - Error (Api_errors.vdi_is_a_physical_device, [_ref]) - else if is_tools_sr then - Error (Api_errors.sr_operation_not_supported, [Ref.string_of sr]) - else if List.mem record.Db_actions.vDI_type [`rrd] then - Error (Api_errors.vdi_has_rrds, [_ref]) - else if - ha_enabled - && List.mem record.Db_actions.vDI_type [`ha_statefile; `redo_log] - then - Error (Api_errors.ha_is_enabled, []) - else if - List.mem record.Db_actions.vDI_type [`ha_statefile; `redo_log] - && Xapi_pool_helpers.ha_enable_in_progress ~__context - then - Error (Api_errors.ha_enable_in_progress, []) - else if - List.mem record.Db_actions.vDI_type [`ha_statefile; `redo_log] - && Xapi_pool_helpers.ha_disable_in_progress ~__context - then - Error (Api_errors.ha_disable_in_progress, []) - else - Ok () - in - match op with - | `forget -> - if - ha_enabled - && List.mem record.Db_actions.vDI_type [`ha_statefile; `redo_log] - then - Error (Api_errors.ha_is_enabled, []) - else if List.mem record.Db_actions.vDI_type [`rrd] then - Error (Api_errors.vdi_has_rrds, [_ref]) + let* () = + if pbds_attached = [] && op = `resize then + Error (Api_errors.sr_no_pbds, [Ref.string_of sr]) else Ok () - | `destroy -> - check_destroy () - | `data_destroy -> - if not record.Db_actions.vDI_is_a_snapshot then + in + + (* check to see whether VBDs exist which are using this VDI *) + + (* If the VBD is currently_attached then some operations can still be + performed ie: VDI.clone (if the VM is suspended we have to have the + 'allow_clone_suspended_vm' flag); VDI.snapshot; VDI.resize_online; + 'blocked' (CP-831); VDI.data_destroy: it is not allowed on VDIs linked + to a VM, but the implementation first waits for the VDI's VBDs to be + unplugged and destroyed, and the checks are performed there. + *) + let operation_can_be_performed_live = + match op with + | `snapshot + | `resize_online + | `blocked + | `clone + | `mirror + | `enable_cbt + | `disable_cbt + | `data_destroy -> + true + | _ -> + false + in + let operation_can_be_performed_with_ro_attach = + operation_can_be_performed_live + || match op with `copy -> true | _ -> false + in + (* NB RO vs RW sharing checks are done in xapi_vbd.ml *) + let blocked_by_attach = + let blocked_by_attach = + if operation_can_be_performed_live then + false + else if operation_can_be_performed_with_ro_attach then + my_active_rw_vbd_records <> [] + else + my_active_vbd_records <> [] + in + let allow_attached_vbds = + (* We use Valid_ref_list.list to ignore exceptions due to invalid + references that could propagate to the message forwarding layer, which + calls this function to check for errors - these exceptions would + prevent the actual XenAPI function from being run. Checks called from + the message forwarding layer should not fail with an exception. *) + let true_for_all_active_vbds f = + Valid_ref_list.for_all f my_active_vbd_records + in + match op with + | `list_changed_blocks -> + let vbd_connected_to_vm_snapshot vbd = + let vm = vbd.Db_actions.vBD_VM in + Db.is_valid_ref __context vm + && Db.VM.get_is_a_snapshot ~__context ~self:vm + in + (* We allow list_changed_blocks on VDIs attached to snapshot VMs, + because VM.checkpoint may set the currently_attached fields of the + snapshot's VBDs to true, and this would block list_changed_blocks. *) + true_for_all_active_vbds vbd_connected_to_vm_snapshot + | _ -> + false + in + blocked_by_attach && not allow_attached_vbds + in + let* () = + if blocked_by_attach then Error - (Api_errors.operation_not_allowed, ["VDI is not a snapshot: " ^ _ref]) - else if not record.Db_actions.vDI_cbt_enabled then - Error (Api_errors.vdi_no_cbt_metadata, [_ref]) - else - check_destroy () - | `resize -> - if - ha_enabled - && List.mem record.Db_actions.vDI_type [`ha_statefile; `redo_log] + ( Api_errors.vdi_in_use + , [_ref; Record_util.vdi_operations_to_string op] + ) + else if + (* data_destroy first waits for all the VBDs to disappear in its + implementation, so it is harmless to allow it when any of the VDI's + VBDs have operations in progress. This ensures that we avoid the retry + mechanism of message forwarding and only use the event loop. *) + my_has_current_operation_vbd_records <> [] && op <> `data_destroy then - Error (Api_errors.ha_is_enabled, []) + let op_ref, op_type = + List.hd + (List.hd my_has_current_operation_vbd_records) + .Db_actions.vBD_current_operations + in + Error + ( Api_errors.other_operation_in_progress + , ["VDI"; _ref; API.vbd_operations_to_string op_type; op_ref] + ) else Ok () - | `resize_online -> + in + let* () = check_sm_feature_error op sm_features sr in + let allowed_for_cbt_metadata_vdi = + match op with + | `clone + | `copy + | `disable_cbt + | `enable_cbt + | `mirror + | `resize + | `resize_online + | `snapshot + | `set_on_boot -> + false + | `blocked + | `data_destroy + | `destroy + | `list_changed_blocks + | `force_unlock + | `forget + | `generate_config + | `update -> + true + in + let* () = if - ha_enabled - && List.mem record.Db_actions.vDI_type [`ha_statefile; `redo_log] + (not allowed_for_cbt_metadata_vdi) + && record.Db_actions.vDI_type = `cbt_metadata then - Error (Api_errors.ha_is_enabled, []) - else - Ok () - | `snapshot when record.Db_actions.vDI_sharable -> - Error (Api_errors.vdi_is_sharable, [_ref]) - | (`snapshot | `copy) when reset_on_boot -> - Error (Api_errors.vdi_on_boot_mode_incompatible_with_operation, []) - | `snapshot -> - if List.exists (fun (_, op) -> op = `copy) current_ops then Error - ( Api_errors.operation_not_allowed - , ["Snapshot operation not allowed during copy."] + ( Api_errors.vdi_incompatible_type + , [_ref; Record_util.vdi_type_to_string `cbt_metadata] ) else Ok () - | `copy -> - if List.mem record.Db_actions.vDI_type [`ha_statefile; `redo_log] then - Error - ( Api_errors.operation_not_allowed - , [ - "VDI containing HA statefile or redo log cannot be copied (check \ - the VDI's allowed operations)." - ] - ) + in + let allowed_when_cbt_enabled = + match op with + | `mirror | `set_on_boot -> + false + | `blocked + | `clone + | `copy + | `data_destroy + | `destroy + | `disable_cbt + | `enable_cbt + | `list_changed_blocks + | `force_unlock + | `forget + | `generate_config + | `resize + | `resize_online + | `snapshot + | `update -> + true + in + let* () = + if (not allowed_when_cbt_enabled) && record.Db_actions.vDI_cbt_enabled + then + Error (Api_errors.vdi_cbt_enabled, [_ref]) else Ok () - | `enable_cbt | `disable_cbt -> - if record.Db_actions.vDI_is_a_snapshot then - Error (Api_errors.operation_not_allowed, ["VDI is a snapshot: " ^ _ref]) - else if not (List.mem record.Db_actions.vDI_type [`user; `system]) then - Error - ( Api_errors.vdi_incompatible_type - , [_ref; Record_util.vdi_type_to_string record.Db_actions.vDI_type] - ) - else if reset_on_boot then - Error (Api_errors.vdi_on_boot_mode_incompatible_with_operation, []) + in + let check_destroy () = + if sr_type = "udev" then + Error (Api_errors.vdi_is_a_physical_device, [_ref]) + else if is_tools_sr then + Error (Api_errors.sr_operation_not_supported, [Ref.string_of sr]) + else if List.mem record.Db_actions.vDI_type [`rrd] then + Error (Api_errors.vdi_has_rrds, [_ref]) + else if ha_enabled && vdi_is_ha_state_or_redolog then + Error (Api_errors.ha_is_enabled, []) + else if + vdi_is_ha_state_or_redolog + && Xapi_pool_helpers.ha_enable_in_progress ~__context + then + Error (Api_errors.ha_enable_in_progress, []) + else if + vdi_is_ha_state_or_redolog + && Xapi_pool_helpers.ha_disable_in_progress ~__context + then + Error (Api_errors.ha_disable_in_progress, []) else Ok () - | `mirror - | `clone - | `generate_config - | `force_unlock - | `set_on_boot - | `list_changed_blocks - | `blocked - | `update -> - Ok () + in + match op with + | `forget -> + if ha_enabled && vdi_is_ha_state_or_redolog then + Error (Api_errors.ha_is_enabled, []) + else if List.mem record.Db_actions.vDI_type [`rrd] then + Error (Api_errors.vdi_has_rrds, [_ref]) + else + Ok () + | `destroy -> + check_destroy () + | `data_destroy -> + if not record.Db_actions.vDI_is_a_snapshot then + Error + ( Api_errors.operation_not_allowed + , ["VDI is not a snapshot: " ^ _ref] + ) + else if not record.Db_actions.vDI_cbt_enabled then + Error (Api_errors.vdi_no_cbt_metadata, [_ref]) + else + check_destroy () + | `resize -> + if ha_enabled && vdi_is_ha_state_or_redolog then + Error (Api_errors.ha_is_enabled, []) + else + Ok () + | `resize_online -> + if ha_enabled && vdi_is_ha_state_or_redolog then + Error (Api_errors.ha_is_enabled, []) + else + Ok () + | `snapshot when record.Db_actions.vDI_sharable -> + Error (Api_errors.vdi_is_sharable, [_ref]) + | (`snapshot | `copy) when reset_on_boot -> + Error (Api_errors.vdi_on_boot_mode_incompatible_with_operation, []) + | `snapshot -> + if List.exists (fun (_, op) -> op = `copy) current_ops then + Error + ( Api_errors.operation_not_allowed + , ["Snapshot operation not allowed during copy."] + ) + else + Ok () + | `copy -> + if vdi_is_ha_state_or_redolog then + Error + ( Api_errors.operation_not_allowed + , [ + "VDI containing HA statefile or redo log cannot be copied \ + (check the VDI's allowed operations)." + ] + ) + else + Ok () + | `enable_cbt | `disable_cbt -> + if record.Db_actions.vDI_is_a_snapshot then + Error + (Api_errors.operation_not_allowed, ["VDI is a snapshot: " ^ _ref]) + else if not (List.mem record.Db_actions.vDI_type [`user; `system]) then + Error + ( Api_errors.vdi_incompatible_type + , [_ref; Record_util.vdi_type_to_string record.Db_actions.vDI_type] + ) + else if reset_on_boot then + Error (Api_errors.vdi_on_boot_mode_incompatible_with_operation, []) + else + Ok () + | `mirror + | `clone + | `generate_config + | `force_unlock + | `set_on_boot + | `list_changed_blocks + | `blocked + | `update -> + Ok () let assert_operation_valid ~__context ~self ~(op : API.vdi_operations) = let pool = Helpers.get_pool ~__context in @@ -486,16 +503,11 @@ let update_allowed_operations_internal ~__context ~self ~sr_records ~pbd_records v in let allowed = - let check x = - match - check_operation_error ~__context ~sr_records ~pbd_records ?vbd_records - ha_enabled all self x - with - | Ok () -> - true - | _ -> - false + let check' = + check_operation_error ~__context ~sr_records ~pbd_records ?vbd_records + ha_enabled all self in + let check x = match check' x with Ok () -> true | _ -> false in all_ops |> Xapi_globs.Vdi_operations_set.filter check in let allowed = @@ -837,6 +849,7 @@ let snapshot_and_clone call_f ~__context ~vdi ~driver_params = Db.VDI.set_on_boot ~__context ~self:newvdi ~value:vdi_rec.API.vDI_on_boot ; Db.VDI.set_allow_caching ~__context ~self:newvdi ~value:vdi_rec.API.vDI_allow_caching ; + Db.VDI.set_tags ~__context ~self:newvdi ~value:vdi_rec.API.vDI_tags ; newvdi let snapshot ~__context ~vdi ~driver_params = diff --git a/ocaml/xapi/xapi_vdi_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml index 3cc2d4a7f5..84db627c71 100644 --- a/ocaml/xapi/xapi_vdi_helpers.ml +++ b/ocaml/xapi/xapi_vdi_helpers.ml @@ -184,7 +184,7 @@ let database_ref_of_vdi ~__context ~vdi = debug "Enabling redo_log with device reason [%s]" device ; Redo_log.enable_block_existing log device ; let db = Database.make (Datamodel_schema.of_datamodel ()) in - let db_ref = Xapi_database.Db_ref.in_memory (ref (ref db)) in + let db_ref = Xapi_database.Db_ref.in_memory (Atomic.make db) in Redo_log_usage.read_from_redo_log log Xapi_globs.foreign_metadata_db db_ref ; Redo_log.delete log ; (* Upgrade database to the local schema. *) diff --git a/ocaml/xapi/xapi_vgpu_type.ml b/ocaml/xapi/xapi_vgpu_type.ml index f7d5e1eb40..aae64cef19 100644 --- a/ocaml/xapi/xapi_vgpu_type.ml +++ b/ocaml/xapi/xapi_vgpu_type.ml @@ -1033,7 +1033,9 @@ module Nvidia_compat = struct read_configs ac tl ) in - let conf_files = Array.to_list (Sys.readdir conf_dir) in + let conf_files = + try Array.to_list (Sys.readdir conf_dir) with Sys_error _ -> [] + in debug "Reading NVIDIA vGPU config files %s/{%s}" conf_dir (String.concat ", " conf_files) ; read_configs [] diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 2fab562dbe..37de1b7777 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -50,18 +50,20 @@ let valid_operations ~__context record _ref' : table = in let vm = Db.VIF.get_VM ~__context ~self:_ref' in (* Any current_operations preclude everything else *) - if current_ops <> [] then ( - debug "No operations are valid because current-operations = [ %s ]" - (String.concat "; " - (List.map - (fun (task, op) -> task ^ " -> " ^ vif_operations_to_string op) - current_ops - ) - ) ; - let concurrent_op = snd (List.hd current_ops) in - set_errors Api_errors.other_operation_in_progress - ["VIF"; _ref; vif_operations_to_string concurrent_op] - all_ops + ( if current_ops <> [] then + let concurrent_op_refs, concurrent_op_types = + List.fold_left + (fun (refs, types) (ref, op) -> + (ref :: refs, vif_operations_to_string op :: types) + ) + ([], []) current_ops + in + let format x = Printf.sprintf "{%s}" (String.concat "; " x) in + let concurrent_op_refs = format concurrent_op_refs in + let concurrent_op_types = format concurrent_op_types in + set_errors Api_errors.other_operation_in_progress + ["VIF"; _ref; concurrent_op_types; concurrent_op_refs] + all_ops ) ; (* No hotplug on dom0 *) if Helpers.is_domain_zero ~__context vm then @@ -192,10 +194,11 @@ let clear_current_operations ~__context ~self = (**************************************************************************************) -(** Check if the device string has the right form *) +(** Check if the device string has the right form - it should only be an + unsigned decimal integer *) let valid_device dev = try - ignore (int_of_string dev) ; + Scanf.sscanf dev "%u%!" ignore ; true with _ -> false @@ -264,19 +267,18 @@ let create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config raise (Api_errors.Server_error (Api_errors.mac_invalid, [mAC])) ; (* Make people aware that non-shared networks being added to VMs makes them not agile *) let pool = Helpers.get_pool ~__context in - if - true - && Db.Pool.get_ha_enabled ~__context ~self:pool - && (not (Db.Pool.get_ha_allow_overcommit ~__context ~self:pool)) - && Helpers.is_xha_protected ~__context ~self:vM - && not (Agility.is_network_properly_shared ~__context ~self:network) - then ( - warn "Creating VIF %s makes VM %s not agile" (Ref.string_of ref) - (Ref.string_of vM) ; - raise - (Api_errors.Server_error - (Api_errors.ha_operation_would_break_failover_plan, []) - ) + ( if + true + && Db.Pool.get_ha_enabled ~__context ~self:pool + && (not (Db.Pool.get_ha_allow_overcommit ~__context ~self:pool)) + && Helpers.is_xha_protected ~__context ~self:vM + && not (Agility.is_network_properly_shared ~__context ~self:network) + then + let net = Ref.string_of network in + raise + Api_errors.( + Server_error (ha_constraint_violation_network_not_shared, [net]) + ) ) ; (* Check to make sure the device is unique *) Xapi_stdext_threads.Threadext.Mutex.execute m (fun () -> @@ -288,8 +290,7 @@ let create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config in let new_device = int_of_string device in if List.exists (fun (_, d) -> d = new_device) all_vifs_with_devices then - raise - (Api_errors.Server_error (Api_errors.device_already_exists, [device])) ; + raise Api_errors.(Server_error (device_already_exists, [device])) ; (* If the VM uses a PVS_proxy, then the proxy _must_ be associated with the VIF that has the lowest device number. Check that the new VIF diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 78967197a8..21b1704e8d 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -65,7 +65,8 @@ let update_allowed_operations ~__context ~self = let assert_can_boot_here ~__context ~self ~host = let snapshot = Db.VM.get_record ~__context ~self in if Helpers.rolling_upgrade_in_progress ~__context then - Helpers.assert_platform_version_is_same_on_master ~__context ~host ~self ; + Helpers.Checks.RPU.assert_host_versions_are_same_on_master ~__context ~host + ~self ; assert_can_boot_here ~__context ~self ~host ~snapshot ~do_cpuid_check:true () let retrieve_wlb_recommendations ~__context ~vm = @@ -89,9 +90,6 @@ let retrieve_wlb_recommendations ~__context ~vm = let assert_agile ~__context ~self = Agility.vm_assert_agile ~__context ~self -(* helpers *) -let immediate_complete ~__context = Helpers.progress ~__context (0.0 -. 1.0) - (* API *) let set_actions_after_crash ~__context ~self ~value = set_actions_after_crash ~__context ~self ~value @@ -1171,6 +1169,11 @@ let call_plugin ~__context ~vm ~plugin ~fn ~args = (Api_errors.xenapi_plugin_failure, ["failed to execute fn"; msg; msg]) ) +let call_host_plugin ~__context ~vm ~plugin ~fn ~args = + (* vm is unused; was used to find the host *) + let _ = vm in + Xapi_plugins.call_plugin (Context.get_session_id __context) plugin fn args + let send_sysrq ~__context ~vm:_ ~key:_ = raise (Api_errors.Server_error (Api_errors.not_implemented, ["send_sysrq"])) @@ -1349,11 +1352,11 @@ let set_suspend_VDI ~__context ~self ~value = let dst_vdi = value in if src_vdi <> dst_vdi then ( (* - * We don't care if the future host can see current suspend VDI or not, but - * we want to make sure there's at least a host can see all the VDIs of the - * VM + the new suspend VDI. We raise an exception if there's no suitable - * host. - *) + * We don't care if the future host can see current suspend VDI or not, but + * we want to make sure there's at least a host can see all the VDIs of the + * VM + the new suspend VDI. We raise an exception if there's no suitable + * host. + *) let vbds = Db.VM.get_VBDs ~__context ~self in let vbds = List.filter (fun self -> not (Db.VBD.get_empty ~__context ~self)) vbds @@ -1613,7 +1616,7 @@ let nvram = Mutex.create () let set_NVRAM_EFI_variables ~__context ~self ~value = with_lock nvram (fun () -> (* do not use remove_from_NVRAM: we do not want to - * temporarily end up with an empty NVRAM in HA *) + * temporarily end up with an empty NVRAM in HA *) let key = "EFI-variables" in let nvram = Db.VM.get_NVRAM ~__context ~self in let value = (key, value) :: List.remove_assoc key nvram in @@ -1699,3 +1702,46 @@ let get_secureboot_readiness ~__context ~self = ) ) ) + +let sysprep ~__context ~self ~unattend ~timeout = + let uuid = Db.VM.get_uuid ~__context ~self in + debug "%s %S (timeout %f)" __FUNCTION__ uuid timeout ; + if timeout < 0.0 then + raise + Api_errors.( + Server_error (invalid_value, ["timeout"; string_of_float timeout]) + ) ; + match Vm_sysprep.sysprep ~__context ~vm:self ~unattend ~timeout with + | () -> + debug "%s %S success" __FUNCTION__ uuid ; + () + | exception Vm_sysprep.Sysprep API_not_enabled -> + raise Api_errors.(Server_error (sysprep, [uuid; "API call is disabled"])) + | exception Vm_sysprep.Sysprep VM_CDR_not_found -> + raise Api_errors.(Server_error (sysprep, [uuid; "CD-ROM drive not found"])) + | exception Vm_sysprep.Sysprep VM_misses_feature -> + raise + Api_errors.( + Server_error (sysprep, [uuid; "VM driver does not support sysprep"]) + ) + | exception Vm_sysprep.Sysprep VM_not_running -> + raise Api_errors.(Server_error (sysprep, [uuid; "VM is not running"])) + | exception Vm_sysprep.Sysprep VM_CDR_eject -> + raise Api_errors.(Server_error (sysprep, [uuid; "VM failed to eject CD"])) + | exception Vm_sysprep.Sysprep VM_CDR_insert -> + raise Api_errors.(Server_error (sysprep, [uuid; "VM failed to insert CD"])) + | exception Vm_sysprep.Sysprep VM_sysprep_timeout -> + raise + Api_errors.( + Server_error + (sysprep, [uuid; "No response from sysprep within allocated time"]) + ) + | exception Vm_sysprep.Sysprep XML_too_large -> + raise + Api_errors.( + Server_error (sysprep, [uuid; "unattend.xml file too large"]) + ) + | exception Vm_sysprep.Sysprep (Other msg) -> + raise Api_errors.(Server_error (sysprep, [uuid; msg])) + | exception e -> + raise e diff --git a/ocaml/xapi/xapi_vm.mli b/ocaml/xapi/xapi_vm.mli index d0771c49cf..b3f07d38a9 100644 --- a/ocaml/xapi/xapi_vm.mli +++ b/ocaml/xapi/xapi_vm.mli @@ -32,8 +32,6 @@ val retrieve_wlb_recommendations : val assert_agile : __context:Context.t -> self:[`VM] Ref.t -> unit -val immediate_complete : __context:Context.t -> unit - val set_actions_after_crash : __context:Context.t -> self:[`VM] Ref.t @@ -401,6 +399,14 @@ val call_plugin : -> args:(string * string) list -> string +val call_host_plugin : + __context:Context.t + -> vm:API.ref_VM + -> plugin:string + -> fn:string + -> args:(string * string) list + -> string + val set_has_vendor_device : __context:Context.t -> self:API.ref_VM -> value:bool -> unit @@ -444,3 +450,10 @@ val add_to_blocked_operations : val remove_from_blocked_operations : __context:Context.t -> self:API.ref_VM -> key:API.vm_operations -> unit + +val sysprep : + __context:Context.t + -> self:API.ref_VM + -> unattend:SecretString.t + -> timeout:float + -> unit diff --git a/ocaml/xapi/xapi_vm_appliance_lifecycle.ml b/ocaml/xapi/xapi_vm_appliance_lifecycle.ml index 330d028cf1..765fd9c356 100644 --- a/ocaml/xapi/xapi_vm_appliance_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_appliance_lifecycle.ml @@ -18,38 +18,48 @@ let check_operation_error ~__context record self op = let _ref = Ref.string_of self in let current_ops = record.Db_actions.vM_appliance_current_operations in (* Only allow one operation of [`start | `clean_shutdown | `hard_shutdown | `shutdown ] at a time. *) - if current_ops <> [] then - Some (Api_errors.other_operation_in_progress, ["VM_appliance"; _ref]) - else - let vms = Db.VM_appliance.get_VMs ~__context ~self in - if vms = [] then - Some (Api_errors.operation_not_allowed, ["Appliance has no VMs."]) - else (* Allow the op if any VMs are in a state where the op makes sense. *) - let power_states = - List.map (fun vm -> Db.VM.get_power_state ~__context ~self:vm) vms - in - let predicate, error = - match op with - (* Can start if any are halted. *) - | `start -> - ( (fun power_state -> power_state = `Halted) - , "There are no halted VMs in this appliance." - ) - (* Can clean_shutdown if any are running. *) - | `clean_shutdown -> - ( (fun power_state -> power_state = `Running) - , "There are no running VMs in this appliance." - ) - (* Can hard_shutdown/shutdown if any are not halted. *) - | `hard_shutdown | `shutdown -> - ( (fun power_state -> power_state <> `Halted) - , "All VMs in this appliance are halted." - ) - in - if List.exists predicate power_states then - None + match current_ops with + | (op_ref, op_type) :: _ -> + Some + ( Api_errors.other_operation_in_progress + , [ + "VM_appliance" + ; _ref + ; API.vm_appliance_operation_to_string op_type + ; op_ref + ] + ) + | [] -> + let vms = Db.VM_appliance.get_VMs ~__context ~self in + if vms = [] then + Some (Api_errors.operation_not_allowed, ["Appliance has no VMs."]) else - Some (Api_errors.operation_not_allowed, [error]) + (* Allow the op if any VMs are in a state where the op makes sense. *) + let power_states = + List.map (fun vm -> Db.VM.get_power_state ~__context ~self:vm) vms + in + let predicate, error = + match op with + (* Can start if any are halted. *) + | `start -> + ( (fun power_state -> power_state = `Halted) + , "There are no halted VMs in this appliance." + ) + (* Can clean_shutdown if any are running. *) + | `clean_shutdown -> + ( (fun power_state -> power_state = `Running) + , "There are no running VMs in this appliance." + ) + (* Can hard_shutdown/shutdown if any are not halted. *) + | `hard_shutdown | `shutdown -> + ( (fun power_state -> power_state <> `Halted) + , "All VMs in this appliance are halted." + ) + in + if List.exists predicate power_states then + None + else + Some (Api_errors.operation_not_allowed, [error]) let assert_operation_valid ~__context ~self ~(op : API.vm_appliance_operation) = let all = Db.VM_appliance.get_record_internal ~__context ~self in diff --git a/ocaml/xapi/xapi_vm_clone.ml b/ocaml/xapi/xapi_vm_clone.ml index 09ae3431f2..eaf73576d1 100644 --- a/ocaml/xapi/xapi_vm_clone.ml +++ b/ocaml/xapi/xapi_vm_clone.ml @@ -507,9 +507,6 @@ let clone ?snapshot_info_record ?(ignore_vdis = []) disk_op ~__context ~vm let original = Db.VM.get_suspend_VDI ~__context ~self:vm in if original = Ref.null || disk_op = Disk_op_snapshot then Ref.null - else if disk_op = Disk_op_checkpoint && power_state = `Runnning - then - original else clone_single_vdi rpc session_id disk_op ~__context original driver_params diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index 9daab6113e..fc5f0db762 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -497,7 +497,7 @@ let has_non_allocated_vgpus ~__context ~self = * 4. Remove the list head from the remainding vGPU list of the VM * 5. Repeat step 2-4 until fail or the remainding list is empty * 6. Return success - * *) + *) let assert_gpus_available ~__context ~self ~host = let vgpus = Db.VM.get_VGPUs ~__context ~self in let vGPU_structs = List.map (Vgpuops.vgpu_of_ref ~__context) vgpus in @@ -876,7 +876,7 @@ let vm_can_run_on_host ~__context ~vm ~snapshot ~do_memory_check host = let is_control_domain = Db.VM.get_is_control_domain ~__context ~self:vm in let host_has_proper_version () = if Helpers.rolling_upgrade_in_progress ~__context then - Helpers.host_has_highest_version_in_pool ~__context + Helpers.Checks.RPU.host_has_highest_version_in_pool ~__context ~host:(Helpers.LocalObject host) else true @@ -1304,9 +1304,9 @@ let allowed_VBD_devices_HVM_floppy = (fun x -> Device_number.(make Floppy ~disk:x ~partition:0)) (inclusive_range 0 1) -let allowed_VIF_devices_HVM = vif_inclusive_range 0 6 +let allowed_VIF_devices_HVM = vif_inclusive_range 0 15 -let allowed_VIF_devices_PV = vif_inclusive_range 0 6 +let allowed_VIF_devices_PV = vif_inclusive_range 0 15 (** [possible_VBD_devices_of_string s] returns a list of Device_number.t which represent possible interpretations of [s]. *) @@ -1672,8 +1672,10 @@ let ensure_device_model_profile_present ~__context ~domain_type ~is_a_template let trad = Vm_platform.(device_model, fallback_device_model_stage_1) in if is_a_template then platform - else if (not needs_qemu) || List.mem_assoc Vm_platform.device_model platform - then (* upgrade existing Device Model entry *) + else if + (not needs_qemu) || List.mem_assoc Vm_platform.device_model platform + (* upgrade existing Device Model entry *) + then platform |> List.map (fun entry -> if entry = trad then default else entry) else (* only add device-model to an HVM VM platform if it is not already there *) diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index 9ab13f79b5..14290421fb 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -61,6 +61,7 @@ let allowed_power_states ~__context ~vmr ~(op : API.vm_operations) = | `send_sysrq | `send_trigger | `snapshot_with_quiesce + | `sysprep | `suspend -> [`Running] | `changing_dynamic_range -> @@ -151,6 +152,12 @@ let has_feature ~vmgmr ~feature = try List.assoc feature other = "1" with Not_found -> false ) +let get_feature ~vmgmr ~feature = + Option.bind vmgmr (fun gmr -> + let other = gmr.Db_actions.vM_guest_metrics_other in + List.assoc_opt feature other + ) + (* Returns `true` only if we are certain that the VM has booted PV (if there * is no metrics record, then we can't tell) *) let has_definitely_booted_pv ~vmmr = @@ -166,45 +173,58 @@ let has_definitely_booted_pv ~vmmr = ) (** Return an error iff vmr is an HVM guest and lacks a needed feature. - * Note: it turned out that the Windows guest agent does not write "feature-suspend" - * on resume (only on startup), so we cannot rely just on that flag. We therefore - * add a clause that enables all features when PV drivers are present using the - * old-style check. + + * Note: The FreeBSD driver used by NetScaler supports all power actions. + * However, older versions of the FreeBSD driver do not explicitly advertise + * these support. As a result, xapi does not attempt to signal these power + * actions. To address this as a workaround, all power actions should be + * permitted for FreeBSD guests. + + * Additionally, VMs with an explicit `data/cant_suspend_reason` set aren't + * allowed to suspend, which would crash Windows and other UEFI VMs. + * The "strict" param should be true for determining the allowed_operations list * (which is advisory only) and false (more permissive) when we are potentially about * to perform an operation. This makes a difference for ops that require the guest to * react helpfully. *) let check_op_for_feature ~__context ~vmr:_ ~vmmr ~vmgmr ~power_state ~op ~ref ~strict = - if + let implicit_support = power_state <> `Running (* PV guests offer support implicitly *) || has_definitely_booted_pv ~vmmr || Xapi_pv_driver_version.(has_pv_drivers (of_guest_metrics vmgmr)) (* Full PV drivers imply all features *) - then - None - else - let some_err e = Some (e, [Ref.string_of ref]) in - let lack_feature feature = not (has_feature ~vmgmr ~feature) in - match op with - | `clean_shutdown - when strict - && lack_feature "feature-shutdown" - && lack_feature "feature-poweroff" -> - some_err Api_errors.vm_lacks_feature - | `clean_reboot - when strict - && lack_feature "feature-shutdown" - && lack_feature "feature-reboot" -> - some_err Api_errors.vm_lacks_feature - | `changing_VCPUs_live when lack_feature "feature-vcpu-hotplug" -> - some_err Api_errors.vm_lacks_feature - | (`suspend | `checkpoint | `pool_migrate | `migrate_send) - when strict && lack_feature "feature-suspend" -> + in + let some_err e = Some (e, [Ref.string_of ref]) in + let lack_feature feature = not (has_feature ~vmgmr ~feature) in + match op with + | `suspend | `checkpoint | `pool_migrate | `migrate_send -> ( + match get_feature ~vmgmr ~feature:"data-cant-suspend-reason" with + | Some reason -> + Some (Api_errors.vm_non_suspendable, [Ref.string_of ref; reason]) + | None + when (not implicit_support) && strict && lack_feature "feature-suspend" -> some_err Api_errors.vm_lacks_feature - | _ -> + | None -> None + ) + | _ when implicit_support -> + None + | `clean_shutdown + when strict + && lack_feature "feature-shutdown" + && lack_feature "feature-poweroff" -> + some_err Api_errors.vm_lacks_feature + | `clean_reboot + when strict + && lack_feature "feature-shutdown" + && lack_feature "feature-reboot" -> + some_err Api_errors.vm_lacks_feature + | `changing_VCPUs_live when lack_feature "feature-vcpu-hotplug" -> + some_err Api_errors.vm_lacks_feature + | _ -> + None (* N.B. In the pattern matching above, "pat1 | pat2 | pat3" counts as * one pattern, and the whole thing can be guarded by a "when" clause. *) @@ -269,42 +289,26 @@ let report_power_state_error ~__context ~vmr ~power_state ~op ~ref_str = Some (Api_errors.vm_bad_power_state, [ref_str; expected; actual]) let report_concurrent_operations_error ~current_ops ~ref_str = - let current_ops_str = + let current_ops_ref_str, current_ops_str = + let op_to_str = Record_util.vm_operation_to_string in + let ( >> ) f g x = g (f x) in match current_ops with | [] -> failwith "No concurrent operation to report" - | [(_, cop)] -> - Record_util.vm_operation_to_string cop + | [(op_ref, cop)] -> + (op_ref, op_to_str cop) | l -> - "{" - ^ String.concat "," - (List.map Record_util.vm_operation_to_string (List.map snd l)) - ^ "}" + ( Printf.sprintf "{%s}" (String.concat "," (List.map fst l)) + , Printf.sprintf "{%s}" + (String.concat "," (List.map (snd >> op_to_str) l)) + ) in Some - (Api_errors.other_operation_in_progress, ["VM." ^ current_ops_str; ref_str]) + ( Api_errors.other_operation_in_progress + , ["VM"; ref_str; current_ops_str; current_ops_ref_str] + ) let check_vgpu ~__context ~op ~ref_str ~vgpus ~power_state = - let is_migratable vgpu = - try - (* Prevent VMs with VGPU from being migrated from pre-Jura to Jura and later hosts during RPU *) - let host_from = - Db.VGPU.get_VM ~__context ~self:vgpu |> fun vm -> - Db.VM.get_resident_on ~__context ~self:vm |> fun host -> - Helpers.LocalObject host - in - (* true if platform version of host_from more than inverness' 2.4.0 *) - Helpers.( - compare_int_lists - (version_of ~__context host_from) - platform_version_inverness - ) - > 0 - with e -> - debug "is_migratable: %s" (ExnHelper.string_of_exn e) ; - (* best effort: yes if not possible to decide *) - true - in let is_suspendable vgpu = Db.VGPU.get_type ~__context ~self:vgpu |> fun self -> Db.VGPU_type.get_implementation ~__context ~self |> function @@ -319,9 +323,7 @@ let check_vgpu ~__context ~op ~ref_str ~vgpus ~power_state = match op with | `migrate_send when power_state = `Halted -> None - | (`pool_migrate | `migrate_send) - when List.for_all is_migratable vgpus && List.for_all is_suspendable vgpus - -> + | (`pool_migrate | `migrate_send) when List.for_all is_suspendable vgpus -> None | `checkpoint when power_state = `Suspended -> None @@ -393,8 +395,7 @@ let nested_virt ~__context vm metrics = let key = "nested-virt" in Vm_platform.is_true ~key ~platformdata ~default:false -let is_mobile ~__context vm strict = - let metrics = Db.VM.get_metrics ~__context ~self:vm in +let is_mobile ~__context vm strict metrics = (not @@ nomigrate ~__context vm metrics) && (not @@ nested_virt ~__context vm metrics) || not strict @@ -419,7 +420,7 @@ let nvidia_sriov_pcis ~__context vgpus = Db.VGPU_type.get_implementation ~__context ~self:typ |> function | `nvidia_sriov -> let pci = Db.VGPU.get_PCI ~__context ~self:vgpu in - if Db.is_valid_ref __context pci then Some pci else None + Some pci | _ -> None ) @@ -447,6 +448,42 @@ let check_operation_error ~__context ~ref = vmr.Db_actions.vM_VBDs |> List.filter (Db.is_valid_ref __context) in + let current_ops = vmr.Db_actions.vM_current_operations in + let metrics = Db.VM.get_metrics ~__context ~self:ref in + let is_nested_virt = nested_virt ~__context ref metrics in + let is_domain_zero = + Db.VM.get_by_uuid ~__context ~uuid:vmr.Db_actions.vM_uuid + |> Helpers.is_domain_zero ~__context + in + let vdis_reset_and_caching = + List.filter_map + (fun vdi -> + try + let sm_config = Db.VDI.get_sm_config ~__context ~self:vdi in + Some + ( List.assoc_opt "on_boot" sm_config = Some "reset" + , bool_of_assoc "caching" sm_config + ) + with _ -> None + ) + vdis + in + let sriov_pcis = nvidia_sriov_pcis ~__context vmr.Db_actions.vM_VGPUs in + let is_not_sriov pci = not @@ List.mem pci sriov_pcis in + let pcis = vmr.Db_actions.vM_attached_PCIs in + let is_appliance_valid = + Db.is_valid_ref __context vmr.Db_actions.vM_appliance + in + let is_protection_policy_valid = + Db.is_valid_ref __context vmr.Db_actions.vM_protection_policy + in + let rolling_upgrade_in_progress = + Helpers.rolling_upgrade_in_progress ~__context + in + let is_snapshort_schedule_valid = + Db.is_valid_ref __context vmr.Db_actions.vM_snapshot_schedule + in + fun ~op ~strict -> let current_error = None in let check c f = match c with Some e -> Some e | None -> f () in @@ -470,10 +507,7 @@ let check_operation_error ~__context ~ref = (* if other operations are in progress, check that the new operation is allowed concurrently with them. *) let current_error = check current_error (fun () -> - let current_ops = vmr.Db_actions.vM_current_operations in - if - List.length current_ops <> 0 - && not (is_allowed_concurrently ~op ~current_ops) + if current_ops <> [] && not (is_allowed_concurrently ~op ~current_ops) then report_concurrent_operations_error ~current_ops ~ref_str else @@ -520,18 +554,16 @@ let check_operation_error ~__context ~ref = check current_error (fun () -> match op with | (`suspend | `checkpoint | `pool_migrate | `migrate_send) - when not (is_mobile ~__context ref strict) -> + when not (is_mobile ~__context ref strict metrics) -> Some (Api_errors.vm_is_immobile, [ref_str]) | _ -> None ) in let current_error = - let metrics = Db.VM.get_metrics ~__context ~self:ref in check current_error (fun () -> match op with - | `changing_dynamic_range - when nested_virt ~__context ref metrics && strict -> + | `changing_dynamic_range when is_nested_virt && strict -> Some (Api_errors.vm_is_using_nested_virt, [ref_str]) | _ -> None @@ -542,13 +574,7 @@ let check_operation_error ~__context ~ref = (* make use of the Helpers.ballooning_enabled_for_vm function. *) let current_error = check current_error (fun () -> - let vm_ref () = - Db.VM.get_by_uuid ~__context ~uuid:vmr.Db_actions.vM_uuid - in - if - (op = `changing_VCPUs || op = `destroy) - && Helpers.is_domain_zero ~__context (vm_ref ()) - then + if (op = `changing_VCPUs || op = `destroy) && is_domain_zero then Some ( Api_errors.operation_not_allowed , ["This operation is not allowed on dom0"] @@ -594,19 +620,6 @@ let check_operation_error ~__context ~ref = (* Check for an error due to VDI caching/reset behaviour *) let current_error = check current_error (fun () -> - let vdis_reset_and_caching = - List.filter_map - (fun vdi -> - try - let sm_config = Db.VDI.get_sm_config ~__context ~self:vdi in - Some - ( List.assoc_opt "on_boot" sm_config = Some "reset" - , bool_of_assoc "caching" sm_config - ) - with _ -> None - ) - vdis - in if op = `checkpoint || op = `snapshot @@ -635,9 +648,6 @@ let check_operation_error ~__context ~ref = (* If a PCI device is passed-through, check if the operation is allowed *) let current_error = check current_error @@ fun () -> - let sriov_pcis = nvidia_sriov_pcis ~__context vmr.Db_actions.vM_VGPUs in - let is_not_sriov pci = not @@ List.mem pci sriov_pcis in - let pcis = vmr.Db_actions.vM_attached_PCIs in match op with | (`suspend | `checkpoint | `pool_migrate | `migrate_send) when List.exists is_not_sriov pcis -> @@ -669,7 +679,7 @@ let check_operation_error ~__context ~ref = (* Check for errors caused by VM being in an appliance. *) let current_error = check current_error (fun () -> - if Db.is_valid_ref __context vmr.Db_actions.vM_appliance then + if is_appliance_valid then check_appliance ~vmr ~op ~ref_str else None @@ -678,7 +688,7 @@ let check_operation_error ~__context ~ref = (* Check for errors caused by VM being assigned to a protection policy. *) let current_error = check current_error (fun () -> - if Db.is_valid_ref __context vmr.Db_actions.vM_protection_policy then + if is_protection_policy_valid then check_protection_policy ~vmr ~op ~ref_str else None @@ -687,7 +697,7 @@ let check_operation_error ~__context ~ref = (* Check for errors caused by VM being assigned to a snapshot schedule. *) let current_error = check current_error (fun () -> - if Db.is_valid_ref __context vmr.Db_actions.vM_snapshot_schedule then + if is_snapshort_schedule_valid then check_snapshot_schedule ~vmr ~ref_str op else None @@ -711,7 +721,7 @@ let check_operation_error ~__context ~ref = let current_error = check current_error (fun () -> if - Helpers.rolling_upgrade_in_progress ~__context + rolling_upgrade_in_progress && not (List.mem op Xapi_globs.rpu_allowed_vm_operations) then Some (Api_errors.not_supported_during_upgrade, []) @@ -777,12 +787,9 @@ let allowable_ops = List.filter (fun op -> not (List.mem op ignored_ops)) API.vm_operations__all let update_allowed_operations ~__context ~self = + let check' = check_operation_error ~__context ~ref:self in let check accu op = - match check_operation_error ~__context ~ref:self ~op ~strict:true with - | None -> - op :: accu - | Some _err -> - accu + match check' ~op ~strict:true with None -> op :: accu | Some _err -> accu in let allowed = List.fold_left check [] allowable_ops in (* FIXME: need to be able to deal with rolling-upgrade for orlando as well *) @@ -853,11 +860,12 @@ let force_state_reset_keep_current_operations ~__context ~self ~value:state = (* First update the power_state. Some operations below indirectly rely on this. *) let old_state = Db.VM.get_power_state ~__context ~self in Db.VM.set_power_state ~__context ~self ~value:state ; + debug "%s: VM power state changed from %s to %s" __FUNCTION__ + (Record_util.vm_power_state_to_string old_state) + (Record_util.vm_power_state_to_string state) ; if state = `Suspended then remove_pending_guidance ~__context ~self ~value:`restart_device_model ; if state = `Halted then ( - remove_pending_guidance ~__context ~self ~value:`restart_device_model ; - remove_pending_guidance ~__context ~self ~value:`restart_vm ; (* mark all devices as disconnected *) List.iter (fun vbd -> @@ -899,7 +907,9 @@ let force_state_reset_keep_current_operations ~__context ~self ~value:state = ) (Db.VM.get_VUSBs ~__context ~self) ; (* Blank the requires_reboot flag *) - Db.VM.set_requires_reboot ~__context ~self ~value:false + Db.VM.set_requires_reboot ~__context ~self ~value:false ; + remove_pending_guidance ~__context ~self ~value:`restart_device_model ; + remove_pending_guidance ~__context ~self ~value:`restart_vm ) ; (* Do not clear resident_on for VM and VGPU in a checkpoint operation *) if diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index c12dc0648d..cba3d5f496 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -244,7 +244,7 @@ let assert_licensed_storage_motion ~__context = let rec migrate_with_retries ~__context ~queue_name ~max ~try_no ~dbg:_ ~vm_uuid ~xenops_vdi_map ~xenops_vif_map ~xenops_vgpu_map ~xenops_url ~compress - ~verify_cert = + ~verify_cert ~localhost_migration = let open Xapi_xenops_queue in let module Client = (val make_client queue_name : XENOPS) in let dbg = Context.string_of_task_and_tracing __context in @@ -254,7 +254,7 @@ let rec migrate_with_retries ~__context ~queue_name ~max ~try_no ~dbg:_ ~vm_uuid progress := "Client.VM.migrate" ; let t1 = Client.VM.migrate dbg vm_uuid xenops_vdi_map xenops_vif_map - xenops_vgpu_map xenops_url compress verify_dest + xenops_vgpu_map xenops_url compress verify_dest localhost_migration in progress := "sync_with_task" ; ignore (Xapi_xenops.sync_with_task __context queue_name t1) @@ -281,7 +281,7 @@ let rec migrate_with_retries ~__context ~queue_name ~max ~try_no ~dbg:_ ~vm_uuid (Printexc.to_string e) !progress try_no max ; migrate_with_retries ~__context ~queue_name ~max ~try_no:(try_no + 1) ~dbg ~vm_uuid ~xenops_vdi_map ~xenops_vif_map ~xenops_vgpu_map - ~xenops_url ~compress ~verify_cert + ~xenops_url ~compress ~verify_cert ~localhost_migration (* Something else went wrong *) | e -> debug @@ -374,7 +374,8 @@ let pool_migrate ~__context ~vm ~host ~options = Pool_features.assert_enabled ~__context ~f:Features.Xen_motion ; let dbg = Context.string_of_task __context in let localhost = Helpers.get_localhost ~__context in - if host = localhost then + let localhost_migration = host = localhost in + if localhost_migration then info "This is a localhost migration" ; let open Xapi_xenops_queue in let queue_name = queue_of_vm ~__context ~self:vm in @@ -431,7 +432,7 @@ let pool_migrate ~__context ~vm ~host ~options = let verify_cert = Stunnel_client.pool () in migrate_with_retry ~__context ~queue_name ~dbg ~vm_uuid ~xenops_vdi_map:[] ~xenops_vif_map:[] ~xenops_vgpu_map - ~xenops_url ~compress ~verify_cert ; + ~xenops_url ~compress ~verify_cert ~localhost_migration ; (* Delete all record of this VM locally (including caches) *) Xapi_xenops.Xenopsd_metadata.delete ~__context vm_uuid ) @@ -495,6 +496,11 @@ let pool_migrate_complete ~__context ~vm ~host:_ = Xapi_xenops.refresh_vm ~__context ~self:vm ; Monitor_dbcalls_cache.clear_cache_for_vm ~vm_uuid:id ) ; + (* Reset the state, which will update allowed operations, clear reservations + for halted VMs, disconnect devices *) + let power_state = Db.VM.get_power_state ~__context ~self:vm in + Xapi_vm_lifecycle.force_state_reset_keep_current_operations ~__context + ~self:vm ~value:power_state ; Xapi_vm_group_helpers.maybe_update_vm_anti_affinity_alert_for_vm ~__context ~vm @@ -1019,14 +1025,6 @@ let vdi_copy_fun __context dbg vdi_map remote is_intra_pool remote_vdis so_far (* Though we have no intention of "write", here we use the same mode as the associated VBD on a mirrored VDIs (i.e. always RW). This avoids problem when we need to start/stop the VM along the migration. *) - let read_write = true in - (* DP set up is only essential for MIRROR.start/stop due to their open ended pattern. - It's not necessary for copy which will take care of that itself. *) - ignore - (SMAPI.VDI.attach3 dbg new_dp vconf.sr vconf.location vconf.mirror_vm - read_write - ) ; - SMAPI.VDI.activate3 dbg new_dp vconf.sr vconf.location vconf.mirror_vm ; let id = Storage_migrate_helper.State.mirror_id_of (vconf.sr, vconf.location) in @@ -1077,7 +1075,7 @@ let vdi_copy_fun __context dbg vdi_map remote is_intra_pool remote_vdis so_far (None, vdi.vdi) ) else let mirrorid = task_result |> mirror_of_task dbg in - let m = Storage_migrate.stat ~dbg ~id:mirrorid in + let m = SMAPI.DATA.MIRROR.stat dbg mirrorid in (Some mirrorid, m.Mirror.dest_vdi) in so_far := Int64.add !so_far vconf.size ; @@ -1102,11 +1100,12 @@ let vdi_copy_fun __context dbg vdi_map remote is_intra_pool remote_vdis so_far ) ; result with e -> + error "Catch error in post_mirror: %s" (Printexc.to_string e) ; let mirror_failed = match mirror_id with | Some mid -> ignore (Storage_access.unregister_mirror mid) ; - let m = Storage_migrate.stat ~dbg ~id:mid in + let m = SMAPI.DATA.MIRROR.stat dbg mid in (try Storage_migrate.stop ~dbg ~id:mid with _ -> ()) ; m.Mirror.failed | None -> @@ -1601,7 +1600,8 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map let dbg = Context.string_of_task __context in migrate_with_retry ~__context ~queue_name ~dbg ~vm_uuid ~xenops_vdi_map ~xenops_vif_map ~xenops_vgpu_map - ~xenops_url:remote.xenops_url ~compress ~verify_cert ; + ~xenops_url:remote.xenops_url ~compress ~verify_cert + ~localhost_migration:is_same_host ; Xapi_xenops.Xenopsd_metadata.delete ~__context vm_uuid ) with @@ -1805,7 +1805,10 @@ let assert_can_migrate ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~options (* Prevent VMs from being migrated onto a host with a lower platform version *) let host_to = Helpers.LocalObject remote.dest_host in if - not (Helpers.host_versions_not_decreasing ~__context ~host_from ~host_to) + not + (Helpers.Checks.Migration.host_versions_not_decreasing ~__context + ~host_from ~host_to + ) then raise (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])) ; @@ -1833,7 +1836,10 @@ let assert_can_migrate ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~options Helpers.RemoteObject (remote.rpc, remote.session, remote.dest_host) in if - not (Helpers.host_versions_not_decreasing ~__context ~host_from ~host_to) + not + (Helpers.Checks.Migration.host_versions_not_decreasing ~__context + ~host_from ~host_to + ) then raise (Api_errors.Server_error diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index a7fc76a841..fe7c7bed9d 100644 --- a/ocaml/xapi/xapi_vm_snapshot.ml +++ b/ocaml/xapi/xapi_vm_snapshot.ml @@ -167,8 +167,10 @@ let copy_vm_fields ~__context ~metadata ~dst ~do_not_copy ~overrides = debug "copying metadata into %s" (Ref.string_of dst) ; let db = Context.database_of __context in let module DB = - (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS) - in + Xapi_database.Db_interface_compat.OfCached + (( val Xapi_database.Db_cache.get db + : Xapi_database.Db_interface.DB_ACCESS2 + )) in List.iter (fun (key, value) -> let value = Option.value ~default:value (List.assoc_opt key overrides) in diff --git a/ocaml/xapi/xapi_vmss.ml b/ocaml/xapi/xapi_vmss.ml index 611b729f6c..ff32580365 100644 --- a/ocaml/xapi/xapi_vmss.ml +++ b/ocaml/xapi/xapi_vmss.ml @@ -174,7 +174,7 @@ let set_type ~__context ~self ~value = (* Workaround for `param-set` calling `remove_from_schedule` first then `add_to_schedule` * In case `value` supplied is invalid for `add_to_schedule` it must not remove the key * We need the cache the original value before removing the key - * *) + *) let schedule_backup = ref [] let remove_from_schedule ~__context ~self ~key = diff --git a/ocaml/xapi/xapi_vncsnapshot.ml b/ocaml/xapi/xapi_vncsnapshot.ml index d809dd25a8..f783039ee3 100644 --- a/ocaml/xapi/xapi_vncsnapshot.ml +++ b/ocaml/xapi/xapi_vncsnapshot.ml @@ -30,6 +30,7 @@ let vncsnapshot_handler (req : Request.t) s _ = Rbac_static.permission_http_get_vncsnapshot_host_console .Db_actions.role_name_label ; let tmp = Filename.temp_file "snapshot" "jpg" in + let filename = Filename.basename tmp in Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> let vnc_port = @@ -48,7 +49,7 @@ let vncsnapshot_handler (req : Request.t) s _ = in let hsts_time = !Xapi_globs.hsts_max_age in waitpid_fail_if_bad_exit pid ; - Http_svr.response_file ~hsts_time s tmp + 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_vtpm.ml b/ocaml/xapi/xapi_vtpm.ml index 6e9d96e97f..01411e7a7f 100644 --- a/ocaml/xapi/xapi_vtpm.ml +++ b/ocaml/xapi/xapi_vtpm.ml @@ -85,8 +85,8 @@ let copy ~__context ~vM ref = let destroy ~__context ~self = let vm = Db.VTPM.get_VM ~__context ~self in - Xapi_vm_lifecycle.assert_initial_power_state_is ~__context ~self:vm - ~expected:`Halted ; + Xapi_vm_lifecycle.assert_initial_power_state_in ~__context ~self:vm + ~allowed:[`Halted; `Suspended] ; let secret = Db.VTPM.get_contents ~__context ~self in Db.Secret.destroy ~__context ~self:secret ; Db.VTPM.destroy ~__context ~self diff --git a/ocaml/xapi/xapi_vusb_helpers.ml b/ocaml/xapi/xapi_vusb_helpers.ml index 9b1870cf14..19298735a0 100644 --- a/ocaml/xapi/xapi_vusb_helpers.ml +++ b/ocaml/xapi/xapi_vusb_helpers.ml @@ -16,8 +16,6 @@ open Xapi_stdext_std.Xstringext module D = Debug.Make (struct let name = "xapi_vusb_helpers" end) -open D - (**************************************************************************************) (* current/allowed operations checking *) @@ -31,11 +29,11 @@ let valid_operations ~__context record _ref' : table = let _ref = Ref.string_of _ref' in let current_ops = record.Db_actions.vUSB_current_operations in (* Policy: - * one operation at a time - * a running VM can do plug depending on whether the VUSB is already attached to VM. - * a running VM can do unplug depending on whether the VUSB is already attached to VM. - * - *) + * one operation at a time + * a running VM can do plug depending on whether the VUSB is already attached to VM. + * a running VM can do unplug depending on whether the VUSB is already attached to VM. + * + *) let table : table = Hashtbl.create 10 in List.iter (fun x -> Hashtbl.replace table x None) all_ops ; let set_errors (code : string) (params : string list) @@ -48,18 +46,20 @@ let valid_operations ~__context record _ref' : table = ops in (* Any current_operations preclude everything else *) - if current_ops <> [] then ( - debug "No operations are valid because current-operations = [ %s ]" - (String.concat "; " - (List.map - (fun (task, op) -> task ^ " -> " ^ vusb_operations_to_string op) - current_ops - ) - ) ; - let concurrent_op = snd (List.hd current_ops) in - set_errors Api_errors.other_operation_in_progress - ["VUSB"; _ref; vusb_operations_to_string concurrent_op] - all_ops + ( if current_ops <> [] then + let concurrent_op_refs, concurrent_op_types = + List.fold_left + (fun (refs, types) (ref, op) -> + (ref :: refs, vusb_operations_to_string op :: types) + ) + ([], []) current_ops + in + let format x = Printf.sprintf "{%s}" (String.concat "; " x) in + let concurrent_op_refs = format concurrent_op_refs in + let concurrent_op_types = format concurrent_op_types in + set_errors Api_errors.other_operation_in_progress + ["VUSB"; _ref; concurrent_op_types; concurrent_op_refs] + all_ops ) ; let vm = Db.VUSB.get_VM ~__context ~self:_ref' in let power_state = Db.VM.get_power_state ~__context ~self:vm in diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 1a7350c2e9..9b12bcec5a 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -33,7 +33,10 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally let rpc_of t x = Rpcmarshal.marshal t.Rpc.Types.ty x +let ( let@ ) f x = f x + let check_power_state_is ~__context ~self ~expected = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in if expected <> `Running then Xapi_vm_lifecycle.assert_final_power_state_is ~__context ~self ~expected else @@ -48,6 +51,8 @@ let check_power_state_is ~__context ~self ~expected = (Record_util.vm_power_state_to_lowercase_string expected) let event_wait queue_name dbg ?from p = + Debug_info.with_dbg ~name:__FUNCTION__ ~dbg @@ fun di -> + let dbg = Debug_info.to_string di in let finished = ref false in let event_id = ref from in let module Client = (val make_client queue_name : XENOPS) in @@ -58,6 +63,8 @@ let event_wait queue_name dbg ?from p = done let task_ended queue_name dbg id = + Debug_info.with_dbg ~name:__FUNCTION__ ~dbg @@ fun di -> + let dbg = Debug_info.to_string di in let module Client = (val make_client queue_name : XENOPS) in match (Client.TASK.stat dbg id).Task.state with | Task.Completed _ | Task.Failed _ -> @@ -66,6 +73,8 @@ let task_ended queue_name dbg id = false let wait_for_task queue_name dbg id = + Debug_info.with_dbg ~name:__FUNCTION__ ~dbg @@ fun di -> + let dbg = Debug_info.to_string di in let module Client = (val make_client queue_name : XENOPS) in let finished = function | Dynamic.Task id' -> @@ -106,6 +115,7 @@ let xenops_vdi_locator_of sr vdi = (Storage_interface.Vdi.string_of vdi) let xenops_vdi_locator ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let sr = Db.VDI.get_SR ~__context ~self in let sr_uuid = Db.SR.get_uuid ~__context ~self:sr in let vdi_location = Db.VDI.get_location ~__context ~self in @@ -114,9 +124,11 @@ let xenops_vdi_locator ~__context ~self = (Storage_interface.Vdi.of_string vdi_location) let disk_of_vdi ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in try Some (VDI (xenops_vdi_locator ~__context ~self)) with _ -> None let vdi_of_disk ~__context x = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in match String.split ~limit:2 '/' x with | [sr_uuid; location] -> ( let open Xapi_database.Db_filter_types in @@ -151,6 +163,7 @@ let backend_of_network net = (* PR-1255 *) let backend_of_vif ~__context ~vif = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vif_record = Db.VIF.get_record_internal ~__context ~self:vif in let net = Db.Network.get_record ~__context ~self:vif_record.Db_actions.vIF_network @@ -255,6 +268,7 @@ let firmware_of_vm vm = default_firmware let varstore_rm_with_sandbox ~__context ~vm_uuid f = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in let domid = 0 in let chroot, socket_path = @@ -265,6 +279,7 @@ let varstore_rm_with_sandbox ~__context ~vm_uuid f = (fun () -> Xenops_sandbox.Varstore_guard.stop dbg ~domid ~vm_uuid) let nvram_post_clone ~__context ~self ~uuid = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in match Db.VM.get_NVRAM ~__context ~self with | [] -> () @@ -292,6 +307,7 @@ let nvram_post_clone ~__context ~self ~uuid = debug "VM %s: NVRAM changed due to clone" uuid let rtc_timeoffset_of_vm ~__context (vm, vm_t) vbds = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let timeoffset = string vm_t.API.vM_platform "0" Vm_platform.timeoffset in (* If any VDI has on_boot = reset AND has a VDI.other_config:timeoffset then we override the platform/timeoffset. This is needed because windows @@ -365,6 +381,7 @@ let kernel_path filename = Ok real_path let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let open Vm in let video_mode = if vgpu then @@ -525,6 +542,7 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = Helpers.internal_error "invalid boot configuration" let list_net_sriov_vf_pcis ~__context ~vm = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in vm.API.vM_VIFs |> List.filter (fun self -> Db.VIF.get_currently_attached ~__context ~self) |> List.filter_map (fun vif -> @@ -535,10 +553,15 @@ let list_net_sriov_vf_pcis ~__context ~vm = None ) +module StringMap = Map.Make (String) + +let sr_version_cache = ref StringMap.empty + module MD = struct (** Convert between xapi DB records and xenopsd records *) let of_vbd ~__context ~vm ~vbd = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let hvm = match vm.API.vM_domain_type with | `hvm -> @@ -665,6 +688,31 @@ module MD = struct ) else disk_of_vdi ~__context ~self:vbd.API.vBD_VDI in + let can_attach_early = + let sr_opt = + try Some (Db.VDI.get_SR ~__context ~self:vbd.API.vBD_VDI) + with _ -> None + in + match sr_opt with + | Some sr -> ( + let sr_key = Ref.string_of sr in + match StringMap.find_opt sr_key !sr_version_cache with + | Some cached_api_version -> + Version.String.ge cached_api_version "3.0" + | None -> ( + match Xapi_sr.required_api_version_of_sr ~__context ~sr with + | Some api_version -> + sr_version_cache := + StringMap.add sr_key api_version !sr_version_cache ; + Version.String.ge api_version "3.0" + | None -> + false + ) + ) + | None -> + (* If we can't get the SR, we have to default to false *) + false + in { id= (vm.API.vM_uuid, Device_number.to_linux_device device_number) ; position= Some device_number @@ -688,9 +736,11 @@ module MD = struct ( try Db.VDI.get_on_boot ~__context ~self:vbd.API.vBD_VDI = `persist with _ -> true ) + ; can_attach_early } let of_pvs_proxy ~__context vif proxy = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let site = Db.PVS_proxy.get_site ~__context ~self:proxy in let site_uuid = Db.PVS_site.get_uuid ~__context ~self:site in let servers = Db.PVS_site.get_servers ~__context ~self:site in @@ -710,6 +760,7 @@ module MD = struct (site_uuid, servers, interface) let of_vif ~__context ~vm ~vif:(vif_ref, vif) = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let net = Db.Network.get_record ~__context ~self:vif.API.vIF_network in let net_mtu = Int64.to_int net.API.network_MTU in let mtu = @@ -853,6 +904,7 @@ module MD = struct } let pcis_of_vm ~__context (vmref, vm) = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vgpu_pcidevs = Vgpuops.list_pcis_for_passthrough ~__context ~vm:vmref in let devs = List.concat_map (fun (_, dev) -> dev) (Pciops.sort_pcidevs vgpu_pcidevs) @@ -883,6 +935,7 @@ module MD = struct devs let get_target_pci_address ~__context vgpu = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let pgpu = if Db.is_valid_ref __context @@ -911,6 +964,7 @@ module MD = struct * is passed trough completely. *) let sriov_vf ~__context vgpu = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let is_sriov () = let ty = vgpu.Db_actions.vGPU_type in match Db.VGPU_type.get_implementation ~__context ~self:ty with @@ -931,6 +985,7 @@ module MD = struct Xenops_interface.Pci.address_of_string str |> fun addr -> Some addr let of_nvidia_vgpu ~__context vm vgpu = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let open Vgpu in (* Get the PCI address. *) let physical_pci_address = get_target_pci_address ~__context vgpu in @@ -967,6 +1022,7 @@ module MD = struct } let of_gvt_g_vgpu ~__context vm vgpu = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let open Vgpu in (* Get the PCI address. *) let physical_pci_address = get_target_pci_address ~__context vgpu in @@ -1007,6 +1063,7 @@ module MD = struct failwith "Intel GVT-g settings invalid" let of_mxgpu_vgpu ~__context vm vgpu = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let open Vgpu in (* Get the PCI address. *) let physical_pci_address = get_target_pci_address ~__context vgpu in @@ -1043,6 +1100,7 @@ module MD = struct failwith "AMD MxGPU settings invalid" let vgpus_of_vm ~__context (_, vm) = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in List.fold_left (fun acc vgpu -> let vgpu_record = Db.VGPU.get_record_internal ~__context ~self:vgpu in @@ -1064,6 +1122,7 @@ module MD = struct [] vm.API.vM_VGPUs let of_vusb ~__context ~vm ~pusb = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let open Vusb in try let path = pusb.API.pUSB_path in @@ -1087,6 +1146,7 @@ module MD = struct raise e let vusbs_of_vm ~__context (_, vm) = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in vm.API.vM_VUSBs |> List.map (fun self -> Db.VUSB.get_record ~__context ~self) |> List.filter (fun self -> self.API.vUSB_currently_attached) @@ -1096,6 +1156,7 @@ module MD = struct |> List.map (fun pusb -> of_vusb ~__context ~vm ~pusb) let of_vm ~__context (vmref, vm) vbds pci_passthrough vgpu = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let on_action_behaviour = function | `preserve -> [Vm.Pause] @@ -1213,7 +1274,7 @@ module MD = struct if not (List.mem_assoc Vm_platform.featureset platformdata) then let featureset = match - List.assoc_opt Xapi_globs.cpu_info_features_key + List.assoc_opt Constants.cpu_info_features_key vm.API.vM_last_boot_CPU_flags with | _ when vm.API.vM_power_state <> `Suspended -> @@ -1351,6 +1412,7 @@ module Guest_agent_features = struct auto_update_enabled @ auto_update_url let of_config ~__context config = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let open Features in let vss = let name = Features.name_of_feature VSS in @@ -1370,6 +1432,7 @@ module Guest_agent_features = struct end let apply_guest_agent_config ~__context config = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in let features = Guest_agent_features.of_config ~__context config in let module Client = (val make_client (default_xenopsd ()) : XENOPS) in @@ -1377,6 +1440,7 @@ let apply_guest_agent_config ~__context config = (* Create an instance of Metadata.t, suitable for uploading to the xenops service *) let create_metadata ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VM.get_record ~__context ~self in let vbds = List.filter @@ -1419,6 +1483,8 @@ let id_of_vm ~__context ~self = Db.VM.get_uuid ~__context ~self let vm_of_id ~__context uuid = Db.VM.get_by_uuid ~__context ~uuid let vm_exists_in_xenopsd queue_name dbg id = + Debug_info.with_dbg ~name:__FUNCTION__ ~dbg @@ fun di -> + let dbg = Debug_info.to_string di in let module Client = (val make_client queue_name : XENOPS) in Client.VM.exists dbg id @@ -1627,6 +1693,7 @@ module Xenopsd_metadata = struct (* If the VM has Xapi_globs.persist_xenopsd_md -> filename in its other_config, we persist the xenopsd metadata to a well-known location in the filesystem *) let maybe_persist_md ~__context ~self md = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let oc = Db.VM.get_other_config ~__context ~self in if List.mem_assoc Xapi_globs.persist_xenopsd_md oc then let file_path = @@ -1647,6 +1714,7 @@ module Xenopsd_metadata = struct ) let push ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in with_lock metadata_m (fun () -> let md = create_metadata ~__context ~self in let txt = md |> rpc_of Metadata.t |> Jsonrpc.to_string in @@ -1663,6 +1731,7 @@ module Xenopsd_metadata = struct ) let delete_nolock ~__context id = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in info "xenops: VM.remove %s" id ; try @@ -1687,6 +1756,7 @@ module Xenopsd_metadata = struct (* Unregisters a VM with xenopsd, and cleans up metadata and caches *) let pull ~__context id = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in with_lock metadata_m (fun () -> info "xenops: VM.export_metadata %s" id ; let dbg = Context.string_of_task_and_tracing __context in @@ -1717,9 +1787,11 @@ module Xenopsd_metadata = struct ) let delete ~__context id = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in with_lock metadata_m (fun () -> delete_nolock ~__context id) let update ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let id = id_of_vm ~__context ~self in let queue_name = queue_of_vm ~__context ~self in with_lock metadata_m (fun () -> @@ -1793,6 +1865,18 @@ module Events_from_xenopsd = struct let module Client = (val make_client queue_name : XENOPS) in let t = make () in let id = register t in + Debug_info.with_dbg + ~attributes: + [ + ("messaging.operation.name", "subscribe") + ; ("messaging.system", "event") + ; ("messaging.destination.subscription.name", vm_id) + ; ("messaging.message.id", string_of_int id) + ] + ~name:("subscribe" ^ " " ^ queue_name) + ~dbg + @@ fun di -> + let dbg = Debug_info.to_string di in debug "Client.UPDATES.inject_barrier %d" id ; Client.UPDATES.inject_barrier dbg vm_id id ; with_lock t.m (fun () -> @@ -1802,6 +1886,17 @@ module Events_from_xenopsd = struct ) let wakeup queue_name dbg id = + Debug_info.with_dbg + ~attributes: + [ + ("messaging.operation.name", "settle") + ; ("messaging.system", "event") + ; ("messaging.message.id", string_of_int id) + ] + ~name:("settle" ^ " " ^ queue_name) + ~dbg + @@ fun di -> + let dbg = Debug_info.to_string di in let module Client = (val make_client queue_name : XENOPS) in Client.UPDATES.remove_barrier dbg id ; let t = @@ -1852,586 +1947,560 @@ module Events_from_xenopsd = struct ) end -let update_vm ~__context id = - try - if Events_from_xenopsd.are_suppressed id then - debug "xenopsd event: ignoring event for VM (VM %s migrating away)" id +let update_vm_internal ~__context ~id ~self ~previous ~info ~localhost = + debug "xenopsd event: processing event for VM %s" id ; + if info = None then + debug "xenopsd event: VM state missing: assuming VM has shut down" ; + let should_update_allowed_operations = ref false in + + (* If a field (accessed by [accessor] for [Vm.state]) changed in an + update and [predicate has_changed], call [f (accessor info)] *) + let different accessor predicate f = + let a = Option.map (fun x -> accessor x) info in + let b = Option.map accessor previous in + let diff = a <> b in + if predicate diff then + Option.iter f a else - let self = Db.VM.get_by_uuid ~__context ~uuid:id in - let localhost = Helpers.get_localhost ~__context in - if Db.VM.get_resident_on ~__context ~self = localhost then - let previous = Xenops_cache.find_vm id in - let dbg = Context.string_of_task_and_tracing __context in - let module Client = - (val make_client (queue_of_vm ~__context ~self) : XENOPS) - in - let info = try Some (Client.VM.stat dbg id) with _ -> None in - if Option.map snd info <> previous then ( - debug "xenopsd event: processing event for VM %s" id ; - if info = None then - debug "xenopsd event: VM state missing: assuming VM has shut down" ; - let should_update_allowed_operations = ref false in - let different f = - let a = Option.map (fun x -> f (snd x)) info in - let b = Option.map f previous in - a <> b - in - (* Helpers to create and update guest metrics when needed *) - let lookup state key = List.assoc_opt key state.Vm.guest_agent in - let list state dir = - let dir = - if dir.[0] = '/' then - String.sub dir 1 (String.length dir - 1) - else - dir + () + in + (* Helpers to create and update guest metrics when needed *) + let lookup state key = List.assoc_opt key state.Vm.guest_agent in + let list state dir = + let dir = + if dir.[0] = '/' then + String.sub dir 1 (String.length dir - 1) + else + dir + in + let results = + List.filter_map + (fun (path, _) -> + if String.starts_with ~prefix:dir path then + let rest = + String.sub path (String.length dir) + (String.length path - String.length dir) in - let results = - List.filter_map - (fun (path, _) -> - if String.starts_with ~prefix:dir path then - let rest = - String.sub path (String.length dir) - (String.length path - String.length dir) - in - match - List.filter (fun x -> x <> "") (String.split '/' rest) - with - | x :: _ -> - Some x - | _ -> - None - else - None + match List.filter (fun x -> x <> "") (String.split '/' rest) with + | x :: _ -> + Some x + | _ -> + None + else + None + ) + state.Vm.guest_agent + |> Listext.setify + in + results + in + let create_guest_metrics_if_needed () = + let gm = Db.VM.get_guest_metrics ~__context ~self in + if gm = Ref.null then + Option.iter + (fun state -> + List.iter + (fun domid -> + try + let new_gm_ref = + Xapi_guest_agent.create_and_set_guest_metrics (lookup state) + (list state) ~__context ~domid ~uuid:id + ~pV_drivers_detected:state.pv_drivers_detected + in + debug "xenopsd event: created guest metrics %s for VM %s" + (Ref.string_of new_gm_ref) id + with e -> + error "Caught %s: while creating VM %s guest metrics" + (Printexc.to_string e) id + ) + state.domids + ) + info + in + let check_guest_agent () = + Option.iter + (fun state -> + Option.iter + (fun oldstate -> + let old_ga = oldstate.Vm.guest_agent in + let new_ga = state.Vm.guest_agent in + (* Remove memory keys *) + let ignored_keys = + ["data/meminfo_free"; "data/updated"; "data/update_cnt"] + in + let remove_ignored ga = + List.fold_left + (fun acc k -> List.filter (fun x -> fst x <> k) acc) + ga ignored_keys + in + let old_ga = remove_ignored old_ga in + let new_ga = remove_ignored new_ga in + if new_ga <> old_ga then ( + debug + "Will update VM.allowed_operations because guest_agent has \ + changed." ; + should_update_allowed_operations := true + ) else + debug + "Supressing VM.allowed_operations update because guest_agent \ + data is largely the same" + ) + previous ; + List.iter + (fun domid -> + try + debug "xenopsd event: Updating VM %s domid %d guest_agent" id + domid ; + Xapi_guest_agent.all (lookup state) (list state) ~__context ~domid + ~uuid:id ~pV_drivers_detected:state.pv_drivers_detected + with e -> + error "Caught %s: while updating VM %s guest_agent" + (Printexc.to_string e) id + ) + state.domids + ) + info + in + (* Notes on error handling: if something fails we log and continue, to + maximise the amount of state which is correctly synced. If something + does fail then we may end up permanently out-of-sync until either a + process restart or an event is generated. We may wish to periodically + inject artificial events IF there has been an event sync failure? *) + let power_state = + xenapi_of_xenops_power_state (Option.map (fun x -> x.Vm.power_state) info) + in + let power_state_before_update = Db.VM.get_power_state ~__context ~self in + (* We preserve the current_domain_type of suspended VMs like we preserve + the currently_attached fields for VBDs/VIFs etc - it's important to know + whether suspended VMs are going to resume into PV or PVinPVH for example. + We do this before updating the power_state to maintain the invariant that + any VM that's not `Halted cannot have an unspecified current_domain_type *) + different + (fun x -> x.Vm.domain_type) + (( && ) (power_state <> `Suspended)) + (fun domain_type -> + let metrics = Db.VM.get_metrics ~__context ~self in + let update domain_type = + debug "xenopsd event: Updating VM %s current_domain_type <- %s" id + (Record_util.domain_type_to_string domain_type) ; + Db.VM_metrics.set_current_domain_type ~__context ~self:metrics + ~value:domain_type + in + match domain_type with + | Vm.Domain_HVM -> + update `hvm + | Domain_PV -> + update `pv + | Domain_PVinPVH -> + update `pv_in_pvh + | Domain_PVH -> + update `pvh + | Domain_undefined -> + if power_state <> `Halted then + debug + "xenopsd returned an undefined domain type for non-halted VM \ + %s;assuming this is transient, so not updating \ + current_domain_type" + id + else + update `unspecified + ) ; + different + (fun x -> x.Vm.power_state) + Fun.id + (fun _ -> + try + debug + "Will update VM.allowed_operations because power_state has changed." ; + should_update_allowed_operations := true ; + (* Update ha_always_run before the power_state (if needed), to avoid racing + with the HA monitor thread. *) + let pool = Helpers.get_pool ~__context in + if + power_state = `Halted + && not + (Db.Pool.get_ha_reboot_vm_on_internal_shutdown ~__context + ~self:pool + ) + then ( + Db.VM.set_ha_always_run ~__context ~self ~value:false ; + debug "Setting ha_always_run on vm=%s as false after shutdown" + (Ref.string_of self) + ) ; + debug "xenopsd event: Updating VM %s power_state <- %s" id + (Record_util.vm_power_state_to_string power_state) ; + + (* NOTE: Pull xenopsd metadata as soon as possible so that + nothing comes inbetween the power state change and the + Xenopsd_metadata.pull and overwrites it. *) + ( if power_state = `Suspended then + let md = Xenopsd_metadata.pull ~__context id in + match md.Metadata.domains with + | None -> + error "Suspended VM has no domain-specific metadata" + | Some x -> + Db.VM.set_last_booted_record ~__context ~self ~value:x ; + debug "VM %s last_booted_record set to %s" (Ref.string_of self) + x + ) ; + + (* This will mark VBDs, VIFs as detached and clear resident_on + if the VM has permanently shutdown. current-operations + should not be reset as there maybe a checkpoint is ongoing*) + Xapi_vm_lifecycle.force_state_reset_keep_current_operations ~__context + ~self ~value:power_state ; + if power_state = `Running then + create_guest_metrics_if_needed () ; + if power_state = `Suspended || power_state = `Halted then ( + Xapi_network.detach_for_vm ~__context ~host:localhost ~vm:self ; + Storage_access.reset ~__context ~vm:self + ) ; + if power_state = `Halted then ( + Xenopsd_metadata.delete ~__context id ; + !trigger_xenapi_reregister () + ) + with e -> + error "Caught %s: while updating VM %s power_state" + (Printexc.to_string e) id + ) ; + different + (fun x -> x.Vm.domids) + Fun.id + (fun _ -> + try + debug "Will update VM.allowed_operations because domid has changed." ; + should_update_allowed_operations := true ; + debug "xenopsd event: Updating VM %s domid" id ; + Option.iter + (fun state -> + match state.Vm.domids with + | value :: _ -> + Db.VM.set_domid ~__context ~self ~value:(Int64.of_int value) + | [] -> + () + (* happens when the VM is shutdown *) + ) + info ; + (* If this is a storage domain, attempt to plug the PBD *) + Option.iter + (fun pbd -> + let (_ : Thread.t) = + Thread.create + (fun () -> + (* Don't block the database update thread *) + Xapi_pbd.plug ~__context ~self:pbd ) - state.Vm.guest_agent - |> Listext.setify + () in - results - in - let create_guest_metrics_if_needed () = - let gm = Db.VM.get_guest_metrics ~__context ~self in - if gm = Ref.null then - Option.iter - (fun (_, state) -> - List.iter - (fun domid -> - try - let new_gm_ref = - Xapi_guest_agent.create_and_set_guest_metrics - (lookup state) (list state) ~__context ~domid - ~uuid:id - ~pV_drivers_detected:state.pv_drivers_detected - in - debug - "xenopsd event: created guest metrics %s for VM %s" - (Ref.string_of new_gm_ref) id - with e -> - error "Caught %s: while creating VM %s guest metrics" - (Printexc.to_string e) id - ) - state.domids + () + ) + (System_domains.pbd_of_vm ~__context ~vm:self) + with e -> + error "Caught %s: while updating VM %s domids" (Printexc.to_string e) id + ) ; + (* consoles *) + different + (fun x -> x.Vm.consoles) + Fun.id + (fun consoles -> + try + debug "xenopsd event: Updating VM %s consoles" id ; + let address = Db.Host.get_address ~__context ~self:localhost in + let uri = + Uri.( + make ~scheme:"https" ~host:address ~path:Constants.console_uri () + |> to_string + ) + in + let get_uri_from_location loc = + try + let n = String.index loc '?' in + String.sub loc 0 n + with Not_found -> loc + in + let current_protocols = + List.map + (fun self -> + ( ( Db.Console.get_protocol ~__context ~self + |> to_xenops_console_protocol + , Db.Console.get_location ~__context ~self + |> get_uri_from_location ) - info - in - let check_guest_agent () = - Option.iter - (fun (_, state) -> - Option.iter - (fun oldstate -> - let old_ga = oldstate.Vm.guest_agent in - let new_ga = state.Vm.guest_agent in - (* Remove memory keys *) - let ignored_keys = - ["data/meminfo_free"; "data/updated"; "data/update_cnt"] - in - let remove_ignored ga = - List.fold_left - (fun acc k -> List.filter (fun x -> fst x <> k) acc) - ga ignored_keys - in - let old_ga = remove_ignored old_ga in - let new_ga = remove_ignored new_ga in - if new_ga <> old_ga then ( - debug - "Will update VM.allowed_operations because guest_agent \ - has changed." ; - should_update_allowed_operations := true - ) else - debug - "Supressing VM.allowed_operations update because \ - guest_agent data is largely the same" - ) - previous ; - List.iter - (fun domid -> - try - debug "xenopsd event: Updating VM %s domid %d guest_agent" - id domid ; - Xapi_guest_agent.all (lookup state) (list state) - ~__context ~domid ~uuid:id - ~pV_drivers_detected:state.pv_drivers_detected - with e -> - error "Caught %s: while updating VM %s guest_agent" - (Printexc.to_string e) id - ) - state.domids + , self ) - info - in - (* Notes on error handling: if something fails we log and continue, to - maximise the amount of state which is correctly synced. If something - does fail then we may end up permanently out-of-sync until either a - process restart or an event is generated. We may wish to periodically - inject artificial events IF there has been an event sync failure? *) - let power_state = - xenapi_of_xenops_power_state - (Option.map (fun x -> (snd x).Vm.power_state) info) - in - let power_state_before_update = - Db.VM.get_power_state ~__context ~self - in - (* We preserve the current_domain_type of suspended VMs like we preserve - the currently_attached fields for VBDs/VIFs etc - it's important to know - whether suspended VMs are going to resume into PV or PVinPVH for example. - We do this before updating the power_state to maintain the invariant that - any VM that's not `Halted cannot have an unspecified current_domain_type *) - if different (fun x -> x.domain_type) && power_state <> `Suspended - then - Option.iter - (fun (_, state) -> - let metrics = Db.VM.get_metrics ~__context ~self in - let update domain_type = - debug - "xenopsd event: Updating VM %s current_domain_type <- %s" id - (Record_util.domain_type_to_string domain_type) ; - Db.VM_metrics.set_current_domain_type ~__context ~self:metrics - ~value:domain_type - in - match state.Vm.domain_type with - | Domain_HVM -> - update `hvm - | Domain_PV -> - update `pv - | Domain_PVinPVH -> - update `pv_in_pvh - | Domain_PVH -> - update `pvh - | Domain_undefined -> - if power_state <> `Halted then - debug - "xenopsd returned an undefined domain type for \ - non-halted VM %s;assuming this is transient, so not \ - updating current_domain_type" - id - else - update `unspecified - ) - info ; - ( if different (fun x -> x.power_state) then - try - debug - "Will update VM.allowed_operations because power_state has \ - changed." ; - should_update_allowed_operations := true ; - (* Update ha_always_run before the power_state (if needed), to avoid racing - with the HA monitor thread. *) - let pool = Helpers.get_pool ~__context in - if - power_state = `Halted - && not - (Db.Pool.get_ha_reboot_vm_on_internal_shutdown ~__context - ~self:pool - ) - then ( - Db.VM.set_ha_always_run ~__context ~self ~value:false ; - debug "Setting ha_always_run on vm=%s as false after shutdown" - (Ref.string_of self) - ) ; - debug "xenopsd event: Updating VM %s power_state <- %s" id - (Record_util.vm_power_state_to_string power_state) ; - (* This will mark VBDs, VIFs as detached and clear resident_on - if the VM has permanently shutdown. current-operations - should not be reset as there maybe a checkpoint is ongoing*) - Xapi_vm_lifecycle.force_state_reset_keep_current_operations - ~__context ~self ~value:power_state ; - if power_state = `Running then create_guest_metrics_if_needed () ; - if power_state = `Suspended || power_state = `Halted then ( - Xapi_network.detach_for_vm ~__context ~host:localhost ~vm:self ; - Storage_access.reset ~__context ~vm:self - ) ; - if power_state = `Halted then - Xenopsd_metadata.delete ~__context id ; - ( if power_state = `Suspended then - let md = Xenopsd_metadata.pull ~__context id in - match md.Metadata.domains with - | None -> - error "Suspended VM has no domain-specific metadata" - | Some x -> - Db.VM.set_last_booted_record ~__context ~self ~value:x ; - debug "VM %s last_booted_record set to %s" - (Ref.string_of self) x - ) ; - if power_state = `Halted then - !trigger_xenapi_reregister () - with e -> - error "Caught %s: while updating VM %s power_state" - (Printexc.to_string e) id - ) ; - ( if different (fun x -> x.domids) then - try - debug - "Will update VM.allowed_operations because domid has changed." ; - should_update_allowed_operations := true ; - debug "xenopsd event: Updating VM %s domid" id ; - Option.iter - (fun (_, state) -> - match state.Vm.domids with - | value :: _ -> - Db.VM.set_domid ~__context ~self - ~value:(Int64.of_int value) - | [] -> - () - (* happens when the VM is shutdown *) - ) - info ; - (* If this is a storage domain, attempt to plug the PBD *) - Option.iter - (fun pbd -> - let (_ : Thread.t) = - Thread.create - (fun () -> - (* Don't block the database update thread *) - Xapi_pbd.plug ~__context ~self:pbd - ) - () - in - () - ) - (System_domains.pbd_of_vm ~__context ~vm:self) - with e -> - error "Caught %s: while updating VM %s domids" - (Printexc.to_string e) id - ) ; - (* consoles *) - ( if different (fun x -> x.consoles) then - try - debug "xenopsd event: Updating VM %s consoles" id ; - Option.iter - (fun (_, state) -> - let localhost = Helpers.get_localhost ~__context in - let address = - Db.Host.get_address ~__context ~self:localhost - in - let uri = - Uri.( - make ~scheme:"https" ~host:address - ~path:Constants.console_uri () - |> to_string - ) - in - let get_uri_from_location loc = - try - let n = String.index loc '?' in - String.sub loc 0 n - with Not_found -> loc - in - let current_protocols = - List.map - (fun self -> - ( ( Db.Console.get_protocol ~__context ~self - |> to_xenops_console_protocol - , Db.Console.get_location ~__context ~self - |> get_uri_from_location - ) - , self - ) - ) - (Db.VM.get_consoles ~__context ~self) - in - let new_protocols = - List.map - (fun c -> ((c.Vm.protocol, uri), c)) - state.Vm.consoles - in - (* Destroy consoles that have gone away *) - List.iter - (fun protocol -> - let self = List.assoc protocol current_protocols in - Db.Console.destroy ~__context ~self - ) - (Listext.set_difference - (List.map fst current_protocols) - (List.map fst new_protocols) - ) ; - (* Create consoles that have appeared *) - List.iter - (fun (protocol, _) -> - let ref = Ref.make () in - let uuid = Uuidx.to_string (Uuidx.make ()) in - let location = Printf.sprintf "%s?uuid=%s" uri uuid in - let port = - try - Int64.of_int - (List.find - (fun c -> c.Vm.protocol = protocol) - state.Vm.consoles - ) - .port - with Not_found -> -1L - in - Db.Console.create ~__context ~ref ~uuid - ~protocol:(to_xenapi_console_protocol protocol) - ~location ~vM:self ~other_config:[] ~port - ) - (Listext.set_difference - (List.map fst new_protocols) - (List.map fst current_protocols) - ) - ) - info - with e -> - error "Caught %s: while updating VM %s consoles" - (Printexc.to_string e) id - ) ; - ( if different (fun x -> x.memory_target) then - try - Option.iter - (fun (_, state) -> - debug "xenopsd event: Updating VM %s memory_target <- %Ld" - id state.Vm.memory_target ; - Db.VM.set_memory_target ~__context ~self - ~value:state.memory_target - ) - info - with e -> - error "Caught %s: while updating VM %s consoles" - (Printexc.to_string e) id + ) + (Db.VM.get_consoles ~__context ~self) + in + let new_protocols = + List.map (fun c -> ((c.Vm.protocol, uri), c)) consoles + in + (* Destroy consoles that have gone away *) + List.iter + (fun protocol -> + let self = List.assoc protocol current_protocols in + Db.Console.destroy ~__context ~self + ) + (Listext.set_difference + (List.map fst current_protocols) + (List.map fst new_protocols) ) ; - ( if different (fun x -> x.rtc_timeoffset) then + (* Create consoles that have appeared *) + List.iter + (fun (protocol, _) -> + let ref = Ref.make () in + let uuid = Uuidx.to_string (Uuidx.make ()) in + let location = Printf.sprintf "%s?uuid=%s" uri uuid in + let port = try - Option.iter - (fun (_, state) -> - if state.Vm.rtc_timeoffset <> "" then ( - debug - "xenopsd event: Updating VM %s platform:timeoffset <- \ - %s" - id state.rtc_timeoffset ; - ( try - Db.VM.remove_from_platform ~__context ~self - ~key:Vm_platform.timeoffset - with _ -> () - ) ; - Db.VM.add_to_platform ~__context ~self - ~key:Vm_platform.timeoffset ~value:state.rtc_timeoffset - ) - ) - info - with e -> - error "Caught %s: while updating VM %s rtc/timeoffset" - (Printexc.to_string e) id + Int64.of_int + (List.find (fun c -> c.Vm.protocol = protocol) consoles).port + with Not_found -> -1L + in + Db.Console.create ~__context ~ref ~uuid + ~protocol:(to_xenapi_console_protocol protocol) + ~location ~vM:self ~other_config:[] ~port + ) + (Listext.set_difference + (List.map fst new_protocols) + (List.map fst current_protocols) + ) + with e -> + error "Caught %s: while updating VM %s consoles" (Printexc.to_string e) + id + ) ; + different + (fun x -> x.Vm.memory_target) + Fun.id + (fun memory_target -> + try + debug "xenopsd event: Updating VM %s memory_target <- %Ld" id + memory_target ; + Db.VM.set_memory_target ~__context ~self ~value:memory_target + with e -> + error "Caught %s: while updating VM %s consoles" (Printexc.to_string e) + id + ) ; + different + (fun x -> x.rtc_timeoffset) + Fun.id + (fun rtc_timeoffset -> + try + if rtc_timeoffset <> "" then ( + debug "xenopsd event: Updating VM %s platform:timeoffset <- %s" id + rtc_timeoffset ; + ( try + Db.VM.remove_from_platform ~__context ~self + ~key:Vm_platform.timeoffset + with _ -> () ) ; - if different (fun x -> x.hvm) then - Option.iter - (fun (_, state) -> - let metrics = Db.VM.get_metrics ~__context ~self in - debug "xenopsd event: Updating VM %s hvm <- %s" id - (string_of_bool state.Vm.hvm) ; - Db.VM_metrics.set_hvm ~__context ~self:metrics - ~value:state.Vm.hvm - ) - info ; - if different (fun x -> x.nomigrate) then - Option.iter - (fun (_, state) -> - let metrics = Db.VM.get_metrics ~__context ~self in - debug "xenopsd event: Updating VM %s nomigrate <- %s" id - (string_of_bool state.Vm.nomigrate) ; - Db.VM_metrics.set_nomigrate ~__context ~self:metrics - ~value:state.Vm.nomigrate - ) - info ; - if different (fun x -> x.nested_virt) then - Option.iter - (fun (_, state) -> - let metrics = Db.VM.get_metrics ~__context ~self in - debug "xenopsd event: Updating VM %s nested_virt <- %s" id - (string_of_bool state.Vm.nested_virt) ; - Db.VM_metrics.set_nested_virt ~__context ~self:metrics - ~value:state.Vm.nested_virt - ) - info ; - let update_pv_drivers_detected () = - Option.iter - (fun (_, state) -> - try - let gm = Db.VM.get_guest_metrics ~__context ~self in - debug "xenopsd event: Updating VM %s PV drivers detected %b" - id state.Vm.pv_drivers_detected ; - Db.VM_guest_metrics.set_PV_drivers_detected ~__context - ~self:gm ~value:state.Vm.pv_drivers_detected ; - Db.VM_guest_metrics.set_PV_drivers_up_to_date ~__context - ~self:gm ~value:state.Vm.pv_drivers_detected - with e -> - debug "Caught %s: while updating VM %s PV drivers" - (Printexc.to_string e) id - ) - info - in - (* Chack last_start_time before updating anything in the guest metrics *) - ( if different (fun x -> x.last_start_time) then + Db.VM.add_to_platform ~__context ~self ~key:Vm_platform.timeoffset + ~value:rtc_timeoffset + ) + with e -> + error "Caught %s: while updating VM %s rtc/timeoffset" + (Printexc.to_string e) id + ) ; + different + (fun x -> x.hvm) + Fun.id + (fun hvm -> + let metrics = Db.VM.get_metrics ~__context ~self in + debug "xenopsd event: Updating VM %s hvm <- %s" id (string_of_bool hvm) ; + Db.VM_metrics.set_hvm ~__context ~self:metrics ~value:hvm + ) ; + different + (fun x -> x.nomigrate) + Fun.id + (fun nomigrate -> + let metrics = Db.VM.get_metrics ~__context ~self in + debug "xenopsd event: Updating VM %s nomigrate <- %s" id + (string_of_bool nomigrate) ; + Db.VM_metrics.set_nomigrate ~__context ~self:metrics ~value:nomigrate + ) ; + different + (fun x -> x.nested_virt) + Fun.id + (fun nested_virt -> + let metrics = Db.VM.get_metrics ~__context ~self in + debug "xenopsd event: Updating VM %s nested_virt <- %s" id + (string_of_bool nested_virt) ; + Db.VM_metrics.set_nested_virt ~__context ~self:metrics ~value:nested_virt + ) ; + (* Chack last_start_time before updating anything in the guest metrics *) + different + (fun x -> x.last_start_time) + Fun.id + (fun last_start_time -> + try + let metrics = Db.VM.get_metrics ~__context ~self in + (* Clamp time to full seconds, stored timestamps do not + have decimals *) + let start_time = Float.floor last_start_time |> Date.of_unix_time in + let expected_time = + Db.VM_metrics.get_start_time ~__context ~self:metrics + in + if Date.is_later ~than:expected_time start_time then ( + debug "xenopsd event: Updating VM %s last_start_time <- %s" id + Date.(to_rfc3339 (of_unix_time last_start_time)) ; + Db.VM_metrics.set_start_time ~__context ~self:metrics + ~value:start_time ; + if + (* VM start and VM reboot *) + power_state = `Running && power_state_before_update <> `Suspended + then ( + Xapi_vm_lifecycle.remove_pending_guidance ~__context ~self + ~value:`restart_device_model ; + Xapi_vm_lifecycle.remove_pending_guidance ~__context ~self + ~value:`restart_vm + ) + ) ; + create_guest_metrics_if_needed () ; + let gm = Db.VM.get_guest_metrics ~__context ~self in + let update_time = + Db.VM_guest_metrics.get_last_updated ~__context ~self:gm + in + if update_time < start_time then ( + debug + "VM %s guest metrics update time (%s) < VM start time (%s): \ + deleting" + id + (Date.to_rfc3339 update_time) + (Date.to_rfc3339 start_time) ; + Xapi_vm_helpers.delete_guest_metrics ~__context ~self ; + check_guest_agent () + ) + with e -> + error "Caught %s: while updating VM %s last_start_time" + (Printexc.to_string e) id + ) ; + Option.iter + (fun state -> + List.iter + (fun domid -> + (* Guest metrics could have been destroyed during the last_start_time check + by recreating them, we avoid CA-223387 *) + create_guest_metrics_if_needed () ; + different + (fun x -> x.Vm.uncooperative_balloon_driver) + Fun.id + (fun uncooperative_balloon_driver -> + debug + "xenopsd event: VM %s domid %d uncooperative_balloon_driver = \ + %b" + id domid uncooperative_balloon_driver + ) ; + different + (fun x -> x.Vm.guest_agent) + Fun.id + (fun _ -> check_guest_agent ()) ; + different + (fun x -> x.Vm.pv_drivers_detected) + Fun.id + (fun pv_drivers_detected -> try - Option.iter - (fun (_, state) -> - let metrics = Db.VM.get_metrics ~__context ~self in - (* Clamp time to full seconds, stored timestamps do not - have decimals *) - let start_time = - Float.floor state.Vm.last_start_time |> Date.of_unix_time - in - let expected_time = - Db.VM_metrics.get_start_time ~__context ~self:metrics - in - if Date.is_later ~than:expected_time start_time then ( - debug - "xenopsd event: Updating VM %s last_start_time <- %s" id - Date.(to_rfc3339 (of_unix_time state.Vm.last_start_time)) ; - Db.VM_metrics.set_start_time ~__context ~self:metrics - ~value:start_time ; - if - (* VM start and VM reboot *) - power_state = `Running - && power_state_before_update <> `Suspended - then ( - Xapi_vm_lifecycle.remove_pending_guidance ~__context - ~self ~value:`restart_device_model ; - Xapi_vm_lifecycle.remove_pending_guidance ~__context - ~self ~value:`restart_vm - ) - ) ; - create_guest_metrics_if_needed () ; - let gm = Db.VM.get_guest_metrics ~__context ~self in - let update_time = - Db.VM_guest_metrics.get_last_updated ~__context ~self:gm - in - if update_time < start_time then ( - debug - "VM %s guest metrics update time (%s) < VM start time \ - (%s): deleting" - id - (Date.to_rfc3339 update_time) - (Date.to_rfc3339 start_time) ; - Xapi_vm_helpers.delete_guest_metrics ~__context ~self ; - check_guest_agent () - ) - ) - info + let gm = Db.VM.get_guest_metrics ~__context ~self in + debug "xenopsd event: Updating VM %s PV drivers detected %b" id + pv_drivers_detected ; + Db.VM_guest_metrics.set_PV_drivers_detected ~__context ~self:gm + ~value:pv_drivers_detected ; + Db.VM_guest_metrics.set_PV_drivers_up_to_date ~__context + ~self:gm ~value:pv_drivers_detected with e -> - error "Caught %s: while updating VM %s last_start_time" + debug "Caught %s: while updating VM %s PV drivers" (Printexc.to_string e) id - ) ; - Option.iter - (fun (_, state) -> - List.iter - (fun domid -> - (* Guest metrics could have been destroyed during the last_start_time check - by recreating them, we avoid CA-223387 *) - create_guest_metrics_if_needed () ; - if different (fun x -> x.Vm.uncooperative_balloon_driver) then - debug - "xenopsd event: VM %s domid %d \ - uncooperative_balloon_driver = %b" - id domid state.Vm.uncooperative_balloon_driver ; - if different (fun x -> x.Vm.guest_agent) then - check_guest_agent () ; - if different (fun x -> x.Vm.pv_drivers_detected) then - update_pv_drivers_detected () ; - ( if different (fun x -> x.Vm.xsdata_state) then - try - debug "xenopsd event: Updating VM %s domid %d xsdata" id - domid ; - Db.VM.set_xenstore_data ~__context ~self - ~value:state.Vm.xsdata_state - with e -> - error "Caught %s: while updating VM %s xsdata" - (Printexc.to_string e) id - ) ; - if different (fun x -> x.Vm.memory_target) then - try - debug - "xenopsd event: Updating VM %s domid %d memory target" - id domid ; - Rrdd.update_vm_memory_target domid state.Vm.memory_target - with e -> - error "Caught %s: while updating VM %s memory_target" - (Printexc.to_string e) id - ) - state.Vm.domids - ) - info ; - if different (fun x -> x.Vm.vcpu_target) then - Option.iter - (fun (_, state) -> - try - debug "xenopsd event: Updating VM %s vcpu_target <- %d" id - state.Vm.vcpu_target ; - let metrics = Db.VM.get_metrics ~__context ~self in - Db.VM_metrics.set_VCPUs_number ~__context ~self:metrics - ~value:(Int64.of_int state.Vm.vcpu_target) - with e -> - error "Caught %s: while updating VM %s VCPUs_number" - (Printexc.to_string e) id - ) - info ; - ( if different (fun x -> x.shadow_multiplier_target) then + ) ; + different + (fun x -> x.Vm.xsdata_state) + Fun.id + (fun xsdata_state -> try - Option.iter - (fun (_, state) -> - debug - "xenopsd event: Updating VM %s shadow_multiplier <- %.2f" - id state.Vm.shadow_multiplier_target ; - if - state.Vm.power_state <> Halted - && state.Vm.shadow_multiplier_target >= 0.0 - then - Db.VM.set_HVM_shadow_multiplier ~__context ~self - ~value:state.Vm.shadow_multiplier_target - ) - info + debug "xenopsd event: Updating VM %s domid %d xsdata" id domid ; + Db.VM.set_xenstore_data ~__context ~self ~value:xsdata_state with e -> - error "Caught %s: while updating VM %s HVM_shadow_multiplier" + error "Caught %s: while updating VM %s xsdata" (Printexc.to_string e) id - ) ; - (* Preserve last_boot_CPU_flags when suspending (see current_domain_type) *) - if different (fun x -> x.Vm.featureset) && power_state <> `Suspended - then - Option.iter - (fun (_, state) -> - try - debug - "xenopsd event: Updating VM %s last_boot_CPU_flags <- %s" id - state.Vm.featureset ; - let vendor = - Db.Host.get_cpu_info ~__context ~self:localhost - |> List.assoc Xapi_globs.cpu_info_vendor_key - in - let value = - [ - (Xapi_globs.cpu_info_vendor_key, vendor) - ; (Xapi_globs.cpu_info_features_key, state.Vm.featureset) - ] - in - Db.VM.set_last_boot_CPU_flags ~__context ~self ~value - with e -> - error "Caught %s: while updating VM %s last_boot_CPU_flags" - (Printexc.to_string e) id - ) - info ; - Xenops_cache.update_vm id (Option.map snd info) ; - if !should_update_allowed_operations then - Helpers.call_api_functions ~__context (fun rpc session_id -> - XenAPI.VM.update_allowed_operations ~rpc ~session_id ~self ) ) + state.Vm.domids + ) + info ; + different + (fun x -> x.Vm.vcpu_target) + Fun.id + (fun vcpu_target -> + try + debug "xenopsd event: Updating VM %s vcpu_target <- %d" id vcpu_target ; + let metrics = Db.VM.get_metrics ~__context ~self in + Db.VM_metrics.set_VCPUs_number ~__context ~self:metrics + ~value:(Int64.of_int vcpu_target) + with e -> + error "Caught %s: while updating VM %s VCPUs_number" + (Printexc.to_string e) id + ) ; + different + (fun x -> x.shadow_multiplier_target) + Fun.id + (fun shadow_multiplier_target -> + try + debug "xenopsd event: Updating VM %s shadow_multiplier <- %.2f" id + shadow_multiplier_target ; + if power_state <> `Halted && shadow_multiplier_target >= 0.0 then + Db.VM.set_HVM_shadow_multiplier ~__context ~self + ~value:shadow_multiplier_target + with e -> + error "Caught %s: while updating VM %s HVM_shadow_multiplier" + (Printexc.to_string e) id + ) ; + (* Preserve last_boot_CPU_flags when suspending (see current_domain_type) *) + different + (fun x -> x.Vm.featureset) + (( && ) (power_state <> `Suspended)) + (fun featureset -> + try + debug "xenopsd event: Updating VM %s last_boot_CPU_flags <- %s" id + featureset ; + let vendor = + Db.Host.get_cpu_info ~__context ~self:localhost + |> List.assoc Constants.cpu_info_vendor_key + in + let value = + [ + (Constants.cpu_info_vendor_key, vendor) + ; (Constants.cpu_info_features_key, featureset) + ] + in + Db.VM.set_last_boot_CPU_flags ~__context ~self ~value + with e -> + error "Caught %s: while updating VM %s last_boot_CPU_flags" + (Printexc.to_string e) id + ) ; + Xenops_cache.update_vm id info ; + if !should_update_allowed_operations then + Helpers.call_api_functions ~__context (fun rpc session_id -> + XenAPI.VM.update_allowed_operations ~rpc ~session_id ~self + ) + +let update_vm ~__context id = + let@ __context = + Context.with_tracing + ~attributes:[("xapi.event.on.vm", id)] + ~__context __FUNCTION__ + in + try + if Events_from_xenopsd.are_suppressed id then + debug "xenopsd event: ignoring event for VM (VM %s migrating away)" id + else + let self = Db.VM.get_by_uuid ~__context ~uuid:id in + let localhost = Helpers.get_localhost ~__context in + if Db.VM.get_resident_on ~__context ~self = localhost then + let previous = Xenops_cache.find_vm id in + let dbg = Context.string_of_task_and_tracing __context in + let module Client = + (val make_client (queue_of_vm ~__context ~self) : XENOPS) + in + let info = try Some (snd (Client.VM.stat dbg id)) with _ -> None in + if info <> previous then + update_vm_internal ~__context ~id ~self ~previous ~info ~localhost with e -> error "xenopsd event: Caught %s while updating VM: has this VM been removed \ @@ -2439,6 +2508,11 @@ let update_vm ~__context id = (string_of_exn e) let update_vbd ~__context (id : string * string) = + let@ __context = + Context.with_tracing + ~attributes:[("xapi.event.on.vm", fst id); ("xapi.event.on.vbd", snd id)] + ~__context __FUNCTION__ + in try if Events_from_xenopsd.are_suppressed (fst id) then debug "xenopsd event: ignoring event for VBD (VM %s migrating away)" @@ -2452,8 +2526,8 @@ let update_vbd ~__context (id : string * string) = let module Client = (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in - let info = try Some (Client.VBD.stat dbg id) with _ -> None in - if Option.map snd info <> previous then ( + let info = try Some (snd (Client.VBD.stat dbg id)) with _ -> None in + if info <> previous then ( let vbds = Db.VM.get_VBDs ~__context ~self:vm in let vbdrs = List.map @@ -2488,7 +2562,7 @@ let update_vbd ~__context (id : string * string) = debug "VBD %s.%s matched device %s" (fst id) (snd id) vbd_r.API.vBD_userdevice ; Option.iter - (fun (_, state) -> + (fun state -> let currently_attached = state.Vbd.plugged || state.Vbd.active in debug "xenopsd event: Updating VBD %s.%s device <- %s; \ @@ -2531,7 +2605,7 @@ let update_vbd ~__context (id : string * string) = ) ) info ; - Xenops_cache.update_vbd id (Option.map snd info) ; + Xenops_cache.update_vbd id info ; Xapi_vbd_helpers.update_allowed_operations ~__context ~self:vbd ; if not (Db.VBD.get_empty ~__context ~self:vbd) then let vdi = Db.VBD.get_VDI ~__context ~self:vbd in @@ -2541,6 +2615,11 @@ let update_vbd ~__context (id : string * string) = error "xenopsd event: Caught %s while updating VBD" (string_of_exn e) let update_vif ~__context id = + let@ __context = + Context.with_tracing + ~attributes:[("xapi.event.on.vm", fst id); ("xapi.event.on.vif", snd id)] + ~__context __FUNCTION__ + in try if Events_from_xenopsd.are_suppressed (fst id) then debug "xenopsd event: ignoring event for VIF (VM %s migrating away)" @@ -2554,8 +2633,8 @@ let update_vif ~__context id = let module Client = (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in - let info = try Some (Client.VIF.stat dbg id) with _ -> None in - if Option.map snd info <> previous then ( + let info = try Some (snd (Client.VIF.stat dbg id)) with _ -> None in + if info <> previous then ( let vifs = Db.VM.get_VIFs ~__context ~self:vm in let vifrs = List.map @@ -2566,7 +2645,7 @@ let update_vif ~__context id = List.find (fun (_, vifr) -> vifr.API.vIF_device = snd id) vifrs in Option.iter - (fun (_, state) -> + (fun state -> if not (state.Vif.plugged || state.Vif.active) then ( ( try Xapi_network.deregister_vif ~__context vif with e -> @@ -2642,13 +2721,18 @@ let update_vif ~__context id = ~value:(state.plugged || state.active) ) info ; - Xenops_cache.update_vif id (Option.map snd info) ; + Xenops_cache.update_vif id info ; Xapi_vif_helpers.update_allowed_operations ~__context ~self:vif ) with e -> error "xenopsd event: Caught %s while updating VIF" (string_of_exn e) let update_pci ~__context id = + let@ __context = + Context.with_tracing + ~attributes:[("xapi.event.on.vm", fst id); ("xapi.event.on.pci", snd id)] + ~__context __FUNCTION__ + in try if Events_from_xenopsd.are_suppressed (fst id) then debug "xenopsd event: ignoring event for PCI (VM %s migrating away)" @@ -2662,8 +2746,8 @@ let update_pci ~__context id = let module Client = (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in - let info = try Some (Client.PCI.stat dbg id) with _ -> None in - if Option.map snd info <> previous then ( + let info = try Some (snd (Client.PCI.stat dbg id)) with _ -> None in + if info <> previous then ( let pcis = Db.Host.get_PCIs ~__context ~self:localhost in let pcirs = List.map @@ -2680,7 +2764,7 @@ let update_pci ~__context id = List.mem vm (Db.PCI.get_attached_VMs ~__context ~self:pci) in Option.iter - (fun (_, state) -> + (fun state -> debug "xenopsd event: Updating PCI %s.%s currently_attached <- %b" (fst id) (snd id) state.Pci.plugged ; if attached_in_db && not state.Pci.plugged then @@ -2711,12 +2795,17 @@ let update_pci ~__context id = vgpu_opt ) info ; - Xenops_cache.update_pci id (Option.map snd info) + Xenops_cache.update_pci id info ) with e -> error "xenopsd event: Caught %s while updating PCI" (string_of_exn e) let update_vgpu ~__context id = + let@ __context = + Context.with_tracing + ~attributes:[("xapi.event.on.vm", fst id); ("xapi.event.on.vgpu", snd id)] + ~__context __FUNCTION__ + in try if Events_from_xenopsd.are_suppressed (fst id) then debug "xenopsd event: ignoring event for VGPU (VM %s migrating away)" @@ -2730,8 +2819,8 @@ let update_vgpu ~__context id = let module Client = (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in - let info = try Some (Client.VGPU.stat dbg id) with _ -> None in - if Option.map snd info <> previous then ( + let info = try Some (snd (Client.VGPU.stat dbg id)) with _ -> None in + if info <> previous then ( let vgpus = Db.VM.get_VGPUs ~__context ~self:vm in let vgpu_records = List.map @@ -2752,7 +2841,7 @@ let update_vgpu ~__context id = = None then Option.iter - (fun (_, state) -> + (fun state -> ( if state.Vgpu.plugged then let scheduled = Db.VGPU.get_scheduled_to_be_resident_on ~__context @@ -2775,12 +2864,17 @@ let update_vgpu ~__context id = ) ) info ; - Xenops_cache.update_vgpu id (Option.map snd info) + Xenops_cache.update_vgpu id info ) with e -> error "xenopsd event: Caught %s while updating VGPU" (string_of_exn e) let update_vusb ~__context (id : string * string) = + let@ __context = + Context.with_tracing + ~attributes:[("xapi.event.on.vm", fst id); ("xapi.event.on.vusb", snd id)] + ~__context __FUNCTION__ + in try if Events_from_xenopsd.are_suppressed (fst id) then debug "xenopsd event: ignoring event for VUSB (VM %s migrating away)" @@ -2794,8 +2888,8 @@ let update_vusb ~__context (id : string * string) = let module Client = (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in - let info = try Some (Client.VUSB.stat dbg id) with _ -> None in - if Option.map snd info <> previous then ( + let info = try Some (snd (Client.VUSB.stat dbg id)) with _ -> None in + if info <> previous then ( let pusb, _ = Db.VM.get_VUSBs ~__context ~self:vm |> List.map (fun self -> Db.VUSB.get_USB_group ~__context ~self) @@ -2810,7 +2904,7 @@ let update_vusb ~__context (id : string * string) = let usb_group = Db.PUSB.get_USB_group ~__context ~self:pusb in let vusb = Helpers.get_first_vusb ~__context usb_group in Option.iter - (fun (_, state) -> + (fun state -> debug "xenopsd event: Updating USB %s.%s; plugged <- %b" (fst id) (snd id) state.Vusb.plugged ; let currently_attached = state.Vusb.plugged in @@ -2818,7 +2912,7 @@ let update_vusb ~__context (id : string * string) = ~value:currently_attached ) info ; - Xenops_cache.update_vusb id (Option.map snd info) ; + Xenops_cache.update_vusb id info ; Xapi_vusb_helpers.update_allowed_operations ~__context ~self:vusb ) with e -> @@ -2836,14 +2930,21 @@ let unwrap x = raise Not_a_xenops_task let register_task __context ?cancellable queue_name id = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in TaskHelper.register_task __context ?cancellable (wrap queue_name id) ; id let unregister_task __context queue_name id = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in TaskHelper.unregister_task __context (wrap queue_name id) ; id let update_task ~__context queue_name id = + let@ __context = + Context.with_tracing + ~attributes:[("xapi.event.on.task", id)] + ~__context __FUNCTION__ + in try let self = TaskHelper.id_to_task_exn (TaskHelper.Xenops (queue_name, id)) in (* throws Not_found *) @@ -2877,59 +2978,65 @@ let update_task ~__context queue_name id = error "xenopsd event: Caught %s while updating task" (string_of_exn e) let rec events_watch ~__context cancel queue_name from = - let dbg = Context.string_of_task_and_tracing __context in - if Xapi_fist.delay_xenopsd_event_threads () then Thread.delay 30.0 ; - let module Client = (val make_client queue_name : XENOPS) in - let barriers, events, next = Client.UPDATES.get dbg from None in - if !cancel then - raise (Api_errors.Server_error (Api_errors.task_cancelled, [])) ; - let done_events = ref [] in - let already_done x = List.mem x !done_events in - let add_event x = done_events := x :: !done_events in - let do_updates l = - let open Dynamic in - List.iter - (fun ev -> - debug "Processing event: %s" - (ev |> Dynamic.rpc_of_id |> Jsonrpc.to_string) ; - if already_done ev then - debug "Skipping (already processed this round)" - else ( - add_event ev ; - match ev with - | Vm id -> - debug "xenops event on VM %s" id ; - update_vm ~__context id - | Vbd id -> - debug "xenops event on VBD %s.%s" (fst id) (snd id) ; - update_vbd ~__context id - | Vif id -> - debug "xenops event on VIF %s.%s" (fst id) (snd id) ; - update_vif ~__context id - | Pci id -> - debug "xenops event on PCI %s.%s" (fst id) (snd id) ; - update_pci ~__context id - | Vgpu id -> - debug "xenops event on VGPU %s.%s" (fst id) (snd id) ; - update_vgpu ~__context id - | Vusb id -> - debug "xenops event on VUSB %s.%s" (fst id) (snd id) ; - update_vusb ~__context id - | Task id -> - debug "xenops event on Task %s" id ; - update_task ~__context queue_name id - ) - ) - l - in - List.iter - (fun (id, b_events) -> - debug "Processing barrier %d" id ; - do_updates b_events ; - Events_from_xenopsd.wakeup queue_name dbg id + Context.complete_tracing __context ; + let next = + Context.with_tracing ~__context __FUNCTION__ (fun __context -> + let dbg = Context.string_of_task_and_tracing __context in + if Xapi_fist.delay_xenopsd_event_threads () then Thread.delay 30.0 ; + let module Client = (val make_client queue_name : XENOPS) in + let barriers, events, next = Client.UPDATES.get dbg from None in + if !cancel then + raise (Api_errors.Server_error (Api_errors.task_cancelled, [])) ; + let done_events = ref [] in + let already_done x = List.mem x !done_events in + let add_event x = done_events := x :: !done_events in + let do_updates l = + let open Dynamic in + List.iter + (fun ev -> + debug "Processing event: %s" + (ev |> Dynamic.rpc_of_id |> Jsonrpc.to_string) ; + if already_done ev then + debug "Skipping (already processed this round)" + else ( + add_event ev ; + match ev with + | Vm id -> + debug "xenops event on VM %s" id ; + update_vm ~__context id + | Vbd id -> + debug "xenops event on VBD %s.%s" (fst id) (snd id) ; + update_vbd ~__context id + | Vif id -> + debug "xenops event on VIF %s.%s" (fst id) (snd id) ; + update_vif ~__context id + | Pci id -> + debug "xenops event on PCI %s.%s" (fst id) (snd id) ; + update_pci ~__context id + | Vgpu id -> + debug "xenops event on VGPU %s.%s" (fst id) (snd id) ; + update_vgpu ~__context id + | Vusb id -> + debug "xenops event on VUSB %s.%s" (fst id) (snd id) ; + update_vusb ~__context id + | Task id -> + debug "xenops event on Task %s" id ; + update_task ~__context queue_name id + ) + ) + l + in + List.iter + (fun (id, b_events) -> + debug "Processing barrier %d" id ; + do_updates b_events ; + Events_from_xenopsd.wakeup queue_name dbg id + ) + barriers ; + do_updates events ; + next ) - barriers ; - do_updates events ; + in events_watch ~__context cancel queue_name (Some next) let events_from_xenopsd queue_name = @@ -2944,6 +3051,7 @@ let events_from_xenopsd queue_name = ) let refresh_vm ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let id = id_of_vm ~__context ~self in info "xenops: UPDATES.refresh_vm %s" id ; let dbg = Context.string_of_task_and_tracing __context in @@ -2953,6 +3061,7 @@ let refresh_vm ~__context ~self = Events_from_xenopsd.wait queue_name dbg id () let resync_resident_on ~__context = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in let localhost = Helpers.get_localhost ~__context in let domain0 = Helpers.get_domain_zero ~__context in @@ -3095,6 +3204,7 @@ let resync_resident_on ~__context = xapi_vms_not_in_xenopsd let resync_all_vms ~__context = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* This should now be correct *) let localhost = Helpers.get_localhost ~__context in let domain0 = Helpers.get_domain_zero ~__context in @@ -3104,7 +3214,15 @@ let resync_all_vms ~__context = in List.iter (fun vm -> refresh_vm ~__context ~self:vm) resident_vms_in_db +(* experimental feature for hard-pinning vcpus *) +let hard_numa_enabled ~__context = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let pool = Helpers.get_pool ~__context in + let restrictions = Db.Pool.get_restrictions ~__context ~self:pool in + List.assoc_opt "restrict_hard_numa" restrictions = Some "false" + let set_numa_affinity_policy ~__context ~value = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task __context in let open Xapi_xenops_queue in let module Client = (val make_client (default_xenopsd ()) : XENOPS) in @@ -3113,6 +3231,8 @@ let set_numa_affinity_policy ~__context ~value = match value with | `any -> Some Any + | `best_effort when hard_numa_enabled ~__context -> + Some Best_effort_hard | `best_effort -> Some Best_effort | `default_policy -> @@ -3121,6 +3241,7 @@ let set_numa_affinity_policy ~__context ~value = Client.HOST.set_numa_affinity_policy dbg value let on_xapi_restart ~__context = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let host = Helpers.get_localhost ~__context in let value = Db.Host.get_numa_affinity_policy ~__context ~self:host in info "Setting NUMA affinity policy in xenopsd on startup to %s" @@ -3144,6 +3265,7 @@ let on_xapi_restart ~__context = apply_guest_agent_config ~__context config let assert_resident_on ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let localhost = Helpers.get_localhost ~__context in if not (Db.VM.get_resident_on ~__context ~self = localhost) then Helpers.internal_error "the VM %s is not resident on this host" @@ -3476,6 +3598,7 @@ let transform_xenops_exn ~__context ~vm queue_name f = should not be any other suppression going on. *) let set_resident_on ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let id = id_of_vm ~__context ~self in debug "VM %s set_resident_on" id ; let localhost = Helpers.get_localhost ~__context in @@ -3490,6 +3613,7 @@ let set_resident_on ~__context ~self = Xenopsd_metadata.update ~__context ~self let update_debug_info __context t = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let task = Context.get_task_id __context in let debug_info = List.map (fun (k, v) -> ("debug_info:" ^ k, v)) t.Task.debug_info @@ -3504,6 +3628,7 @@ let update_debug_info __context t = debug_info let sync_with_task_result __context ?cancellable queue_name x = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in x |> register_task __context ?cancellable queue_name @@ -3515,6 +3640,7 @@ let sync_with_task __context ?cancellable queue_name x = sync_with_task_result __context ?cancellable queue_name x |> ignore let sync __context queue_name x = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in x |> wait_for_task queue_name dbg @@ -3522,6 +3648,7 @@ let sync __context queue_name x = |> ignore let pause ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3535,6 +3662,7 @@ let pause ~__context ~self = ) let unpause ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3547,6 +3675,7 @@ let unpause ~__context ~self = ) let request_rdp ~__context ~self enabled = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3559,6 +3688,7 @@ let request_rdp ~__context ~self enabled = ) let run_script ~__context ~self script = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3575,6 +3705,7 @@ let run_script ~__context ~self script = ) let set_xenstore_data ~__context ~self xsdata = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3586,6 +3717,7 @@ let set_xenstore_data ~__context ~self xsdata = ) let set_vcpus ~__context ~self n = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3613,6 +3745,7 @@ let set_vcpus ~__context ~self n = ) let set_shadow_multiplier ~__context ~self target = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3642,6 +3775,7 @@ let set_shadow_multiplier ~__context ~self target = ) let set_memory_dynamic_range ~__context ~self min max = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3654,6 +3788,7 @@ let set_memory_dynamic_range ~__context ~self min max = ) let maybe_refresh_vm ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in let queue_name = queue_of_vm ~__context ~self in let id = id_of_vm ~__context ~self in @@ -3666,6 +3801,7 @@ let maybe_refresh_vm ~__context ~self = ) let start ~__context ~self paused force = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> @@ -3727,6 +3863,7 @@ let start ~__context ~self paused force = ) let start ~__context ~self paused force = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> try start ~__context ~self paused force @@ -3752,6 +3889,7 @@ let start ~__context ~self paused force = ) let reboot ~__context ~self timeout = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> assert_resident_on ~__context ~self ; @@ -3774,6 +3912,7 @@ let reboot ~__context ~self timeout = ) let shutdown ~__context ~self timeout = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> assert_resident_on ~__context ~self ; @@ -3807,6 +3946,7 @@ let shutdown ~__context ~self timeout = ) let suspend ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> assert_resident_on ~__context ~self ; @@ -3883,6 +4023,7 @@ let suspend ~__context ~self = ) let resume ~__context ~self ~start_paused ~force:_ = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in let queue_name = queue_of_vm ~__context ~self in let vm_id = id_of_vm ~__context ~self in @@ -3936,6 +4077,7 @@ let resume ~__context ~self ~start_paused ~force:_ = ~expected:(if start_paused then `Paused else `Running) let s3suspend ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3947,6 +4089,7 @@ let s3suspend ~__context ~self = ) let s3resume ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let queue_name = queue_of_vm ~__context ~self in transform_xenops_exn ~__context ~vm:self queue_name (fun () -> let id = id_of_vm ~__context ~self in @@ -3958,12 +4101,14 @@ let s3resume ~__context ~self = ) let md_of_vbd ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VBD.get_VM ~__context ~self in MD.of_vbd ~__context ~vm:(Db.VM.get_record ~__context ~self:vm) ~vbd:(Db.VBD.get_record ~__context ~self) let vbd_plug ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VBD.get_VM ~__context ~self in let vm_id = id_of_vm ~__context ~self:vm in let queue_name = queue_of_vm ~__context ~self:vm in @@ -3990,6 +4135,7 @@ let vbd_plug ~__context ~self = ) let vbd_unplug ~__context ~self force = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VBD.get_VM ~__context ~self in let queue_name = queue_of_vm ~__context ~self:vm in transform_xenops_exn ~__context ~vm queue_name (fun () -> @@ -4019,6 +4165,7 @@ let vbd_unplug ~__context ~self force = ) let vbd_eject_hvm ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VBD.get_VM ~__context ~self in let queue_name = queue_of_vm ~__context ~self:vm in transform_xenops_exn ~__context ~vm queue_name (fun () -> @@ -4041,6 +4188,7 @@ let vbd_eject_hvm ~__context ~self = ) let vbd_insert_hvm ~__context ~self ~vdi = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VBD.get_VM ~__context ~self in let queue_name = queue_of_vm ~__context ~self:vm in transform_xenops_exn ~__context ~vm queue_name (fun () -> @@ -4066,6 +4214,7 @@ let vbd_insert_hvm ~__context ~self ~vdi = ) let has_qemu ~__context ~vm = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let dbg = Context.string_of_task_and_tracing __context in let id = Db.VM.get_uuid ~__context ~self:vm in let queue_name = queue_of_vm ~__context ~self:vm in @@ -4074,10 +4223,12 @@ let has_qemu ~__context ~vm = state.Vm.domain_type = Domain_HVM let ejectable ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VBD.get_VM ~__context ~self in has_qemu ~__context ~vm let vbd_eject ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in if ejectable ~__context ~self then vbd_eject_hvm ~__context ~self else ( @@ -4087,6 +4238,7 @@ let vbd_eject ~__context ~self = ) let vbd_insert ~__context ~self ~vdi = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in if ejectable ~__context ~self then vbd_insert_hvm ~__context ~self ~vdi else ( @@ -4096,12 +4248,14 @@ let vbd_insert ~__context ~self ~vdi = ) let md_of_vif ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VIF.get_VM ~__context ~self in MD.of_vif ~__context ~vm:(Db.VM.get_record ~__context ~self:vm) ~vif:(self, Db.VIF.get_record ~__context ~self) let vif_plug ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VIF.get_VM ~__context ~self in let vm_id = id_of_vm ~__context ~self:vm in let queue_name = queue_of_vm ~__context ~self:vm in @@ -4130,6 +4284,7 @@ let vif_plug ~__context ~self = ) let vif_set_locking_mode ~__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 () -> @@ -4144,6 +4299,7 @@ let vif_set_locking_mode ~__context ~self = ) let vif_set_pvs_proxy ~__context ~self creating = + 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 () -> @@ -4159,6 +4315,7 @@ let vif_set_pvs_proxy ~__context ~self creating = ) let vif_unplug ~__context ~self force = + 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 () -> @@ -4181,6 +4338,7 @@ let vif_unplug ~__context ~self force = ) let vif_move ~__context ~self _network = + 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 () -> @@ -4207,6 +4365,7 @@ let vif_move ~__context ~self _network = ) let vif_set_ipv4_configuration ~__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 () -> @@ -4223,6 +4382,7 @@ let vif_set_ipv4_configuration ~__context ~self = ) let vif_set_ipv6_configuration ~__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 () -> @@ -4239,6 +4399,7 @@ let vif_set_ipv6_configuration ~__context ~self = ) let task_cancel ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in try let queue_name, id = TaskHelper.task_to_id_exn self |> unwrap in let module Client = (val make_client queue_name : XENOPS) in @@ -4254,6 +4415,7 @@ let task_cancel ~__context ~self = false let md_of_vusb ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VUSB.get_VM ~__context ~self in let usb_group = Db.VUSB.get_USB_group ~__context ~self in let pusb = Helpers.get_first_pusb ~__context usb_group in @@ -4261,6 +4423,7 @@ let md_of_vusb ~__context ~self = MD.of_vusb ~__context ~vm:(Db.VM.get_record ~__context ~self:vm) ~pusb:pusbr let vusb_unplug_hvm ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VUSB.get_VM ~__context ~self in let queue_name = queue_of_vm ~__context ~self:vm in transform_xenops_exn ~__context ~vm queue_name (fun () -> @@ -4277,10 +4440,12 @@ let vusb_unplug_hvm ~__context ~self = ) let vusb_plugable ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let vm = Db.VUSB.get_VM ~__context ~self in has_qemu ~__context ~vm let vusb_unplug ~__context ~self = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in if vusb_plugable ~__context ~self then vusb_unplug_hvm ~__context ~self else @@ -4328,6 +4493,11 @@ module Observer = struct let dbg = Context.string_of_task __context in Client.Observer.set_export_interval dbg interval + let set_export_chunk_size ~__context ~size = + let module Client = (val make_client (default_xenopsd ()) : XENOPS) in + let dbg = Context.string_of_task __context in + Client.Observer.set_export_chunk_size dbg size + let set_max_spans ~__context ~spans = let module Client = (val make_client (default_xenopsd ()) : XENOPS) in let dbg = Context.string_of_task __context in @@ -4338,6 +4508,11 @@ module Observer = struct let dbg = Context.string_of_task __context in Client.Observer.set_max_traces dbg traces + let set_max_depth ~__context ~depth = + let module Client = (val make_client (default_xenopsd ()) : XENOPS) in + let dbg = Context.string_of_task __context in + Client.Observer.set_max_depth dbg depth + let set_max_file_size ~__context ~file_size = let module Client = (val make_client (default_xenopsd ()) : XENOPS) in let dbg = Context.string_of_task __context in diff --git a/ocaml/xapi/xha_interface.ml b/ocaml/xapi/xha_interface.ml index e89d22978a..82ac381519 100644 --- a/ocaml/xapi/xha_interface.ml +++ b/ocaml/xapi/xha_interface.ml @@ -32,8 +32,7 @@ let xml_element_has_name name element = (** Returns the first element with the specified name from the given element list. *) let first_xml_element_with_name elements name = - try Some (List.find (xml_element_has_name name) elements) - with Not_found -> None + List.find_opt (xml_element_has_name name) elements (** Parses an XML element of the form "value". Returns a (name, value) string pair, where the arguments @@ -493,7 +492,7 @@ module LiveSetInformation = struct ( match first_xml_element_with_name elements "localhost" with | Some (Xml.Element - (_, _, [Xml.Element ("HostID", _, [Xml.PCData local_host_id])]) + (_, _, Xml.Element ("HostID", _, [Xml.PCData local_host_id]) :: _) ) -> ( match Uuidx.of_string local_host_id with | None -> diff --git a/ocaml/xapi/xha_scripts.ml b/ocaml/xapi/xha_scripts.ml index c8f87e412c..669664112a 100644 --- a/ocaml/xapi/xha_scripts.ml +++ b/ocaml/xapi/xha_scripts.ml @@ -17,7 +17,7 @@ module D = Debug.Make (struct let name = "xapi_ha" end) open D let ha_dir () = - let stack = Localdb.get Constants.ha_cluster_stack in + let stack = Localdb.get_exn Constants.ha_cluster_stack in Filename.concat !Xapi_globs.cluster_stack_root stack let ha_set_pool_state = "ha_set_pool_state" diff --git a/ocaml/xapi/xmlrpc_sexpr.ml b/ocaml/xapi/xmlrpc_sexpr.ml deleted file mode 100644 index d241491cdc..0000000000 --- a/ocaml/xapi/xmlrpc_sexpr.ml +++ /dev/null @@ -1,171 +0,0 @@ -(* - * Copyright (C) 2006-2009 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. - *) -(** Functions for converting between xml-rpc and a more - compact representation based on s-expressions. -*) - -open Xml -open Xapi_stdext_std.Xstringext - -(** Accepts an xml-rpc tree of type xml.xml - with contents [child1] [child2] ... [childn] - where: - tag is an xml tag. - - child is an xml tag or a pcdata. - and converts it to an sexpr tree of type SExpr.t - with contents (tag child1 child2 ... childn) - where: - tag is an SExpr.String - - child is an SExpr.t (String or Node) - exception: - - 'member' tags are not in sexpr because they - are basically redundant information inside struct children. - security notes: - 1. there is no verification that the incoming xml-rpc tree - conforms to the xml-rpc specification. an incorrect xml-rpc tree - might result in an unexpected sexpr mapping. therefore, this - function should not be used to process unsanitized/untrusted xml-rpc trees. -*) -let xmlrpc_to_sexpr (root : xml) = - let rec visit (h : int) (xml_lt : xml list) = - match (h, xml_lt) with - | _, [] -> - [] - | _, PCData text :: _ -> - let text = String.trim text in - [SExpr.String text] - (* empty s have default value '' *) - | h, Element ("value", _, []) :: siblings -> - SExpr.String "" :: visit h siblings - (* ,, tags: ignore them and go to children *) - | h, Element ("data", _, children) :: siblings - | h, Element ("value", _, children) :: siblings - | h, Element ("name", _, children) :: siblings -> - visit (h + 1) children @ visit h siblings - (* tags *) - | h, Element ("member", _, children) :: siblings -> ( - let (mychildren : SExpr.t list) = visit (h + 1) children in - let anode = SExpr.Node mychildren in - let (mysiblings : SExpr.t list) = visit h siblings in - match mychildren with - (*name & value?*) - | [SExpr.String _; _] -> - (*is name a string?*) - anode :: mysiblings - (*then add member anode*) - | _ -> - mysiblings - (*ignore incorrect member*) - ) - (*ignore incorrect member*) - (* any other element *) - | h, Element (tag, _, children) :: siblings -> - let tag = String.trim tag in - let mytag = SExpr.String tag in - let (mychildren : SExpr.t list) = visit (h + 1) children in - let anode = SExpr.Node (mytag :: mychildren) in - let (mysiblings : SExpr.t list) = visit h siblings in - anode :: mysiblings - in - List.hd (visit 0 [root]) - -(** Accepts a tree of s-expressions of type SExpr.t - with contents (tag child1 child2 ... childn) - where: - tag is an SExpr.String - - child is an SExpr.t (String or Node) - and converts it to an xml-rpc tree of type xml.xml - with contents [child1] [child2] ... [childn] - where: - tag is an xml tag. - - child is an xml tag or a pcdata. - exception: - - 'member' tags are not in sexpr because they - are redundant information inside struct children. - security notes: - 1. there is no verification that the incoming sexpr trees - conforms to the output of xmlrpc_to_sexpr. an incorrect sexpr tree - might result in an unexpected xml-rpc mapping. therefore, this - function should not be used to process unsanitized/untrusted sexpr trees. -*) -let sexpr_to_xmlrpc (root : SExpr.t) = - let encase_with (container : string) (el : xml) = - Element (container, [], [el]) - in - let is_not_empty_tag (el : xml) = - match el with Element ("", _, _) -> false | _ -> true - in - let rec visit (h : int) (parent : SExpr.t) (sexpr : SExpr.t) = - match (h, parent, sexpr) with - (* sexpr representing a struct with member tags *) - | ( h - , SExpr.Node (SExpr.String "struct" :: _) - , SExpr.Node (SExpr.String name :: avalue :: _) ) -> ( - match avalue with - | SExpr.String "" -> - Element - ( "member" - , [] - , [Element ("name", [], [PCData name]); Element ("value", [], [])] - ) - | SExpr.String value -> - Element - ( "member" - , [] - , [ - Element ("name", [], [PCData name]) - ; Element ("value", [], [PCData value]) - ] - ) - | SExpr.Node _ as somenode -> - Element - ( "member" - , [] - , [ - Element ("name", [], [PCData name]) - ; Element - ("value", [], [visit (h + 1) (SExpr.String "member") somenode]) - ] - ) - | _ -> - Element ("WRONG_SEXPR_MEMBER", [], []) - ) - (* member tag without values - wrong format - defaults to empty value *) - | _, SExpr.Node (SExpr.String "struct" :: _), SExpr.Node [SExpr.String name] - -> - Element - ( "member" - , [] - , [Element ("name", [], [PCData name]); Element ("value", [], [])] - ) - (* sexpr representing array tags *) - | h, _, SExpr.Node (SExpr.String "array" :: values) -> - let xmlvalues = List.map (visit (h + 1) sexpr) values in - Element - ( "array" - , [] - , [Element ("data", [], List.map (encase_with "value") xmlvalues)] - ) - (* sexpr representing any other tag with children *) - | h, _, SExpr.Node (SExpr.String tag :: atail) -> - let xmlvalues = List.map (visit (h + 1) sexpr) atail in - let xml_noemptytags = List.filter is_not_empty_tag xmlvalues in - Element (tag, [], xml_noemptytags) - (* sexpr representing a pcdata *) - | _, _, SExpr.String s -> - PCData s - (* sexpr representing a nameless tag *) - | _, _, SExpr.Node [] -> - Element ("EMPTY_SEXPR", [], []) - (* otherwise, we reached a senseless sexpr *) - | _ -> - Element ("WRONG_SEXPR", [], []) - in - encase_with "value" (visit 0 (SExpr.Node []) root) diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index b8419b12fb..5b8936e4f8 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -10,13 +10,14 @@ http_lib httpsvr inotify - mtime - mtime.clock.os + clock + mtime.clock rpclib.core rrd-transport rrd-transport.lib stunnel threads.posix + unix uuid xapi-backtrace xapi-consts @@ -41,17 +42,19 @@ (libraries astring ezxenstore.core - ezxenstore.watch forkexec http_lib httpsvr inotify + clock rpclib.core rpclib.json rpclib.xml rrdd_libs_internal + rrdd_plugin_xenctrl rrd-transport threads.posix + unix uuid xapi-backtrace xapi-consts.xapi_version @@ -65,9 +68,6 @@ xapi-stdext-threads xapi-stdext-unix xenctrl - xenstore - xenstore.unix - xenstore_transport.unix ) ) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_bindings.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_bindings.ml index f5d977d632..3ddc24e462 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_bindings.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_bindings.ml @@ -47,8 +47,6 @@ module type RRDD_IMPLEMENTATION = sig val update_use_min_max : bool -> unit - val update_vm_memory_target : int -> int64 -> unit - val set_cache_sr : string -> unit val unset_cache_sr : unit -> unit @@ -119,7 +117,6 @@ module Make (Impl : RRDD_IMPLEMENTATION) = struct Server.query_possible_sr_dss Impl.query_possible_sr_dss ; Server.query_sr_ds Impl.query_sr_ds ; Server.update_use_min_max Impl.update_use_min_max ; - Server.update_vm_memory_target Impl.update_vm_memory_target ; Server.set_cache_sr Impl.set_cache_sr ; Server.unset_cache_sr Impl.unset_cache_sr ; (* module Plugin*) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml index 6fa7d58aef..172735708b 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml @@ -51,12 +51,19 @@ let merge_new_dss rrdi dss = !Rrdd_shared.enable_all_dss || ds.ds_default in let default_dss = StringMap.filter should_enable_ds dss in + let ds_names = + Array.fold_left + (fun (acc : StringSet.t) (e : Rrd.ds) : StringSet.t -> + StringSet.add e.ds_name acc + ) + StringSet.empty rrdi.rrd.rrd_dss + in (* NOTE: Only add enabled dss to the live rrd, ignoring non-default ones. This is because non-default ones are added to the RRD when they are enabled. *) let new_enabled_dss = StringMap.filter - (fun ds_name _ -> not (StringMap.mem ds_name rrdi.dss)) + (fun ds_name _ -> not (StringSet.mem ds_name ds_names)) default_dss in (* fold on Map is not tail-recursive, but the depth of the stack should be @@ -148,9 +155,7 @@ let convert_to_owner_map dss = Also resets the value of datasources that are enabled in the RRD, but weren't updated on this refresh cycle. *) -let update_rrds uuid_domids paused_vms plugins_dss = - let uuid_domids = List.to_seq uuid_domids |> StringMap.of_seq in - let paused_vms = List.to_seq paused_vms |> StringSet.of_seq in +let update_rrds uuid_domids plugins_dss = let per_owner_flattened_map, per_plugin_map = convert_to_owner_map plugins_dss in @@ -230,18 +235,11 @@ let update_rrds uuid_domids paused_vms plugins_dss = match vm_rrd with | Some rrdi -> let updated_dss, rrd = merge_new_dss rrdi dss in - (* CA-34383: Memory updates from paused domains serve no useful - purpose. During a migrate such updates can also cause undesirable - discontinuities in the observed value of memory_actual. Hence, we - ignore changes from paused domains: *) - ( if not (StringSet.mem vm_uuid paused_vms) then - let named_updates = - StringMap.map to_named_updates dss - in - Rrd.ds_update_named rrd - ~new_rrd:(domid <> rrdi.domid) timestamp - named_updates - ) ; + let named_updates = + StringMap.map to_named_updates dss + in + Rrd.ds_update_named rrd ~new_rrd:(domid <> rrdi.domid) + timestamp named_updates ; Some {rrd; dss= updated_dss; domid} | None -> debug "%s: Creating fresh RRD for VM uuid=%s" diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index 6e11a2da31..15eee76cfe 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -571,11 +571,6 @@ let update_use_min_max (value : bool) : unit = debug "Updating use_min_max: New value=%b" value ; use_min_max := value -let update_vm_memory_target (domid : int) (target : int64) : unit = - with_lock memory_targets_m (fun _ -> - Hashtbl.replace memory_targets domid target - ) - let set_cache_sr (sr_uuid : string) : unit = with_lock cache_sr_lock (fun () -> cache_sr_uuid := Some sr_uuid) @@ -716,8 +711,12 @@ module Plugin = struct let next_reading (uid : P.uid) : float = let open Rrdd_shared in if with_lock registered_m (fun _ -> Hashtbl.mem registered uid) then - with_lock last_loop_end_time_m (fun _ -> - !last_loop_end_time +. !timeslice -. Unix.gettimeofday () + with_lock next_iteration_start_m (fun _ -> + match Clock.Timer.remaining !next_iteration_start with + | Remaining diff -> + Clock.Timer.span_to_s diff + | Expired diff -> + Clock.Timer.span_to_s diff *. -1. ) else -1. diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.mli b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.mli index 000c53de12..bd8ae2e6c9 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.mli +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.mli @@ -50,8 +50,6 @@ val query_sr_ds : string -> string -> float val update_use_min_max : bool -> unit -val update_vm_memory_target : int -> int64 -> unit - val set_cache_sr : string -> unit val unset_cache_sr : unit -> unit diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml index 8800ed5683..b15e91b50c 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml @@ -20,19 +20,15 @@ module StringSet = Set.Make (String) (* Whether to enable all non-default datasources *) let enable_all_dss = ref false -(* The time between each monitoring loop. *) -let timeslice : float ref = ref 5. +(* The expected time span between each monitoring loop. *) +let timeslice : Mtime.span ref = ref Mtime.Span.(5 * s) -(* Timestamp of the last monitoring loop end. *) -let last_loop_end_time : float ref = ref neg_infinity +(* A timer that expires at the start of the next iteration *) +let next_iteration_start : Clock.Timer.t ref = + ref (Clock.Timer.start ~duration:!timeslice) -(* The mutex that protects the last_loop_end_time against data corruption. *) -let last_loop_end_time_m : Mutex.t = Mutex.create () - -(** Cache memory/target values *) -let memory_targets : (int, int64) Hashtbl.t = Hashtbl.create 20 - -let memory_targets_m = Mutex.create () +(* The mutex that protects the next_iteration_start against data corruption. *) +let next_iteration_start_m : Mutex.t = Mutex.create () let cache_sr_uuid : string option ref = ref None diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 448dc98f9c..17ca619440 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -119,213 +119,6 @@ let start (xmlrpc_path, http_fwd_path) process = let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute -(*****************************************************) -(* xenstore related code *) -(*****************************************************) - -module XSW_Debug = Debug.Make (struct let name = "xenstore_watch" end) - -module Watch = Ez_xenstore_watch.Make (XSW_Debug) - -module Xs = struct - module Client = Xs_client_unix.Client (Xs_transport_unix_client) - - let client = ref None - - (* Initialise the clients on demand - must be done after daemonisation! *) - let get_client () = - match !client with - | Some client -> - client - | None -> - let c = Client.make () in - client := Some c ; - c -end - -(* Map from domid to the latest seen meminfo_free value *) -let current_meminfofree_values = ref Watch.IntMap.empty - -let meminfo_path domid = - Printf.sprintf "/local/domain/%d/data/meminfo_free" domid - -module Meminfo = struct - let watch_token domid = Printf.sprintf "xcp-rrdd:domain-%d" domid - - let interesting_paths_for_domain domid _uuid = [meminfo_path domid] - - let fire_event_on_vm domid domains = - let d = int_of_string domid in - if not (Watch.IntMap.mem d domains) then - info "Ignoring watch on shutdown domain %d" d - else - let path = meminfo_path d in - try - let client = Xs.get_client () in - let meminfo_free_string = - Xs.Client.immediate client (fun xs -> Xs.Client.read xs path) - in - let meminfo_free = Int64.of_string meminfo_free_string in - info "memfree has changed to %Ld in domain %d" meminfo_free d ; - current_meminfofree_values := - Watch.IntMap.add d meminfo_free !current_meminfofree_values - with Xs_protocol.Enoent _hint -> - info - "Couldn't read path %s; forgetting last known memfree value for \ - domain %d" - path d ; - current_meminfofree_values := - Watch.IntMap.remove d !current_meminfofree_values - - let watch_fired _ _xc path domains _ = - match - List.filter (fun x -> x <> "") Astring.String.(cuts ~sep:"/" path) - with - | ["local"; "domain"; domid; "data"; "meminfo_free"] -> - fire_event_on_vm domid domains - | _ -> - debug "Ignoring unexpected watch: %s" path - - let unmanaged_domain _ _ = false - - let found_running_domain _ _ = () - - let domain_appeared _ _ _ = () - - let domain_disappeared _ _ _ = () -end - -module Watcher = Watch.WatchXenstore (Meminfo) - -(*****************************************************) -(* memory stats *) -(*****************************************************) -let dss_mem_host xc = - let physinfo = Xenctrl.physinfo xc in - let total_kib = - Xenctrl.pages_to_kib (Int64.of_nativeint physinfo.Xenctrl.total_pages) - and free_kib = - Xenctrl.pages_to_kib (Int64.of_nativeint physinfo.Xenctrl.free_pages) - in - [ - ( Rrd.Host - , Ds.ds_make ~name:"memory_total_kib" - ~description:"Total amount of memory in the host" - ~value:(Rrd.VT_Int64 total_kib) ~ty:Rrd.Gauge ~min:0.0 ~default:true - ~units:"KiB" () - ) - ; ( Rrd.Host - , Ds.ds_make ~name:"memory_free_kib" - ~description:"Total amount of free memory" - ~value:(Rrd.VT_Int64 free_kib) ~ty:Rrd.Gauge ~min:0.0 ~default:true - ~units:"KiB" () - ) - ] - -(** estimate the space needed to serialize all the dss_mem_vms in a host. the - json-like serialization for the 3 dss in dss_mem_vms takes 622 bytes. these - bytes plus some overhead make 1024 bytes an upper bound. *) - -let bytes_per_mem_vm = 1024 - -let mem_vm_writer_pages = - ((Rrd_interface.max_supported_vms * bytes_per_mem_vm) + 4095) / 4096 - -let res_error fmt = Printf.ksprintf Result.error fmt - -let ok x = Result.ok x - -let ( let* ) = Result.bind - -let finally f always = Fun.protect ~finally:always f - -let scanning path f = - let io = Scanf.Scanning.open_in path in - finally (fun () -> f io) (fun () -> Scanf.Scanning.close_in io) - -let scan path = - try - scanning path @@ fun io -> - Scanf.bscanf io {|MemTotal: %_d %_s MemFree: %_d %_s MemAvailable: %Ld %s|} - (fun size kb -> ok (size, kb) - ) - with _ -> res_error "failed to scan %s" path - -let mem_available () = - let* size, kb = scan "/proc/meminfo" in - match kb with "kB" -> ok size | _ -> res_error "unexpected unit: %s" kb - -let dss_mem_vms doms = - List.fold_left - (fun acc (dom, uuid, domid) -> - let kib = - Xenctrl.pages_to_kib (Int64.of_nativeint dom.Xenctrl.total_memory_pages) - in - let memory = Int64.mul kib 1024L in - let main_mem_ds = - ( Rrd.VM uuid - , Ds.ds_make ~name:"memory" - ~description:"Memory currently allocated to VM" ~units:"B" - ~value:(Rrd.VT_Int64 memory) ~ty:Rrd.Gauge ~min:0.0 ~default:true () - ) - in - let memory_target_opt = - with_lock Rrdd_shared.memory_targets_m (fun _ -> - Hashtbl.find_opt Rrdd_shared.memory_targets domid - ) - in - let mem_target_ds = - Option.map - (fun memory_target -> - ( Rrd.VM uuid - , Ds.ds_make ~name:"memory_target" - ~description:"Target of VM balloon driver" ~units:"B" - ~value:(Rrd.VT_Int64 memory_target) ~ty:Rrd.Gauge ~min:0.0 - ~default:true () - ) - ) - memory_target_opt - in - let other_ds = - if domid = 0 then - match mem_available () with - | Ok mem -> - Some - ( Rrd.VM uuid - , Ds.ds_make ~name:"memory_internal_free" ~units:"KiB" - ~description:"Dom0 current free memory" - ~value:(Rrd.VT_Int64 mem) ~ty:Rrd.Gauge ~min:0.0 - ~default:true () - ) - | Error msg -> - let _ = - error "%s: retrieving Dom0 free memory failed: %s" __FUNCTION__ - msg - in - None - else - try - let mem_free = - Watch.IntMap.find domid !current_meminfofree_values - in - Some - ( Rrd.VM uuid - , Ds.ds_make ~name:"memory_internal_free" ~units:"KiB" - ~description:"Memory used as reported by the guest agent" - ~value:(Rrd.VT_Int64 mem_free) ~ty:Rrd.Gauge ~min:0.0 - ~default:true () - ) - with Not_found -> None - in - List.concat - [ - main_mem_ds :: Option.to_list other_ds - ; Option.to_list mem_target_ds - ; acc - ] - ) - [] doms - (**** Local cache SR stuff *) type last_vals = { @@ -429,87 +222,22 @@ let handle_exn log f default = (Printexc.to_string e) ; default -let uuid_blacklist = ["00000000-0000-0000"; "deadbeef-dead-beef"] - -module IntSet = Set.Make (Int) - -let domain_snapshot xc = - let metadata_of_domain dom = - let ( let* ) = Option.bind in - let* uuid_raw = Uuidx.of_int_array dom.Xenctrl.handle in - let uuid = Uuidx.to_string uuid_raw in - let domid = dom.Xenctrl.domid in - let start = String.sub uuid 0 18 in - (* Actively hide migrating VM uuids, these are temporary and xenops writes - the original and the final uuid to xenstore *) - let uuid_from_key key = - let path = Printf.sprintf "/vm/%s/%s" uuid key in - try Ezxenstore_core.Xenstore.(with_xs (fun xs -> xs.read path)) - with Xs_protocol.Enoent _hint -> - info "Couldn't read path %s; falling back to actual uuid" path ; - uuid - in - let stable_uuid = Option.fold ~none:uuid ~some:uuid_from_key in - if List.mem start uuid_blacklist then - None - else - let key = - if Astring.String.is_suffix ~affix:"000000000000" uuid then - Some "origin-uuid" - else if Astring.String.is_suffix ~affix:"000000000001" uuid then - Some "final-uuid" - else - None - in - Some (dom, stable_uuid key, domid) - in - let domains = - Xenctrl.domain_getinfolist xc 0 |> List.filter_map metadata_of_domain - in - let domain_paused (d, uuid, _) = - if d.Xenctrl.paused then Some uuid else None - in - let paused_uuids = List.filter_map domain_paused domains in - let domids = List.map (fun (_, _, i) -> i) domains |> IntSet.of_list in - let domains_only k v = Option.map (Fun.const v) (IntSet.find_opt k domids) in - Hashtbl.filter_map_inplace domains_only Rrdd_shared.memory_targets ; - (domains, paused_uuids) - let dom0_stat_generators = [ - ("ha", fun _ _ _ -> Rrdd_ha_stats.all ()) - ; ("mem_host", fun xc _ _ -> dss_mem_host xc) - ; ("mem_vms", fun _ _ domains -> dss_mem_vms domains) - ; ("cache", fun _ timestamp _ -> dss_cache timestamp) + ("ha", fun _ _ -> Rrdd_ha_stats.all ()) + ; ("cache", fun _ timestamp -> dss_cache timestamp) ] -let generate_all_dom0_stats xc domains = +let generate_all_dom0_stats xc = let handle_generator (name, generator) = let timestamp = Unix.gettimeofday () in - ( name - , (timestamp, handle_exn name (fun _ -> generator xc timestamp domains) []) - ) + (name, (timestamp, handle_exn name (fun _ -> generator xc timestamp) [])) in List.map handle_generator dom0_stat_generators -let write_dom0_stats writers tagged_dss = - let write_dss (name, writer) = - match List.assoc_opt name tagged_dss with - | None -> - debug - "Could not write stats for \"%s\": no stats were associated with \ - this name" - name - | Some (timestamp, dss) -> - writer.Rrd_writer.write_payload {timestamp; datasources= dss} - in - List.iter write_dss writers - -let do_monitor_write xc writers = +let do_monitor_write domains_before xc = Rrdd_libs.Stats.time_this "monitor" (fun _ -> - let domains, my_paused_vms = domain_snapshot xc in - let tagged_dom0_stats = generate_all_dom0_stats xc domains in - write_dom0_stats writers tagged_dom0_stats ; + let tagged_dom0_stats = generate_all_dom0_stats xc in let dom0_stats = tagged_dom0_stats |> List.to_seq @@ -518,38 +246,65 @@ let do_monitor_write xc writers = ) in let plugins_stats = Rrdd_server.Plugin.read_stats () in + let _, domains_after, _ = Xenctrl_lib.domain_snapshot xc in + let domains_after = List.to_seq domains_after in let stats = Seq.append plugins_stats dom0_stats in Rrdd_stats.print_snapshot () ; - let uuid_domids = List.map (fun (_, u, i) -> (u, i)) domains in - + (* merge the domain ids from the previous iteration and the current one + to avoid missing updates *) + let uuid_domids = + Seq.append domains_before domains_after + |> Seq.map (fun (_, u, i) -> (u, i)) + |> Rrd.StringMap.of_seq + in (* stats are grouped per plugin, which provides its timestamp *) - Rrdd_monitor.update_rrds uuid_domids my_paused_vms stats ; + Rrdd_monitor.update_rrds uuid_domids stats ; Rrdd_libs.Constants.datasource_dump_file |> Rrdd_server.dump_host_dss_to_file ; Rrdd_libs.Constants.datasource_vm_dump_file - |> Rrdd_server.dump_vm_dss_to_file + |> Rrdd_server.dump_vm_dss_to_file ; + domains_after ) -let monitor_write_loop writers = +let monitor_write_loop () = Debug.with_thread_named "monitor_write" (fun () -> Xenctrl.with_intf (fun xc -> + let domains = ref Seq.empty in while true do try - do_monitor_write xc writers ; - with_lock Rrdd_shared.last_loop_end_time_m (fun _ -> - Rrdd_shared.last_loop_end_time := Unix.gettimeofday () + domains := do_monitor_write !domains xc ; + with_lock Rrdd_shared.next_iteration_start_m (fun _ -> + Rrdd_shared.next_iteration_start := + Clock.Timer.extend_by !Rrdd_shared.timeslice + !Rrdd_shared.next_iteration_start ) ; - Thread.delay !Rrdd_shared.timeslice + match Clock.Timer.remaining !Rrdd_shared.next_iteration_start with + | Remaining remaining -> + Thread.delay (Clock.Timer.span_to_s remaining) + | Expired missed_by -> + warn + "%s: Monitor write iteration missed cycle by %a, skipping \ + the delay" + __FUNCTION__ Debug.Pp.mtime_span missed_by ; + (* To avoid to use up 100% CPU when the timer is already + expired, still delay 1s *) + Thread.delay 1. with e -> Backtrace.is_important e ; warn - "Monitor/write thread caught an exception. Pausing for 10s, \ - then restarting: %s" - (Printexc.to_string e) ; + "%s: Monitor/write thread caught an exception. Pausing for \ + 10s, then restarting: %s" + __FUNCTION__ (Printexc.to_string e) ; log_backtrace e ; - Thread.delay 10. + Thread.delay 10. ; + with_lock Rrdd_shared.next_iteration_start_m (fun _ -> + Rrdd_shared.next_iteration_start := + Clock.Timer.extend_by + Mtime.Span.(10 * s) + !Rrdd_shared.next_iteration_start + ) done ) ) @@ -711,45 +466,15 @@ let doc = the datasources and records historical data in RRD format." ] -(** write memory stats to the filesystem so they can be propagated to xapi, - along with the number of pages they require to be allocated *) -let stats_to_write = [("mem_host", 1); ("mem_vms", mem_vm_writer_pages)] - -let writer_basename = ( ^ ) "xcp-rrdd-" - -let configure_writers () = - List.map - (fun (name, n_pages) -> - let path = Rrdd_server.Plugin.get_path (writer_basename name) in - ignore (Xapi_stdext_unix.Unixext.mkdir_safe (Filename.dirname path) 0o644) ; - let writer = - snd - (Rrd_writer.FileWriter.create - {path; shared_page_count= n_pages} - Rrd_protocol_v2.protocol - ) - in - (name, writer) - ) - stats_to_write - -(** we need to make sure we call exit on fatal signals to make sure profiling - data is dumped *) -let stop err writers signal = - debug "caught signal %a" Debug.Pp.signal signal ; - List.iter (fun (_, writer) -> writer.Rrd_writer.cleanup ()) writers ; - exit err - (* Entry point. *) -let _ = +let () = Rrdd_bindings.Rrd_daemon.bind () ; (* bind PPX-generated server calls to implementation of API *) - let writers = configure_writers () in (* Prevent shutdown due to sigpipe interrupt. This protects against potential stunnel crashes. *) Sys.set_signal Sys.sigpipe Sys.Signal_ignore ; - Sys.set_signal Sys.sigterm (Sys.Signal_handle (stop 1 writers)) ; - Sys.set_signal Sys.sigint (Sys.Signal_handle (stop 0 writers)) ; + Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun _ -> exit 1)) ; + Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> exit 0)) ; (* Enable the new logging library. *) Debug.set_facility Syslog.Local5 ; (* Read configuration file. *) @@ -779,15 +504,8 @@ let _ = start (!Rrd_interface.default_path, !Rrd_interface.forwarded_path) (fun () -> Idl.Exn.server Rrdd_bindings.Server.implementation ) ; - ignore - @@ Discover.start - (List.map (fun (name, _) -> writer_basename name) stats_to_write) ; - ignore @@ GCLog.start () ; - debug "Starting xenstore-watching thread .." ; - let () = - try Watcher.create_watcher_thread () - with _ -> error "xenstore-watching thread has failed" - in + let _ : Thread.t = Discover.start [] in + let _ : Thread.t = GCLog.start () in let module Daemon = Xapi_stdext_unix.Unixext.Daemon in if Daemon.systemd_booted () then if Daemon.systemd_notify Daemon.State.Ready then @@ -796,7 +514,7 @@ let _ = warn "Sending systemd notification failed at %s" __LOC__ ; debug "Creating monitoring loop thread .." ; let () = - try Debug.with_thread_associated "main" monitor_write_loop writers + try Debug.with_thread_associated "main" monitor_write_loop () with _ -> error "monitoring loop thread has failed" in while true do diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.mli b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/ocaml/xcp-rrdd/bin/rrdp-cpu/rrdp_cpu.ml b/ocaml/xcp-rrdd/bin/rrdp-cpu/rrdp_cpu.ml index e3b86db975..a677fd1746 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-cpu/rrdp_cpu.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-cpu/rrdp_cpu.ml @@ -20,7 +20,7 @@ module Process = Rrdd_plugin.Process (struct let name = "xcp-rrdd-cpu" end) let xen_flag_complement = Int64.(shift_left 1L 63 |> lognot) -(* This function is used for getting vcpu stats of the VMs present on this host. *) +(* This function is used for getting vCPU stats of the VMs present on this host. *) let dss_vcpus xc doms = List.fold_left (fun dss (dom, uuid, domid) -> @@ -49,7 +49,7 @@ let dss_vcpus xc doms = in cpus (i + 1) (cputime_rrd :: dss) in - (* Runstate info is per-domain rather than per-vcpu *) + (* Runstate info is per-domain rather than per-vCPU *) let dss = let dom_cpu_time = Int64.(to_float @@ logand dom.Xenctrl.cpu_time xen_flag_complement) @@ -57,54 +57,110 @@ let dss_vcpus xc doms = let dom_cpu_time = dom_cpu_time /. (1.0e9 *. float_of_int dom.Xenctrl.nr_online_vcpus) in + let ( ++ ) = Int64.add in try - let ri = Xenctrl.domain_get_runstate_info xc domid in + let ri = Xenctrl.Runstateinfo.V2.domain_get xc domid in + let runnable_vcpus_ds = + match ri.Xenctrl.Runstateinfo.V2.runnable with + | 0L -> + [] + | _ -> + [ + ( Rrd.VM uuid + , Ds.ds_make ~name:"runnable_vcpus" ~units:"(fraction)" + ~value: + (Rrd.VT_Float + (Int64.to_float ri.Xenctrl.Runstateinfo.V2.runnable + /. 1.0e9 + ) + ) + ~description: + "Fraction of time that vCPUs of the domain are runnable" + ~ty:Rrd.Derive ~default:false ~min:0.0 ~max:1.0 () + ) + ] + in ( Rrd.VM uuid , Ds.ds_make ~name:"runstate_fullrun" ~units:"(fraction)" - ~value:(Rrd.VT_Float (Int64.to_float ri.Xenctrl.time0 /. 1.0e9)) - ~description:"Fraction of time that all VCPUs are running" - ~ty:Rrd.Derive ~default:false ~min:0.0 () + ~value: + (Rrd.VT_Float + (Int64.to_float ri.Xenctrl.Runstateinfo.V2.time0 /. 1.0e9) + ) + ~description:"Fraction of time that all vCPUs are running" + ~ty:Rrd.Derive ~default:false ~min:0.0 ~max:1.0 () ) :: ( Rrd.VM uuid , Ds.ds_make ~name:"runstate_full_contention" ~units:"(fraction)" - ~value:(Rrd.VT_Float (Int64.to_float ri.Xenctrl.time1 /. 1.0e9)) + ~value: + (Rrd.VT_Float + (Int64.to_float ri.Xenctrl.Runstateinfo.V2.time1 /. 1.0e9) + ) ~description: - "Fraction of time that all VCPUs are runnable (i.e., \ + "Fraction of time that all vCPUs are runnable (i.e., \ waiting for CPU)" - ~ty:Rrd.Derive ~default:false ~min:0.0 () + ~ty:Rrd.Derive ~default:false ~min:0.0 ~max:1.0 () ) :: ( Rrd.VM uuid , Ds.ds_make ~name:"runstate_concurrency_hazard" ~units:"(fraction)" - ~value:(Rrd.VT_Float (Int64.to_float ri.Xenctrl.time2 /. 1.0e9)) + ~value: + (Rrd.VT_Float + (Int64.to_float ri.Xenctrl.Runstateinfo.V2.time2 /. 1.0e9) + ) ~description: - "Fraction of time that some VCPUs are running and some are \ + "Fraction of time that some vCPUs are running and some are \ runnable" - ~ty:Rrd.Derive ~default:false ~min:0.0 () + ~ty:Rrd.Derive ~default:false ~min:0.0 ~max:1.0 () ) :: ( Rrd.VM uuid , Ds.ds_make ~name:"runstate_blocked" ~units:"(fraction)" - ~value:(Rrd.VT_Float (Int64.to_float ri.Xenctrl.time3 /. 1.0e9)) + ~value: + (Rrd.VT_Float + (Int64.to_float ri.Xenctrl.Runstateinfo.V2.time3 /. 1.0e9) + ) ~description: - "Fraction of time that all VCPUs are blocked or offline" - ~ty:Rrd.Derive ~default:false ~min:0.0 () + "Fraction of time that all vCPUs are blocked or offline" + ~ty:Rrd.Derive ~default:false ~min:0.0 ~max:1.0 () ) :: ( Rrd.VM uuid , Ds.ds_make ~name:"runstate_partial_run" ~units:"(fraction)" - ~value:(Rrd.VT_Float (Int64.to_float ri.Xenctrl.time4 /. 1.0e9)) + ~value: + (Rrd.VT_Float + (Int64.to_float ri.Xenctrl.Runstateinfo.V2.time4 /. 1.0e9) + ) ~description: - "Fraction of time that some VCPUs are running, and some are \ + "Fraction of time that some vCPUs are running and some are \ blocked" - ~ty:Rrd.Derive ~default:false ~min:0.0 () + ~ty:Rrd.Derive ~default:false ~min:0.0 ~max:1.0 () ) :: ( Rrd.VM uuid , Ds.ds_make ~name:"runstate_partial_contention" ~units:"(fraction)" - ~value:(Rrd.VT_Float (Int64.to_float ri.Xenctrl.time5 /. 1.0e9)) + ~value: + (Rrd.VT_Float + (Int64.to_float ri.Xenctrl.Runstateinfo.V2.time5 /. 1.0e9) + ) ~description: - "Fraction of time that some VCPUs are runnable and some are \ + "Fraction of time that some vCPUs are runnable and some are \ blocked" - ~ty:Rrd.Derive ~default:false ~min:0.0 () + ~ty:Rrd.Derive ~default:false ~min:0.0 ~max:1.0 () + ) + :: ( Rrd.VM uuid + , Ds.ds_make ~name:"runnable_any" ~units:"(fraction)" + ~value: + (Rrd.VT_Float + (Int64.to_float + (ri.Xenctrl.Runstateinfo.V2.time1 + ++ ri.Xenctrl.Runstateinfo.V2.time2 + ++ ri.Xenctrl.Runstateinfo.V2.time5 + ) + /. 1.0e9 + ) + ) + ~description: + "Fraction of time that at least one vCPU is runnable in the \ + domain" + ~ty:Rrd.Derive ~default:false ~min:0.0 ~max:1.0 () ) :: ( Rrd.VM uuid , Ds.ds_make @@ -115,6 +171,7 @@ let dss_vcpus xc doms = ~min:0.0 ~max:1.0 () ) :: dss + @ runnable_vcpus_ds with _ -> dss in try cpus 0 dss with _ -> dss diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune index 4ba37845e2..255beba0a8 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune @@ -16,6 +16,7 @@ str stringext threads.posix + unix uuid xapi-idl.rrd xapi-log diff --git a/ocaml/xcp-rrdd/bin/rrdp-netdev/rrdp_netdev.ml b/ocaml/xcp-rrdd/bin/rrdp-netdev/rrdp_netdev.ml index bd31674a03..deaadffc35 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-netdev/rrdp_netdev.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-netdev/rrdp_netdev.ml @@ -42,17 +42,18 @@ let default_stats = let monitor_whitelist = ref - [ - "eth" - ; "vif" (* This includes "tap" owing to the use of standardise_name below *) - ] + ["vif" (* This includes "tap" owing to the use of standardise_name below *)] (** Transform names of the form 'tapX.X' to 'vifX.X' so these can be handled consistently later *) let standardise_name name = try Scanf.sscanf name "tap%d.%d" @@ Printf.sprintf "vif%d.%d" with _ -> name -let get_link_stats () = +let get_link_stats dbg () = + let managed_host_net_devs = + Network_client.Client.Interface.get_interface_positions dbg () + |> List.map fst + in let open Netlink in let s = Socket.alloc () in Socket.connect s Socket.NETLINK_ROUTE ; @@ -63,13 +64,14 @@ let get_link_stats () = List.exists (fun s -> Astring.String.is_prefix ~affix:s name) !monitor_whitelist + || List.mem name managed_host_net_devs in let is_vlan name = - Astring.String.is_prefix ~affix:"eth" name && String.contains name '.' + List.mem name managed_host_net_devs && String.contains name '.' in List.map (fun link -> (standardise_name (Link.get_name link), link)) links |> (* Only keep interfaces with prefixes on the whitelist, and exclude VLAN - devices (ethx.y). *) + devices (ethx.y). *) List.filter (fun (name, _) -> is_whitelisted name && not (is_vlan name)) in let devs = @@ -160,7 +162,7 @@ let generate_netdev_dss () = Network_client.Client.Bridge.get_all_bonds dbg from_cache in - let stats = get_link_stats () |> add_bonds bonds |> transform_taps in + let stats = get_link_stats dbg () |> add_bonds bonds |> transform_taps in let dss, sum_rx, sum_tx = List.fold_left (fun (dss, sum_rx, sum_tx) (dev, stat) -> diff --git a/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune b/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune index d45dd928de..75c8e1f5ab 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune @@ -2,12 +2,13 @@ (modes exe) (name rrdp_squeezed) (libraries - rrdd-plugin + rrdd_plugin_xenctrl rrdd_plugins_libs xapi-stdext-std ezxenstore ezxenstore.watch + unix xapi-idl.rrd xapi-log xapi-rrd diff --git a/ocaml/xcp-rrdd/bin/rrdp-squeezed/rrdp_squeezed.ml b/ocaml/xcp-rrdd/bin/rrdp-squeezed/rrdp_squeezed.ml index 4c0b13cf3e..df49dca259 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-squeezed/rrdp_squeezed.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-squeezed/rrdp_squeezed.ml @@ -17,10 +17,6 @@ open Rrdd_plugin module Process = Process (struct let name = "xcp-rrdd-squeezed" end) -open Process - -let with_xc f = Xenctrl.with_intf f - module Xs = struct module Client = Xs_client_unix.Client (Xs_transport_unix_client) include Client @@ -38,10 +34,6 @@ module Xs = struct c end -(* Return a list of domids of VMs running on this host *) -let get_running_domains xc = - Xenctrl.domain_getinfolist xc 0 |> List.map (fun di -> di.Xenctrl.domid) - module D = Debug.Make (struct let name = "rrdd-plugins" end) module XSW = Ez_xenstore_watch.Make (D) @@ -53,12 +45,19 @@ let current_dynamic_min_values = ref IntMap.empty let current_target_values = ref IntMap.empty +let current_free_values = ref IntMap.empty + module MemoryActions = struct let interesting_paths_for_domain domid _ = - let keys = ["dynamic-max"; "dynamic-min"; "target"] in - List.map - (fun key -> Printf.sprintf "/local/domain/%d/memory/%s" domid key) - keys + let keys = + [ + "memory/dynamic-max" + ; "memory/dynamic-min" + ; "memory/target" + ; "data/meminfo_free" + ] + in + List.map (fun key -> Printf.sprintf "/local/domain/%d/%s" domid key) keys let watch_token domid = Printf.sprintf "xcp-rrdd-plugins/squeezed:domain-%d" domid @@ -73,10 +72,7 @@ module MemoryActions = struct try let client = Xs.get_client () in let value = - Xs.immediate client (fun xs -> Xs.read xs path) - |> Int64.of_string - |> Int64.mul 1024L - (* convert from KiB to bytes *) + Xs.immediate client (fun xs -> Xs.read xs path) |> Int64.of_string in current_memory_values := IntMap.add domid value !current_memory_values with Xs_protocol.Enoent _ -> @@ -92,6 +88,8 @@ module MemoryActions = struct read_new_value domid current_dynamic_min_values | ["local"; "domain"; domid; "memory"; "target"] -> read_new_value domid current_target_values + | ["local"; "domain"; domid; "data"; "meminfo_free"] -> + read_new_value domid current_free_values | _ -> D.debug "Ignoring unexpected watch: %s" path @@ -106,43 +104,78 @@ end module Watcher = WatchXenstore (MemoryActions) -(* Return a tuple (dynamic-max, dynamic-min, target) for a running VM *) -let get_squeezed_data domid = - let get_current_value ~label current_values = - try IntMap.find domid !current_values - with _ -> - if domid <> 0 then - D.warn "Couldn't find cached %s value for domain %d, using 0" label - domid ; - 0L +(** All these values are reported in KiB *) +type values = { + dynamic_max: int64 option + ; dynamic_min: int64 option + ; target: int64 option + ; free: int64 option +} + +let get_values ((_, _, domid) as dom) = + let get_current_value current_values = + IntMap.find_opt domid !current_values in - ( get_current_value ~label:"dynamic-max" current_dynamic_max_values - , get_current_value ~label:"dynamic-min" current_dynamic_min_values - , get_current_value ~label:"target" current_target_values + ( dom + , { + dynamic_max= get_current_value current_dynamic_max_values + ; dynamic_min= get_current_value current_dynamic_min_values + ; target= get_current_value current_target_values + ; free= get_current_value current_free_values + } ) -let get_datas () = - (* Create a tuple (dynamic-max, dynamic-min, target) for each VM running on the host *) - let domids = with_xc get_running_domains in - List.map get_squeezed_data domids +let get_domain_stats xc = + let _, domains, _ = Xenctrl_lib.domain_snapshot xc in + List.map get_values domains + +let bytes_of_kib kib = Int64.mul 1024L kib -let generate_squeezed_dss () = +let generate_host_sources xc counters = let memory_reclaimed, memory_possibly_reclaimed = - get_datas () - (* Calculate metrics - - Host memory reclaimed by squeezed = - sum_across_running_vms(dynamic_max - target) - - Host memory that could be reclaimed by squeezed = - sum_across_running_vms(target - dynamic_min) + (* Calculate host metrics + - Host memory reclaimed by squeezed = + sum_across_running_vms(dynamic_max - target) + - Host memory that could be reclaimed by squeezed = + sum_across_running_vms(target - dynamic_min) *) + let ( let* ) = Option.bind in + counters |> List.fold_left - (fun (acc1, acc2) (max, min, target) -> - ( Int64.add acc1 (Int64.sub max target) - , Int64.add acc2 (Int64.sub target min) - ) + (fun (acc1, acc2) (_, {dynamic_max; dynamic_min; target; _}) -> + let r = + let* target in + let acc1 = + let* max = dynamic_max in + Some (Int64.add acc1 (Int64.sub max target)) + in + let acc2 = + let* min = dynamic_min in + Some (Int64.add acc2 (Int64.sub target min)) + in + Some (acc1, acc2) + in + match r with + | None | Some (None, None) -> + (acc1, acc2) + | Some (Some acc1, Some acc2) -> + (acc1, acc2) + | Some (Some acc1, None) -> + (acc1, acc2) + | Some (None, Some acc2) -> + (acc1, acc2) ) (Int64.zero, Int64.zero) in + let memory_reclaimed = bytes_of_kib memory_reclaimed in + let memory_possibly_reclaimed = bytes_of_kib memory_possibly_reclaimed in + let physinfo = Xenctrl.physinfo xc in + let total_kib = + Xenctrl.pages_to_kib (Int64.of_nativeint physinfo.Xenctrl.total_pages) + in + let free_kib = + Xenctrl.pages_to_kib (Int64.of_nativeint physinfo.Xenctrl.free_pages) + in (* Build corresponding Ds.ds values *) [ ( Rrd.Host @@ -157,13 +190,137 @@ let generate_squeezed_dss () = ~value:(Rrd.VT_Int64 memory_possibly_reclaimed) ~ty:Rrd.Gauge ~default:true ~units:"B" () ) + ; ( Rrd.Host + , Ds.ds_make ~name:"memory_total_kib" + ~description:"Total amount of memory in the host" + ~value:(Rrd.VT_Int64 total_kib) ~ty:Rrd.Gauge ~min:0.0 ~default:true + ~units:"KiB" () + ) + ; ( Rrd.Host + , Ds.ds_make ~name:"memory_free_kib" + ~description:"Total amount of free memory" + ~value:(Rrd.VT_Int64 free_kib) ~ty:Rrd.Gauge ~min:0.0 ~default:true + ~units:"KiB" () + ) ] -(* This plugin always reports two datasources only, so one page is fine. *) -let shared_page_count = 1 +let res_error fmt = Printf.ksprintf Result.error fmt + +let finally f finally = Fun.protect ~finally f + +let scanning path f = + let io = Scanf.Scanning.open_in path in + finally (fun () -> f io) (fun () -> Scanf.Scanning.close_in io) + +let scan path = + try + scanning path @@ fun io -> + Scanf.bscanf io {|MemTotal: %_d %_s MemFree: %_d %_s MemAvailable: %Ld %s|} + (fun size kb -> Ok (size, kb) + ) + with _ -> res_error "failed to scan %s" path + +let free_dom0 uuid = + let result = + match scan "/proc/meminfo" with + | Ok (size, "kB") -> + Ok size + | Ok (_, unit) -> + res_error "unexpected unit: %s" unit + | Error e -> + Error e + in + match result with + | Ok mem -> + Some + ( Rrd.VM uuid + , Ds.ds_make ~name:"memory_internal_free" ~units:"KiB" + ~description:"Dom0 current free memory" ~value:(Rrd.VT_Int64 mem) + ~ty:Rrd.Gauge ~min:0.0 ~default:true () + ) + | Error msg -> + let _ = + D.error "%s: retrieving Dom0 free memory failed: %s" __FUNCTION__ msg + in + None + +let free_other uuid free = + Some + ( Rrd.VM uuid + , Ds.ds_make ~name:"memory_internal_free" ~units:"KiB" + ~description:"Memory used as reported by the guest agent" + ~value:(Rrd.VT_Int64 free) ~ty:Rrd.Gauge ~min:0.0 ~default:true () + ) + +let get_list f = Option.to_list (f ()) + +let generate_vm_sources domains = + let metrics_of ((dom, uuid, domid), {target; free; _}) = + let target () = + Option.map + (fun target -> + let target = bytes_of_kib target in + ( Rrd.VM uuid + , Ds.ds_make ~name:"memory_target" + ~description:"Target of VM balloon driver" ~units:"B" + ~value:(Rrd.VT_Int64 target) ~ty:Rrd.Gauge ~min:0.0 ~default:true + () + ) + ) + target + in + let free () = + if domid = 0 then + free_dom0 uuid + else + Option.bind free (free_other uuid) + in + let total () = + let memory = + Int64.of_nativeint dom.Xenctrl.total_memory_pages + |> Xenctrl.pages_to_kib + |> bytes_of_kib + in + Some + ( Rrd.VM uuid + , Ds.ds_make ~name:"memory" + ~description:"Memory currently allocated to VM" ~units:"B" + ~value:(Rrd.VT_Int64 memory) ~ty:Rrd.Gauge ~min:0.0 ~default:true () + ) + in + (* CA-34383: Memory updates from paused domains serve no useful purpose. + During a migrate such updates can also cause undesirable + discontinuities in the observed value of memory_actual. Hence, we + ignore changes from paused domains: *) + if dom.Xenctrl.paused then + [] + else + get_list target @ get_list free @ get_list total + in + + List.concat_map metrics_of domains + +let generate_sources xc () = + let domain_stats = get_domain_stats xc in + generate_host_sources xc domain_stats @ generate_vm_sources domain_stats + +(** The json-like serialization for 3 dss in dss_mem_vms takes 622 bytes. These + bytes plus some overhead make 1024 bytes an upper bound. *) + +let bytes_per_mem_vm = 1024 -let _ = - initialise () ; +let host_page_count = 1 + +let vm_page_count = + ((Rrd_interface.max_supported_vms * bytes_per_mem_vm) + 4095) / 4096 + +let shared_page_count = host_page_count + vm_page_count + +let () = Watcher.create_watcher_thread () ; - main_loop ~neg_shift:0.5 ~target:(Reporter.Local shared_page_count) - ~protocol:Rrd_interface.V2 ~dss_f:generate_squeezed_dss + Process.initialise () ; + Xenctrl.with_intf (fun xc -> + Process.main_loop ~neg_shift:0.5 + ~target:(Reporter.Local shared_page_count) ~protocol:Rrd_interface.V2 + ~dss_f:(generate_sources xc) + ) diff --git a/ocaml/xcp-rrdd/bin/rrdview/dune b/ocaml/xcp-rrdd/bin/rrdview/dune new file mode 100644 index 0000000000..fd56897dc0 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdview/dune @@ -0,0 +1,18 @@ +(executable + (modes byte exe) + (name rrdview) + ;(public_name rrdview) + (libraries + threads + unix + xapi-rrd.unix + bos.setup + astring + fpath + rresult + xmlm + tyre + xapi-rrd + result) + ;(package xapi-tools) + ) diff --git a/ocaml/xcp-rrdd/bin/rrdview/rrdgraph.ml b/ocaml/xcp-rrdd/bin/rrdview/rrdgraph.ml new file mode 100644 index 0000000000..80717c21e3 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdview/rrdgraph.ml @@ -0,0 +1,83 @@ +open Rrd + +type vname = VName of string + +module Rpn = struct + module VDef = struct + (* see rrdgraph_rpn(3) *) + type t = vname * string + + type op = vname -> t + + let op kind vname = (vname, kind) + + let maximum = op "MAXIMUM" + + let minimum = op "MINIMUM" + + let average = op "AVERAGE" + + let stdev = op "STDEV" + + let last = op "LAST" + + let first = op "FIRST" + + let total = op "TOTAL" + + let percent = op "PERCENT" + + let percentnan = op "PERCENTNAN" + + let lsl_slope = op "LSLSLOPE" + + let lsl_intercept = op "LSLSLINT" + + let lsl_correlation = op "LSLCORREL" + end + + module CDef = struct + type t = string Seq.t (* stores a serialized RPN expression *) + + let to_string r = r |> List.of_seq |> String.concat "," + + let vname (VName vname) = Seq.return vname + + let value f = Printf.sprintf "%g" f |> Seq.return + + (* reverse polish notation: arguments first, operator last *) + + let opn op args = Seq.append (List.to_seq args |> Seq.concat) (Seq.return op) + + let op1 op arg = opn op [arg] + + let op2 op arg1 arg2 = opn op [arg1; arg2] + + let op3 op arg1 arg2 arg3 = opn op [arg1; arg2; arg3] + end +end + +module Data = struct + type t = string + + (* see rrdgraph_data (3) *) + + let def vname rrdfile rrd rra ds = + let step = Int64.mul rrd.timestep @@ Int64.of_int rra.rra_pdp_cnt in + ( VName vname + , String.concat ":" + [ + "DEF" + ; vname ^ "=" ^ Fpath.to_string rrdfile + ; ds.ds_name + ; Rrd.cf_type_to_string rra.rra_cf + ; Printf.sprintf "step=%Lu" step + ] + ) + + let vdef vname (VName var, rpnvdefop) = + (VName vname, Printf.sprintf "CDEF:%s=%s,%s" vname var rpnvdefop) + + let cdef vname rpn = + (VName vname, Printf.sprintf "CDEF:%s=%s" vname (Rpn.CDef.to_string rpn)) +end diff --git a/ocaml/xcp-rrdd/bin/rrdview/rrdgraph.mli b/ocaml/xcp-rrdd/bin/rrdview/rrdgraph.mli new file mode 100644 index 0000000000..0c4ac9738e --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdview/rrdgraph.mli @@ -0,0 +1,88 @@ +(** a variable name *) +type vname + +module Rpn : sig + (** RPN expressions for VDEF statements, see [rrdgraph_rpn(3)] *) + module VDef : sig + (** an RPN expression for VDEF, see [rrdgraph_data(3)] *) + type t + + (** a VDEF RPN expression, see [rrdgraph_rpn(3)] *) + type op = vname -> t + + val maximum : op + (** see [rrdgraph_rpn(3)] *) + + val minimum : op + (** see [rrdgraph_rpn(3)] *) + + val average : op + (** see [rrdgraph_rpn(3)] *) + + val stdev : op + (** see [rrdgraph_rpn(3)] *) + + val last : op + (** see [rrdgraph_rpn(3)] *) + + val first : op + (** see [rrdgraph_rpn(3)] *) + + val total : op + (** see [rrdgraph_rpn(3)] *) + + val percent : op + (** see [rrdgraph_rpn(3)] *) + + val percentnan : op + (** see [rrdgraph_rpn(3)] *) + + val lsl_slope : op + (** see [rrdgraph_rpn(3)] *) + + val lsl_intercept : op + (** see [rrdgraph_rpn(3)] *) + + val lsl_correlation : op + (** see [rrdgraph_rpn(3)] *) + end + + module CDef : sig + (** an RPN expression for CDEF, see [rrdgraph_data(3)] *) + type t + + val vname : vname -> t + (** [vname v] is [v] as an RPN expression *) + + val value : float -> t + (** [value v] is [v] as an RPN expression *) + + val op1 : string -> t -> t + (** [op1 op arg1] is [op arg1]. For valid operators see [rrdgraph_rpn(3)] *) + + val op2 : string -> t -> t -> t + (** [op2 op arg1 arg2] is [op arg1 arg2]. For valid operators see [rrdgraph_rpn(3)] *) + + val op3 : string -> t -> t -> t -> t + (** [op3 op arg1 arg2 arg3] is [op arg1 arg2 arg3]. For valid operators see [rrdgraph_rpn(3)] *) + end +end + +module Data : sig + (** an rrd graph data definition, see [rrdgraph_data(3)] *) + type t + + val def : string -> Fpath.t -> Rrd.rrd -> Rrd.rra -> Rrd.ds -> vname * t + (** [def vname rrdfile rrd rra datasource] is a [DEF] (see [rrdgraph_data(3)]) that loads + [datasource.ds_name] from the [rrdfile] and plots it according to the consolidation function in the + specified [rra] and timestep calculated based on [rrd]. This data can be refered to as [vname] + elsewhere. *) + + val vdef : string -> Rpn.VDef.t -> vname * t + (** [vdef vname vdefrpn] defines [vname] through a [VDEF] (see [rrdgraph_data(3)]) using the + specified [vdefrpn] expression. Conversion to RPN form is handled internally. *) + + val cdef : string -> Rpn.CDef.t -> vname * t + (** [cdef vname cdefrpn] defines [vname] through a [CDEF] (see [rrdgraph_data(3)]) using the + specified [cdefrpn] expression. Conversion to RPN form is handled internally. *) +end diff --git a/ocaml/xcp-rrdd/bin/rrdview/rrdview.ml b/ocaml/xcp-rrdd/bin/rrdview/rrdview.ml new file mode 100644 index 0000000000..3716f4cfde --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdview/rrdview.ml @@ -0,0 +1,483 @@ +(* + * Copyright (C) 2006-2009 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. + *) + +open Bos_setup + +type def = Def of string * Rrd.cf_type | Cdef of string + +let name ~ds_name ~cf_type = + cf_type + |> Rrd.cf_type_to_string + |> String.Ascii.lowercase + |> Printf.sprintf "%s_%s" ds_name + +type ds_def = {units: string option} + +let default_def = {units= None} + +let def ~data ~step ~ds_name ~cf_type = + let cfstr = Rrd.cf_type_to_string cf_type in + let namestr = name ~ds_name ~cf_type in + ( Def (ds_name, cf_type) + , Printf.sprintf "DEF:%s=%s:%s:%s:step=%Ld" namestr (Fpath.to_string data) + ds_name cfstr step + ) + +type ds = Ds : string -> ds + +type cdef = Op of cdef * string * cdef | Var of def + +let rec string_of_cdef = function + | Op (lhs, op, rhs) -> + String.concat ~sep:"," [string_of_cdef lhs; string_of_cdef rhs; op] + | Var (Def (ds_name, cf_type)) -> + name ~ds_name ~cf_type + | Var (Cdef s) -> + s + +let cdef name ops = + (Cdef name, Printf.sprintf "CDEF:%s=%s" name @@ string_of_cdef ops) + +type rgb = {r: int; g: int; b: int; alpha: int option} + +type fill = RGB of rgb + +let shape ?(stack = false) kind ?label ~def fill = + let defstr = + match def with + | Def (ds_name, cf_type) -> + name ~ds_name ~cf_type + | Cdef str -> + str + in + let fillstr = + match fill with + | Some (RGB {r; g; b; alpha}) -> + Printf.sprintf "#%02x%02x%02x%s" r g b + (Option.fold ~none:"" ~some:(Printf.sprintf "%02u") alpha) + | None -> + "" + in + Printf.sprintf "%s:%s%s%s%s" kind defstr fillstr + (if stack then ":STACK" else "") + (match label with None -> "" | Some x -> ":" ^ x) + +let area = shape "AREA" + +let area_stack = shape ~stack:true "AREA" + +let line ?label = shape ?label "LINE" + +(* colors from rrdtool wiki OutlinedAreaGraph *) +let rgb ?alpha hex = + let r = (hex lsr 16) land 0xff + and g = (hex lsr 8) land 0xff + and b = hex land 0xff in + RGB {r; g; b; alpha} + +let rgb light dark = (rgb light, rgb dark) + +let colors = + [| + rgb 0x54EC48 0x24BC14 + ; rgb 0x48C4EC 0x1598C3 + ; rgb 0xDE48EC 0xB415C7 + ; rgb 0x7648EC 0x4D18E4 + ; rgb 0xEA644A 0xCC3118 + ; rgb 0xEC9D48 0xCC7016 + ; rgb 0xECD748 0xC9B215 + |] + +let get_color ~dark i = + let RGB col_light, col_dark = colors.(i mod Array.length colors) in + Some (if dark then col_dark else RGB {col_light with alpha= Some 50}) + +let rrdtool ~filename ~data title ~ds_names ~first ~last ~step ~width + ~has_min_max = + let graph = + List.of_seq + (ds_names + |> List.mapi (fun x s -> (s, x)) + |> List.to_seq + |> Seq.flat_map @@ fun (ds_name, i) -> + Seq.append + ( if has_min_max then + let ds_min, def1 = def ~step ~data ~ds_name ~cf_type:Rrd.CF_Min + and ds_max, def2 = + def ~step ~data ~ds_name ~cf_type:Rrd.CF_Max + in + let ds_range, cdef1 = + cdef (ds_name ^ "range") (Op (Var ds_max, "-", Var ds_min)) + in + List.to_seq + [ + def1 + ; def2 + ; cdef1 + ; area ~def:ds_min None + ; area_stack ~def:ds_range @@ get_color ~dark:false i + ] + else + Seq.empty + ) + (let ds_avg, def3 = + def ~step ~data ~ds_name ~cf_type:Rrd.CF_Average + in + List.to_seq + [def3; line ~label:ds_name ~def:ds_avg @@ get_color ~dark:true i] + ) + ) + in + Cmd.( + v "rrdtool" + % "graph" + % "--imgformat" + % "SVG" + % Fpath.to_string filename + % "--title" + % title + % "--width" + % string_of_int width + % "--height" + % "256" (* ~4 rows *) + % "--start" + % Int64.to_string first + % "--end" + % Int64.to_string last + %% of_list graph + ) + +let prepare_plot_cmds ~filename ~data rrd = + let open Rrd in + let has cf rra = rra.rra_cf = cf in + let has_min = + Array.find_opt (has Rrd.CF_Min) rrd.rrd_rras |> Option.is_some + in + let has_max = + Array.find_opt (has Rrd.CF_Max) rrd.rrd_rras |> Option.is_some + in + rrd.rrd_rras + |> Array.to_seq + |> Seq.map @@ fun rra -> + let timespan = + Int64.mul (Int64.of_int (rra.rra_pdp_cnt * rra.rra_row_cnt)) rrd.timestep + in + let start = rrd.last_updated -. Int64.to_float timespan in + let filename = + Fpath.add_ext (Int64.to_string timespan) filename |> Fpath.add_ext "svg" + in + let title = + Fpath.rem_ext filename + |> Fpath.basename + |> String.cuts ~sep:"." + |> String.concat ~sep:"
" + in + let step = Int64.(mul (of_int rra.rra_pdp_cnt) rrd.timestep) in + let width = 2 * rra.rra_row_cnt in + (* 1 point = 1 CDP from the RRA *) + (* TODO: could look up original names in original_ds *) + rrdtool ~step ~width ~data ~filename title ~ds_names:(ds_names rrd) + ~has_min_max:(has_min && has_max) ~first:(Int64.of_float start) + ~last:(Int64.of_float rrd.last_updated) + +let prepare_plots ?(exec = false) ~filename ~data rrd = + let output = Fpath.set_ext ".sh" filename in + let cmds = prepare_plot_cmds ~filename ~data rrd in + if exec then + cmds + |> Seq.iter @@ fun cmd -> + OS.Cmd.run cmd + |> Logs.on_error_msg ~use:(fun () -> failwith "failed to run rrdtool") + else + cmds + |> Seq.map Cmd.to_string + |> List.of_seq + |> OS.File.write_lines output + |> Logs.on_error_msg ~use:(fun _ -> exit 2) + +let finally f ~(always : unit -> unit) = + match f () with + | result -> + always () ; result + | exception e -> + always () ; raise e + +let with_input_file path f = + if Fpath.has_ext "gz" path then + let cmd = Cmd.(v "zcat" % p path) in + let ic = cmd |> Cmd.to_string |> Unix.open_process_in in + finally + (fun () -> f ic) + ~always:(fun () -> + let (_ : Unix.process_status) = Unix.close_process_in ic in + () + ) + else + let ic = open_in Fpath.(to_string path) in + finally (fun () -> f ic) ~always:(fun () -> close_in ic) + +let with_input_rrd f filename = + with_input_file filename @@ fun ic -> + Logs.info (fun m -> m "Parsing RRD %a" Fpath.pp filename) ; + let input = Xmlm.make_input (`Channel ic) in + let rrd = Rrd.from_xml input in + f ~filename rrd + +(* to avoid mixing data source and filenames we use a different type here *) + +let make_ds ?filename dsname = + let dsname = + if String.length dsname >= 20 then ( + Logs.warn (fun m -> + m "RRD data source name exceeds 20 char limit: %s" dsname + ) ; + String.with_range dsname ~len:19 + ) else + dsname + in + (Option.map Fpath.v filename, Ds dsname) + +let make_sr (dsname, uuid) = make_ds ~filename:("_sr_" ^ uuid) dsname + +let make_vbd (vbd, dsname) = make_ds ~filename:vbd dsname + +let make_runstate dsname = make_ds ~filename:"runstate" dsname + +(* top-level value to compile regexes only once *) +let classify = + (* some RRD data source names are too long, max is 20 chars. + Splitting RRDs into different files allows to shorten the names, + e.g. remove the UUID from SR datasources. + Some names are still too long, but those can be shortened without losing information. *) + let open Tyre in + let uuid8 = pcre "[0-9a-f]{8}" in + let uuid_rest = pcre "(-[0-9a-f]{4}){3}-[0-9a-f]{12}" in + let dsname = pcre "[a-zA-Z_]+" in + let shorten from target = str from --> fun () -> make_ds target in + [ + (dsname <&> char '_' *> uuid8) --> make_sr + ; (str "sr_" *> uuid8 <* uuid_rest <* char '_' <&> dsname) --> make_sr + ; shorten "Tapdisks_in_low_memory_mode" "Tapdisks_in_lowmem" + ; ( (opt dsname <* str "memory_" <&> dsname) --> fun (pre, post) -> + make_ds (Option.value ~default:"" pre ^ "mem_" ^ post) + ) + ; (pcre "vbd_[^_]+" <* char '_' <&> dsname) --> make_vbd + ; (str "runstate_" *> dsname) --> make_runstate + ; ( (str "cpu" *> int <&> opt @@ (str "-C" *> int)) --> fun (cpuidx, cstate) -> + let filename = + match cstate with None -> "cpu" | Some n -> Printf.sprintf "cpu-C%d" n + in + make_ds ~filename ("cpu" ^ string_of_int cpuidx) + ) + ; (str "cpu_avg" --> fun () -> make_ds ~filename:"cpu_avg" "cpu_avg") + ; (pcre "pif_" *> dsname) --> make_ds ~filename:"pif" + (* TODO: could provide info on polarity based on rx/tx and on kind, TICK for errors *) + ] + |> route + +let classify_dsname dsname = + let error _ = make_ds dsname in + dsname |> Tyre.exec classify |> Result.fold ~ok:Fun.id ~error + +let classify ~ds_def ~filename ds = + let open Rrd in + let override, dsname = classify_dsname ds.ds_name in + let pathname = + let name = Fpath.rem_ext filename in + match override with + | None -> + Fpath.(name + "_filtered") + | Some newname -> + Fpath.(name + to_string newname) + in + (* Logs.debug (fun m -> m "%s -> %a" ds.ds_name Fpath.pp pathname); *) + let def = + StringMap.find_opt ds.ds_name ds_def |> Option.value ~default:default_def + in + (* can only plot graphs with same units *) + let extra = + match def.units with + | None -> + (* use RRD type as approximation to "same unit", at least same kind of unit, + e.g. rate vs duration *) + Rrd.ds_type_to_string ds.ds_ty + | Some u -> + String.take ~sat:Char.Ascii.is_alphanum u + in + (Fpath.(pathname + extra |> add_ext "xml"), dsname) + +let rrdtool = + OS.Cmd.resolve (Cmd.v "rrdtool") + |> Logs.on_error_msg ~use:(fun () -> failwith "rrdtool is not installed") + +let rrd_restore filename rrd = + let filename = Fpath.set_ext "xml" filename in + Logs.debug (fun m -> m "Writing RRD xml to %a" Fpath.pp filename) ; + let () = + Out_channel.with_open_text (Fpath.to_string filename) @@ fun ch -> + Rrd_unix.to_fd rrd (Unix.descr_of_out_channel ch) + in + let dot_rrd = Fpath.set_ext "rrd" filename in + Logs.debug (fun m -> m "Restoring RRD to %a" Fpath.pp dot_rrd) ; + Cmd.(rrdtool % "restore" % "-f" % p filename % p dot_rrd) + |> OS.Cmd.run + |> Result.map (fun () -> dot_rrd) + +let split_rrd ~ds_def ~filename rrd = + let open Rrd in + let rrds = Hashtbl.create 3 in + let original_ds = Hashtbl.create 127 in + + (* split the rrd into multiple rrds based on data source name *) + let () = + Logs.info (fun m -> m "classifying data sources") ; + rrd.rrd_dss + |> Array.iteri @@ fun i ds -> + let filename, Ds ds_name = classify ~ds_def ~filename ds in + let get_i rra = (rra.rra_data.(i), rra.rra_cdps.(i)) in + let previous = + Hashtbl.find_opt rrds filename |> Option.value ~default:[] + in + Hashtbl.replace original_ds ds_name ds ; + Hashtbl.replace rrds filename + @@ (({ds with ds_name}, Array.map get_i rrd.rrd_rras) :: previous) + in + Logs.info (fun m -> m "Building and restoring RRDs") ; + (* now build an RRD and restore it to binary .rrd form *) + rrds + |> Hashtbl.iter @@ fun filename lst -> + Logs.debug (fun m -> m "Building %a" Fpath.pp filename) ; + let rrd_dss, rrd_rras = List.split lst in + let rrd_rras = + rrd.rrd_rras + |> Array.mapi @@ fun i rra -> + let rra_seq = List.to_seq rrd_rras in + let geti a = a.(i) in + { + rra with + rra_data= rra_seq |> Seq.map geti |> Seq.map fst |> Array.of_seq + ; rra_cdps= rra_seq |> Seq.map geti |> Seq.map snd |> Array.of_seq + } + in + let rrd = {rrd with rrd_dss= Array.of_list rrd_dss; rrd_rras} in + let data = + rrd_restore filename rrd + |> Logs.on_error_msg ~use:(fun () -> failwith "Failed to restore RRD") + in + prepare_plots ~filename ~data rrd + +type mode = Split | Default | Plot + +let parse_ds_def def k v = + match k with "units" when v <> "unknown" -> {units= Some v} | _ -> def + +let parse_ds_defs path = + Logs.info (fun m -> m "Loading data source definitions from %a" Fpath.pp path) ; + let fields line = + line + |> String.cut ~sep:":" + |> Option.map @@ fun (k, v) -> (String.trim k, String.trim v) + in + let fold (map, key_opt) line = + match (fields line, key_opt) with + | Some ("name_label", ds_name), None -> + (map, Some ds_name) (* start parsing new item *) + | _, None -> + (map, None) (* ignore *) + | None, Some _ -> + (map, None) + | Some (k, v), Some ds_name -> + let map = + map + |> Rrd.StringMap.update ds_name @@ fun def -> + Some (parse_ds_def (Option.value ~default:default_def def) k v) + in + (map, Some ds_name) + in + OS.File.fold_lines fold (Rrd.StringMap.empty, None) path + |> Logs.on_error_msg ~use:(fun _ -> + failwith "Could not parse datasource definitions" + ) + |> fst + +let plot_rrd ~filename rrd = + let data = + rrd_restore filename rrd + |> Logs.on_error_msg ~use:(fun () -> failwith "Failed to restore RRD") + in + prepare_plots ~exec:true ~filename ~data rrd + +let () = + let open OS.Arg in + let level = + let conv = + conv ~docv:"LEVEL" Logs.level_of_string Fmt.(option Logs.pp_level) + in + opt ~doc:"Set log level" ["log"] conv ~absent:(Some Logs.Debug) + in + let mode = + opt + ~doc: + "Used in self-invocation to split rrd into multiple rrds, or to plot \ + an already split rrd" + ["mode"] ~absent:Default + @@ enum [("split", Split); ("plot", Plot); ("default", Default)] + in + + let data_source_list = + opt ~doc:"Load data source definitions" ~docv:"PATH" ["def"] ~absent:None + (some path) + in + let paths = + OS.Arg.( + parse ~doc:"Split and plot xcp-rrdd XML rrd.gz with rrdtool" ~pos:path () + ) + in + + Logs.set_level level ; + let ds_def = + Option.map parse_ds_defs data_source_list + |> Option.value ~default:Rrd.StringMap.empty + in + match mode with + | Default -> + let cmd = + Cmd.( + v "find" %% of_values p paths % "-name" % "*.gz" % "-print0" + |> OS.Cmd.run_out + ) + in + (* TODO: forward level *) + let xargs = + Cmd.( + v "xargs" + % "-0" + % "-P0" + % "-n1" + % Sys.executable_name + %% of_values ~slip:"--def" p (Option.to_list data_source_list) + % "--mode=split" + |> OS.Cmd.run_in + ) + in + let res = + OS.Cmd.out_run_in cmd + |> Logs.on_error_msg ~use:(fun _ -> exit 1) + |> xargs + in + Logs.on_error_msg ~use:(fun _ -> exit 1) res + | Split -> + paths |> List.iter @@ with_input_rrd (split_rrd ~ds_def) + | Plot -> + paths |> List.iter @@ with_input_rrd plot_rrd diff --git a/ocaml/xcp-rrdd/bin/rrdview/rrdview.mli b/ocaml/xcp-rrdd/bin/rrdview/rrdview.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/ocaml/xcp-rrdd/bin/transport-rw/dune b/ocaml/xcp-rrdd/bin/transport-rw/dune index b080d67bd8..1fc8a7ac1a 100644 --- a/ocaml/xcp-rrdd/bin/transport-rw/dune +++ b/ocaml/xcp-rrdd/bin/transport-rw/dune @@ -5,7 +5,7 @@ (package xapi-tools) (libraries cmdliner - + unix rrd-transport threads.posix xapi-idl.rrd diff --git a/ocaml/xcp-rrdd/lib/blktap/lib/dune b/ocaml/xcp-rrdd/lib/blktap/lib/dune index bc79ab629d..6963432428 100644 --- a/ocaml/xcp-rrdd/lib/blktap/lib/dune +++ b/ocaml/xcp-rrdd/lib/blktap/lib/dune @@ -4,6 +4,7 @@ (preprocess (pps ppx_cstruct)) (libraries cstruct-unix + unix ) ) diff --git a/ocaml/xcp-rrdd/lib/plugin/dune b/ocaml/xcp-rrdd/lib/plugin/dune index b927bcc161..c23c13acfd 100644 --- a/ocaml/xcp-rrdd/lib/plugin/dune +++ b/ocaml/xcp-rrdd/lib/plugin/dune @@ -12,6 +12,7 @@ xapi-stdext-threads xapi-stdext-unix threads.posix + unix xapi-rrd rrd-transport.file rrd-transport.lib @@ -32,6 +33,7 @@ xenctrl ezxenstore.core uuid + unix xapi-log threads.posix ) @@ -48,6 +50,7 @@ rrd-transport.file rrd-transport.lib threads.posix + unix xapi-idl.rrd xapi-log xapi-stdext-threads diff --git a/ocaml/xcp-rrdd/lib/rrdd/dune b/ocaml/xcp-rrdd/lib/rrdd/dune index dd63ed8876..54f1b73cd4 100644 --- a/ocaml/xcp-rrdd/lib/rrdd/dune +++ b/ocaml/xcp-rrdd/lib/rrdd/dune @@ -4,6 +4,7 @@ (flags (:standard -bin-annot)) (libraries threads.posix + unix xapi-log xapi-stdext-threads xapi_version diff --git a/ocaml/xcp-rrdd/lib/transport/file/dune b/ocaml/xcp-rrdd/lib/transport/file/dune index 37b20597ff..ffe58c234a 100644 --- a/ocaml/xcp-rrdd/lib/transport/file/dune +++ b/ocaml/xcp-rrdd/lib/transport/file/dune @@ -7,6 +7,7 @@ cstruct rrd_transport_lib threads.posix + unix ) ) diff --git a/ocaml/xcp-rrdd/test/rrdd/test_rrdd_monitor.ml b/ocaml/xcp-rrdd/test/rrdd/test_rrdd_monitor.ml index bb0f726b5e..5ff9fac1bf 100644 --- a/ocaml/xcp-rrdd/test/rrdd/test_rrdd_monitor.ml +++ b/ocaml/xcp-rrdd/test/rrdd/test_rrdd_monitor.ml @@ -60,11 +60,11 @@ let host_rrds rrd_info = Hashtbl.add h "host" rrd_info ; Some h -let update_rrds_test ~timestamp ~dss ~uuid_domids ~paused_vms ~expected_vm_rrds +let update_rrds_test ~timestamp ~dss ~uuid_domids ~expected_vm_rrds ~expected_sr_rrds ~expected_host_dss = let test () = reset_rrdd_shared_state () ; - Rrdd_monitor.update_rrds uuid_domids paused_vms + Rrdd_monitor.update_rrds uuid_domids (List.to_seq [("update_rrds_test", timestamp, List.to_seq dss)]) ; check_datasources "VM" (Some Rrdd_shared.vm_rrds) expected_vm_rrds ; check_datasources "SR" (Some Rrdd_shared.sr_rrds) expected_sr_rrds ; @@ -74,63 +74,61 @@ let update_rrds_test ~timestamp ~dss ~uuid_domids ~paused_vms ~expected_vm_rrds let update_rrds = let open Rrd in + let map_of_list ls = StringMap.of_seq (List.to_seq ls) in [ ( "Null update" - , update_rrds_test ~timestamp:0. ~dss:[] ~uuid_domids:[] ~paused_vms:[] + , update_rrds_test ~timestamp:0. ~dss:[] ~uuid_domids:StringMap.empty ~expected_vm_rrds:[] ~expected_sr_rrds:[] ~expected_host_dss:[] ) ; ( "Single host update" , update_rrds_test ~timestamp:0. ~dss:[(Host, ds_a)] - ~uuid_domids:[] ~paused_vms:[] ~expected_vm_rrds:[] ~expected_sr_rrds:[] + ~uuid_domids:StringMap.empty ~expected_vm_rrds:[] ~expected_sr_rrds:[] ~expected_host_dss:[("host", [ds_a])] ) ; ( "Multiple host updates" , update_rrds_test ~timestamp:0. ~dss:[(Host, ds_a); (Host, ds_b)] - ~uuid_domids:[] ~paused_vms:[] ~expected_vm_rrds:[] ~expected_sr_rrds:[] + ~uuid_domids:StringMap.empty ~expected_vm_rrds:[] ~expected_sr_rrds:[] ~expected_host_dss:[("host", [ds_a; ds_b])] ) ; ( "Single non-resident VM update" , update_rrds_test ~timestamp:0. ~dss:[(VM "a", ds_a)] - ~uuid_domids:[] ~paused_vms:[] ~expected_vm_rrds:[] ~expected_sr_rrds:[] + ~uuid_domids:StringMap.empty ~expected_vm_rrds:[] ~expected_sr_rrds:[] ~expected_host_dss:[] ) ; ( "Multiple non-resident VM updates" , update_rrds_test ~timestamp:0. ~dss:[(VM "a", ds_a); (VM "b", ds_a)] - ~uuid_domids:[] ~paused_vms:[] ~expected_vm_rrds:[] ~expected_sr_rrds:[] + ~uuid_domids:StringMap.empty ~expected_vm_rrds:[] ~expected_sr_rrds:[] ~expected_host_dss:[] ) ; ( "Single resident VM update" , update_rrds_test ~timestamp:0. ~dss:[(VM "a", ds_a)] - ~uuid_domids:[("a", 1)] - ~paused_vms:[] + ~uuid_domids:(map_of_list [("a", 1)]) ~expected_vm_rrds:[("a", [ds_a])] ~expected_sr_rrds:[] ~expected_host_dss:[] ) ; ( "Multiple resident VM updates" , update_rrds_test ~timestamp:0. ~dss:[(VM "a", ds_a); (VM "b", ds_a); (VM "b", ds_b)] - ~uuid_domids:[("a", 1); ("b", 1)] - ~paused_vms:[] + ~uuid_domids:(map_of_list [("a", 1); ("b", 1)]) ~expected_vm_rrds:[("a", [ds_a]); ("b", [ds_a; ds_b])] ~expected_sr_rrds:[] ~expected_host_dss:[] ) ; ( "Multiple resident and non-resident VM updates" , update_rrds_test ~timestamp:0. ~dss:[(VM "a", ds_a); (VM "b", ds_a); (VM "c", ds_a)] - ~uuid_domids:[("a", 1); ("b", 1)] - ~paused_vms:[] + ~uuid_domids:(map_of_list [("a", 1); ("b", 1)]) ~expected_vm_rrds:[("a", [ds_a]); ("b", [ds_a])] ~expected_sr_rrds:[] ~expected_host_dss:[] ) ; ( "Multiple SR updates" , update_rrds_test ~timestamp:0. ~dss:[(SR "a", ds_a); (SR "b", ds_a); (SR "b", ds_b)] - ~uuid_domids:[] ~paused_vms:[] ~expected_vm_rrds:[] + ~uuid_domids:StringMap.empty ~expected_vm_rrds:[] ~expected_sr_rrds:[("a", [ds_a]); ("b", [ds_a; ds_b])] ~expected_host_dss:[] ) diff --git a/ocaml/xcp-rrdd/test/transport/dune b/ocaml/xcp-rrdd/test/transport/dune index 4efd2bc042..4a0f06b67a 100644 --- a/ocaml/xcp-rrdd/test/transport/dune +++ b/ocaml/xcp-rrdd/test/transport/dune @@ -3,9 +3,9 @@ (package rrd-transport) (libraries alcotest - fmt rrd-transport + unix xapi-idl.rrd xapi-rrd ) diff --git a/ocaml/xe-cli/bash-completion b/ocaml/xe-cli/bash-completion index 8120df874f..d11195c667 100644 --- a/ocaml/xe-cli/bash-completion +++ b/ocaml/xe-cli/bash-completion @@ -342,7 +342,7 @@ _xe() __xe_debug "triggering autocompletion for type, class is '$fst'" if [[ "$fst" == "vbd" ]]; then - set_completions 'Disk,CD' "$value" + set_completions 'Disk,CD,Floppy' "$value" elif [[ "$fst" == "vdi" ]]; then set_completions 'system,user,suspend,crashdump' "$value" elif [[ "$fst" == "sr" ]]; then @@ -542,12 +542,16 @@ _xe() hvm | nomigrate | nested-virt | PV-drivers-up-to-date | \ PV-drivers-detected | live | cooperative | enforce-homogeneity | \ host-metrics-live | sharable | read-only | storage-lock | missing | \ - metadata-latest | empty | clustered | pool-auto-join | joined) + metadata-latest | empty | clustered | pool-auto-join | joined | \ + dry-run | metadata | paused | approximate | copy | progress | public | \ + include-snapshots | preserve-power-state | soft | update | is-unique) # Until autocompletion can be generated from the # datamodel, this is just naive hardcoding. These cases were # obtained by looking for boolean fields: # 'xapi-cli-server/records.ml | grep bool_of_string' and # 'grep string_of_bool' + # and + # 'xapi-cli-server/cli_frontend.ml | grep get_bool_param' __xe_debug "triggering autocompletion for boolean params" IFS=$'\n,' set_completions 'true,false' "$value" @@ -566,11 +570,18 @@ _xe() else all="--all" fi - if [[ "$fst" == "into-vdi" || "$fst" == "base-vdi" || "$fst" == "vdi-from" || "$fst" == "vdi-to" ]]; then + + case "$fst" in + into-vdi | base-vdi | vdi-from | vdi-to | suspend-VDI) class=vdi - else + ;; + suspend-SR) + class=sr + ;; + *) class="$fst" - fi + ;; + esac # Show corresponding name labels for each UUID SHOW_DESCRIPTION=1 @@ -588,7 +599,21 @@ _xe() __xe_debug "fst is '$fst', snd is '$snd'" if [[ "$snd" == "list" || "$fst" == "vm" ]]; then IFS=$'\n,' - set_completions_for_names "${fst}-list" "$param" "$value" + + # Try to provide a helpful "description" to the suggestions + case "$param" in + resident-on | affinity) + SHOW_DESCRIPTION=1 + class="host" + ;; + *) + ;; + esac + + local name_label_cmd="$xe ${class}-list params=name-label 2>/dev/null --minimal uuid=" + __xe_debug "description class is '$class'" + + set_completions_for_names "${fst}-list" "$param" "$value" "$name_label_cmd" return 0 fi fi @@ -638,7 +663,7 @@ _xe() local previous_params="${OLDSTYLE_WORDS[@]:2:$params_len}" previous_params=$( echo "$previous_params" | cut -d= -f1 | \ sed -r '/^\s*$/d' | cut -d: -f1 | \ - sed -re 's/^/-e "\\s*/g' -e 's/$/[=:]"/g' | paste -sd " ") + sed -re 's/^/-e "^\\s*/g' -e 's/$/[=:]"/g' | paste -sd " ") set_completions "$SUBCOMMAND_PARAMS" "$param" "" "$previous_params" @@ -755,6 +780,10 @@ __add_completion() local description_cmd="$2" local max_cmd_length="$3" + if [ "$word" = "" ]; then + return 0 + fi + COMPLETION_SUGGESTIONS=$((COMPLETION_SUGGESTIONS+1)) __xe_debug "\t$word" @@ -768,8 +797,8 @@ __add_completion() COMPREPLY+=( $(printf '%s%q' "$description" "$word") ) else if [[ $SHOW_DESCRIPTION == 1 ]]; then - __xe_debug "\t showing command description - '$description'" description=" - $(eval $description_cmd$word)" + __xe_debug "\t showing command description - '$description'" fi # Right-pad the command with spaces before the help string COMPREPLY+=( $(printf "%-${max_cmd_length}q %s" "$word" "$description") ) @@ -780,7 +809,8 @@ __preprocess_suggestions() { wordlist=$( echo "$1" | \ sed -re 's/(^|[^\])((\\\\)*),,*/\1\2\n/g' -e 's/\\,/,/g' -e 's/\\\\/\\/g' | \ - sed -e 's/ *$//') + sed -e 's/ *$//' | \ + sort -u ) local IFS=$'\n' for word in $wordlist; do if [[ "$word" =~ ^$prefix.* ]]; then @@ -879,4 +909,4 @@ __autocomplete_reqd_params_names() return 0 } -bind -x '"\C-rq":"__autocomplete_reqd_params_names"' +bind -x '"\eq":"__autocomplete_reqd_params_names"' diff --git a/ocaml/xe-cli/dune b/ocaml/xe-cli/dune index 9141c1fab0..b61ec3cde6 100644 --- a/ocaml/xe-cli/dune +++ b/ocaml/xe-cli/dune @@ -11,6 +11,7 @@ stunnel threads tracing + unix uri yojson xapi-backtrace diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index c33e32a2e0..60ecce2a47 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -66,15 +66,26 @@ let debug fmt = exception Usage let usage () = - error - "Usage: %s [-s server] [-p port] ([-u username] [-pw password] or \ - [-pwf ]) [--traceparent traceparent] \n" - Sys.argv.(0) ; - error - "\n\ - A full list of commands can be obtained by running \n\ - \t%s help -s -p \n" - Sys.argv.(0) + let help = + Printf.sprintf + {|Usage: + %s + [ -s ] XenServer host + [ -p ] XenServer port number + [ -u -pw | -pwf ] + User authentication (password or file) + [ --nossl ] Disable SSL/TLS + [ --debug ] Enable debug output + [ --debug-on-fail ] Enable debug output only on failure + [ --traceparent ] Distributed tracing context + [ ... ] Command-specific options + +A full list of commands can be obtained by running + %s help -s -p +|} + Sys.argv.(0) Sys.argv.(0) + in + error "%s" help let is_localhost ip = ip = "127.0.0.1" diff --git a/ocaml/xen-api-client/lwt/dune b/ocaml/xen-api-client/lwt/dune index 306a170d0c..9db22c4370 100644 --- a/ocaml/xen-api-client/lwt/dune +++ b/ocaml/xen-api-client/lwt/dune @@ -14,6 +14,7 @@ rpclib.json rpclib.xml ssl + unix uri xapi-client xapi-consts diff --git a/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml b/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml index a69e942308..4f1c2d708c 100644 --- a/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml +++ b/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml @@ -129,7 +129,6 @@ let exn_to_string = function Printexc.to_string e let do_it uri string = - let uri = Uri.of_string uri in let connection = M.make uri in Lwt.finalize (fun () -> @@ -179,7 +178,7 @@ module SessionCache = struct let make_rpc ?timeout target = let uri = Uri.with_path target "/jsonrpc" in - make_json ?timeout @@ Uri.to_string @@ uri + make_json ?timeout uri let create_rpc ?timeout rpc ~uname ~pwd ~version ~originator () = let acquire () = diff --git a/ocaml/xen-api-client/lwt/xen_api_lwt_unix.mli b/ocaml/xen-api-client/lwt/xen_api_lwt_unix.mli index aed47eb613..7340d1d23d 100644 --- a/ocaml/xen-api-client/lwt/xen_api_lwt_unix.mli +++ b/ocaml/xen-api-client/lwt/xen_api_lwt_unix.mli @@ -12,11 +12,11 @@ * GNU Lesser General Public License for more details. *) -val make : ?timeout:float -> string -> Rpc.call -> Rpc.response Lwt.t +val make : ?timeout:float -> Uri.t -> Rpc.call -> Rpc.response Lwt.t (** [make ?timeout uri] returns an 'rpc' function which can be passed to Client.* functions *) -val make_json : ?timeout:float -> string -> Rpc.call -> Rpc.response Lwt.t +val make_json : ?timeout:float -> Uri.t -> Rpc.call -> Rpc.response Lwt.t (** [make ?timeout uri] returns an 'rpc' function which can be passed to Client.* functions *) diff --git a/ocaml/xen-api-client/lwt_examples/dune b/ocaml/xen-api-client/lwt_examples/dune index 56d95a3e6d..b3d8220f7a 100644 --- a/ocaml/xen-api-client/lwt_examples/dune +++ b/ocaml/xen-api-client/lwt_examples/dune @@ -20,9 +20,9 @@ (modules upload_disk) (libraries cstruct - lwt lwt.unix + unix uri xapi-consts xapi-types diff --git a/ocaml/xenopsd/c_stubs/dune b/ocaml/xenopsd/c_stubs/dune index f22b2ea896..c7a34c5c2e 100644 --- a/ocaml/xenopsd/c_stubs/dune +++ b/ocaml/xenopsd/c_stubs/dune @@ -10,11 +10,9 @@ (library (name xapi_xenopsd_xc_c_stubs) (wrapped false) - (libraries xenctrl) (foreign_stubs (language c) - (names tuntap_stubs xenctrlext_stubs) + (names tuntap_stubs) ) - (c_library_flags (-L/lib64 -lxenforeignmemory)) ) diff --git a/ocaml/xenopsd/cli/dune b/ocaml/xenopsd/cli/dune index 9b4b9baa7d..88d76bfa43 100644 --- a/ocaml/xenopsd/cli/dune +++ b/ocaml/xenopsd/cli/dune @@ -13,6 +13,7 @@ rpclib.json rresult threads + unix uuid uuidm xapi-idl diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index a6ed6a884b..24fecb9cf0 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -278,6 +278,7 @@ let vbd_of_disk_info vm_id info = ; extra_private_keys= [] ; qos= None ; persistent= true + ; can_attach_early= false } let print_disk vbd = diff --git a/ocaml/xenopsd/dbgring/dune b/ocaml/xenopsd/dbgring/dune index b9d4773b34..3d31cdc0ec 100644 --- a/ocaml/xenopsd/dbgring/dune +++ b/ocaml/xenopsd/dbgring/dune @@ -12,6 +12,7 @@ xenstore_transport xenstore_transport.unix threads + unix xapi-idl.xen rpclib.core uutf diff --git a/ocaml/xenopsd/lib/bootloader.ml b/ocaml/xenopsd/lib/bootloader.ml index 8e4012a90d..ae91daf8c3 100644 --- a/ocaml/xenopsd/lib/bootloader.ml +++ b/ocaml/xenopsd/lib/bootloader.ml @@ -223,8 +223,6 @@ let sanity_check_path p = let extract (task : Xenops_task.task_handle) ~bootloader ~disk ?(legacy_args = "") ?(extra_args = "") ?(pv_bootloader_args = "") ~vm:vm_uuid ~domid () = - (* Without this path, pygrub will fail: *) - Unixext.mkdir_rec "/var/run/xend/boot" 0o0755 ; let bootloader_path, cmdline = command bootloader true pv_bootloader_args disk vm_uuid domid in diff --git a/ocaml/xenopsd/lib/dune b/ocaml/xenopsd/lib/dune index 694327c44f..a865cea18b 100644 --- a/ocaml/xenopsd/lib/dune +++ b/ocaml/xenopsd/lib/dune @@ -21,6 +21,7 @@ sexplib sexplib0 stunnel + unix uri uuid uuidm diff --git a/ocaml/xenopsd/lib/xenops_migrate.ml b/ocaml/xenopsd/lib/xenops_migrate.ml index 1121af8302..c16c65bd8f 100644 --- a/ocaml/xenopsd/lib/xenops_migrate.ml +++ b/ocaml/xenopsd/lib/xenops_migrate.ml @@ -93,7 +93,7 @@ end module Forwarded_http_request = struct (** Subset of the structure sent by xapi *) type t = { - uri: string + path: string ; query: (string * string) list ; additional_headers: (string * string) list ; cookie: (string * string) list diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index 2ad0422104..6a06b36ba1 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -168,6 +168,8 @@ type atomic = | VM_rename of (Vm.id * Vm.id * rename_when) | VM_import_metadata of (Vm.id * Metadata.t) | Parallel of Vm.id * string * atomic list + | Nested_parallel of Vm.id * string * atomic list + (** used to make nested parallel atoms explicit, as each atom requires its own worker *) | Serial of Vm.id * string * atomic list | Best_effort of atomic [@@deriving rpcty] @@ -286,6 +288,9 @@ let rec name_of_atomic = function | Parallel (_, _, atomics) -> Printf.sprintf "Parallel (%s)" (String.concat " | " (List.map name_of_atomic atomics)) + | Nested_parallel (_, _, atomics) -> + Printf.sprintf "Nested_parallel (%s)" + (String.concat " | " (List.map name_of_atomic atomics)) | Serial (_, _, atomics) -> Printf.sprintf "Serial (%s)" (String.concat " & " (List.map name_of_atomic atomics)) @@ -295,7 +300,7 @@ let rec name_of_atomic = function let rec atomic_expires_after = function | Serial (_, _, ops) -> List.map atomic_expires_after ops |> List.fold_left ( +. ) 0. - | Parallel (_, _, ops) -> + | Parallel (_, _, ops) | Nested_parallel (_, _, ops) -> List.map atomic_expires_after ops |> List.fold_left Float.max 0. | _ -> (* 20 minutes, in seconds *) @@ -311,6 +316,7 @@ type vm_migrate_op = { ; vmm_tmp_dest_id: Vm.id ; vmm_compress: bool ; vmm_verify_dest: bool + ; vmm_localhost_migration: bool } [@@deriving rpcty] @@ -842,10 +848,11 @@ module Queues = struct let get tag qs = with_lock qs.m (fun () -> - if StringMap.mem tag qs.qs then - StringMap.find tag qs.qs - else - Queue.create () + match StringMap.find_opt tag qs.qs with + | Some x -> + x + | None -> + Queue.create () ) let tags qs = @@ -856,10 +863,11 @@ module Queues = struct let push_with_coalesce should_keep tag item qs = with_lock qs.m (fun () -> let q = - if StringMap.mem tag qs.qs then - StringMap.find tag qs.qs - else - Queue.create () + match StringMap.find_opt tag qs.qs with + | Some x -> + x + | None -> + Queue.create () in push_with_coalesce should_keep item q ; qs.qs <- StringMap.add tag q qs.qs ; @@ -915,6 +923,33 @@ module Redirector = struct Parallel atoms, creating a deadlock. *) let parallel_queues = {queues= Queues.create (); mutex= Mutex.create ()} + (* We create another queue only for Nested_parallel atoms for the same reason + as parallel_queues. When a Nested_parallel atom is inside a Parallel atom, + they are both using a worker whilst not doing any work, so they each need + additional space to prevent a deadlock. *) + let nested_parallel_queues = + {queues= Queues.create (); mutex= Mutex.create ()} + + (* We create another queue only for VM_receive_memory operations for the same reason again. + Migration spawns 2 operations, send and receive, so if there is limited available worker space + a deadlock can happen when VMs are migrating between hosts or on localhost migration + as the receiver has no free workers to receive memory. *) + let receive_memory_queues = {queues= Queues.create (); mutex= Mutex.create ()} + + (* we do not want to use = when comparing queues: queues can contain + (uncomparable) functions, and we are only interested in comparing the + equality of their static references *) + let is_same_redirector q1 q2 = q1 == q2 + + let to_string r = + match r with + | w when is_same_redirector w parallel_queues -> + "Parallel" + | w when is_same_redirector w nested_parallel_queues -> + "Nested_parallel" + | _ -> + "Default" + (* When a thread is actively processing a queue, items are redirected to a thread-private queue *) let overrides = ref StringMap.empty @@ -1034,6 +1069,8 @@ module Redirector = struct List.concat_map one (default.queues :: parallel_queues.queues + :: nested_parallel_queues.queues + :: receive_memory_queues.queues :: List.map snd (StringMap.bindings !overrides) ) ) @@ -1218,11 +1255,11 @@ module WorkerPool = struct operate *) let count_active queues = with_lock m (fun () -> - (* we do not want to use = when comparing queues: queues can contain - (uncomparable) functions, and we are only interested in comparing the - equality of their static references *) List.map - (fun w -> w.Worker.redirector == queues && Worker.is_active w) + (fun w -> + Redirector.is_same_redirector w.Worker.redirector queues + && Worker.is_active w + ) !pool |> List.filter (fun x -> x) |> List.length @@ -1230,17 +1267,18 @@ module WorkerPool = struct let find_one queues f = List.fold_left - (fun acc x -> acc || (x.Worker.redirector == queues && f x)) + (fun acc x -> + acc || (Redirector.is_same_redirector x.Worker.redirector queues && f x) + ) false (* Clean up any shutdown threads and remove them from the master list *) let gc queues pool = List.fold_left (fun acc w -> - (* we do not want to use = when comparing queues: queues can contain - (uncomparable) functions, and we are only interested in comparing the - equality of their static references *) - if w.Worker.redirector == queues && Worker.get_state w = Worker.Shutdown + if + Redirector.is_same_redirector w.Worker.redirector queues + && Worker.get_state w = Worker.Shutdown then ( Worker.join w ; acc ) else @@ -1267,7 +1305,9 @@ module WorkerPool = struct let start size = for _i = 1 to size do incr Redirector.default ; - incr Redirector.parallel_queues + incr Redirector.parallel_queues ; + incr Redirector.nested_parallel_queues ; + incr Redirector.receive_memory_queues done let set_size size = @@ -1282,7 +1322,9 @@ module WorkerPool = struct done in inner Redirector.default ; - inner Redirector.parallel_queues + inner Redirector.parallel_queues ; + inner Redirector.nested_parallel_queues ; + inner Redirector.receive_memory_queues end (* Keep track of which VMs we're rebooting so we avoid transient glitches where @@ -1583,6 +1625,11 @@ let collect_into apply = function [] -> [] | [op] -> [op] | lst -> apply lst let parallel name ~id = collect_into (fun ls -> [Parallel (id, Printf.sprintf "%s VM=%s" name id, ls)]) +let nested_parallel name ~id = + collect_into (fun ls -> + [Nested_parallel (id, Printf.sprintf "%s VM=%s" name id, ls)] + ) + let serial name ~id = collect_into (fun ls -> [Serial (id, Printf.sprintf "%s VM=%s" name id, ls)]) @@ -1592,6 +1639,9 @@ let serial_concat name ~id lst = serial name ~id (List.concat lst) let parallel_map name ~id lst f = parallel name ~id (List.concat_map f lst) +let nested_parallel_map name ~id lst f = + nested_parallel name ~id (List.concat_map f lst) + let map_or_empty f x = Option.value ~default:[] (Option.map f x) (* Creates a Serial of 2 or more Atomics. If the number of Atomics could be @@ -1629,7 +1679,7 @@ let rec atomics_of_operation = function let pf = Printf.sprintf in let name_multi = pf "VBDs.activate_epoch_and_plug %s" typ in let name_one = pf "VBD.activate_epoch_and_plug %s" typ in - parallel_map name_multi ~id vbds (fun vbd -> + nested_parallel_map name_multi ~id vbds (fun vbd -> serial_concat name_one ~id [ [VBD_set_active (vbd.Vbd.id, true)] @@ -1663,11 +1713,11 @@ let rec atomics_of_operation = function vifs ; serial_concat "VGPUs.activate & PCI.plug (SRIOV)" ~id [ - parallel_map "VGPUs.activate" ~id vgpus (fun vgpu -> + nested_parallel_map "VGPUs.activate" ~id vgpus (fun vgpu -> [VGPU_set_active (vgpu.Vgpu.id, true)] ) - ; parallel_map "PCIs.plug (SRIOV)" ~id pcis_sriov (fun pci -> - [PCI_plug (pci.Pci.id, false)] + ; nested_parallel_map "PCIs.plug (SRIOV)" ~id pcis_sriov + (fun pci -> [PCI_plug (pci.Pci.id, false)] ) ] ] @@ -1715,7 +1765,8 @@ let rec atomics_of_operation = function serial "VIF.activate_and_plug" ~id [VIF_set_active (vif.Vif.id, true); VIF_plug vif.Vif.id] ) - | VM_restore_devices (id, restore_vifs) -> + | VM_restore_devices (id, migration) -> + let restore_vifs = not migration in let vbds_rw, vbds_ro = VBD_DB.vbds id |> vbd_plug_sets in let vgpus = VGPU_DB.vgpus id in let pcis = PCI_DB.pcis id |> pci_plug_order in @@ -1725,8 +1776,22 @@ let rec atomics_of_operation = function let name_multi = pf "VBDs.activate_and_plug %s" typ in let name_one = pf "VBD.activate_and_plug %s" typ in parallel_map name_multi ~id vbds (fun vbd -> - serial name_one ~id - [VBD_set_active (vbd.Vbd.id, true); vbd_plug vbd.Vbd.id] + (* When migrating, attach early if the vbd's SM allows it. + Note: there is a bug here for SxM if migrating between API + versions as the Vbd's new SR won't have propagated to xenopsd + yet. This means can_attach_early will be based on the origin SR. + This is a non-issue as v1 <-> v3 migration is still experimental + and v1 is already early-attaching in SxM through mirroring. + *) + if + migration + && (not !xenopsd_vbd_plug_unplug_legacy) + && vbd.Vbd.can_attach_early + then + [VBD_activate vbd.Vbd.id] + else + serial name_one ~id + [VBD_set_active (vbd.Vbd.id, true); vbd_plug vbd.Vbd.id] ) in [ @@ -1849,7 +1914,7 @@ let rec atomics_of_operation = function ] ; vgpu_start_operations ; [VM_restore (id, data, vgpu_data)] - ; atomics_of_operation (VM_restore_devices (id, true)) + ; atomics_of_operation (VM_restore_devices (id, false)) ; [ (* At this point the domain is considered survivable. *) VM_set_domain_action_request (id, None) @@ -1881,57 +1946,12 @@ let rec perform_atomic ~progress_callback ?result (op : atomic) debug "Ignoring error during best-effort operation: %s" (Printexc.to_string e) ) - | Parallel (_id, description, atoms) -> - (* parallel_id is a unused unique name prefix for a parallel worker queue *) - let parallel_id = - Printf.sprintf "Parallel:task=%s.atoms=%d.(%s)" - (Xenops_task.id_of_handle t) - (List.length atoms) description - in - let with_tracing = id_with_tracing parallel_id t in - debug "begin_%s" parallel_id ; - let task_list = - queue_atomics_and_wait ~progress_callback ~max_parallel_atoms:10 - with_tracing parallel_id atoms - in - debug "end_%s" parallel_id ; - (* make sure that we destroy all the parallel tasks that finished *) - let errors = - List.map - (fun (id, task_handle, task_state) -> - match task_state with - | Some (Task.Completed _) -> - TASK.destroy' id ; None - | Some (Task.Failed e) -> - TASK.destroy' id ; - let e = - match Rpcmarshal.unmarshal Errors.error.Rpc.Types.ty e with - | Ok x -> - Xenopsd_error x - | Error (`Msg x) -> - internal_error "Error unmarshalling failure: %s" x - in - Some e - | None | Some (Task.Pending _) -> - (* Because pending tasks are filtered out in - queue_atomics_and_wait with task_ended the second case will - never be encountered. The previous boolean used in - event_wait was enough to express the possible cases *) - let err_msg = - Printf.sprintf "Timed out while waiting on task %s (%s)" id - (Xenops_task.get_dbg task_handle) - in - error "%s" err_msg ; - Xenops_task.cancel task_handle ; - Some (Xenopsd_error (Internal_error err_msg)) - ) - task_list - in - (* if any error was present, raise first one, so that - trigger_cleanup_after_failure is called *) - List.iter - (fun err -> match err with None -> () | Some e -> raise e) - errors + | Parallel (_id, description, atoms) as atom -> + check_nesting atom ; + parallel_atomic ~progress_callback ~description ~nested:false atoms t + | Nested_parallel (_id, description, atoms) as atom -> + check_nesting atom ; + parallel_atomic ~progress_callback ~description ~nested:true atoms t | Serial (_, _, atoms) -> List.iter (Fun.flip (perform_atomic ~progress_callback) t) atoms | VIF_plug id -> @@ -2079,10 +2099,7 @@ let rec perform_atomic ~progress_callback ?result (op : atomic) | VBD_unplug (id, force) -> debug "VBD.unplug %s" (VBD_DB.string_of_id id) ; finally - (fun () -> - B.VBD.deactivate t (VBD_DB.vm_of id) (VBD_DB.read_exn id) force ; - B.VBD.detach t (VBD_DB.vm_of id) (VBD_DB.read_exn id) - ) + (fun () -> B.VBD.unplug t (VBD_DB.vm_of id) (VBD_DB.read_exn id) force) (fun () -> VBD_DB.signal id) | VBD_deactivate (id, force) -> debug "VBD.deactivate %s" (VBD_DB.string_of_id id) ; @@ -2282,11 +2299,18 @@ let rec perform_atomic ~progress_callback ?result (op : atomic) debug "VM.destroy %s" id ; B.VM.destroy t (VM_DB.read_exn id) | VM_create (id, memory_upper_bound, final_id, no_sharept) -> - debug "VM.create %s memory_upper_bound = %s" id + let num_of_vbds = List.length (VBD_DB.vbds id) in + let num_of_vifs = List.length (VIF_DB.vifs id) in + debug + "VM.create %s memory_upper_bound = %s, num_of_vbds = %d, num_of_vifs = \ + %d" + id (Option.value ~default:"None" (Option.map Int64.to_string memory_upper_bound) - ) ; + ) + num_of_vbds num_of_vifs ; B.VM.create t memory_upper_bound (VM_DB.read_exn id) final_id no_sharept + num_of_vbds num_of_vifs | VM_build (id, force) -> debug "VM.build %s" id ; let vbds : Vbd.t list = VBD_DB.vbds id |> vbd_plug_order in @@ -2360,7 +2384,92 @@ let rec perform_atomic ~progress_callback ?result (op : atomic) debug "VM.soft_reset %s" id ; B.VM.soft_reset t (VM_DB.read_exn id) -and queue_atomic_int ~progress_callback dbg id op = +and check_nesting atom = + let msg_prefix = "Nested atomics error" in + let rec check_nesting_inner found_parallel found_nested = function + | Parallel (_, _, rem) -> + if found_parallel then ( + warn + "%s: Two or more Parallel atoms found, use Nested_parallel for the \ + inner atom" + msg_prefix ; + true + ) else + List.exists (check_nesting_inner true found_nested) rem + | Nested_parallel (_, _, rem) -> + if found_nested then ( + warn + "%s: Two or more Nested_parallel atoms found, there should only be \ + one layer of nesting" + msg_prefix ; + true + ) else + List.exists (check_nesting_inner found_parallel true) rem + | Serial (_, _, rem) -> + List.exists (check_nesting_inner found_parallel found_nested) rem + | _ -> + false + in + ignore @@ check_nesting_inner false false atom + +and parallel_atomic ~progress_callback ~description ~nested atoms t = + (* parallel_id is a unused unique name prefix for a parallel worker queue *) + let redirector = + if nested then + Redirector.nested_parallel_queues + else + Redirector.parallel_queues + in + let parallel_id = + Printf.sprintf "%s:task=%s.atoms=%d.(%s)" + (Redirector.to_string redirector) + (Xenops_task.id_of_handle t) + (List.length atoms) description + in + let with_tracing = id_with_tracing parallel_id t in + debug "begin_%s" parallel_id ; + let task_list = + queue_atomics_and_wait ~progress_callback ~max_parallel_atoms:10 + with_tracing parallel_id atoms redirector + in + debug "end_%s" parallel_id ; + (* make sure that we destroy all the parallel tasks that finished *) + let errors = + List.map + (fun (id, task_handle, task_state) -> + match task_state with + | Some (Task.Completed _) -> + TASK.destroy' id ; None + | Some (Task.Failed e) -> + TASK.destroy' id ; + let e = + match Rpcmarshal.unmarshal Errors.error.Rpc.Types.ty e with + | Ok x -> + Xenopsd_error x + | Error (`Msg x) -> + internal_error "Error unmarshalling failure: %s" x + in + Some e + | None | Some (Task.Pending _) -> + (* Because pending tasks are filtered out in + queue_atomics_and_wait with task_ended the second case will + never be encountered. The previous boolean used in + event_wait was enough to express the possible cases *) + let err_msg = + Printf.sprintf "Timed out while waiting on task %s (%s)" id + (Xenops_task.get_dbg task_handle) + in + error "%s" err_msg ; + Xenops_task.cancel task_handle ; + Some (Xenopsd_error (Internal_error err_msg)) + ) + task_list + in + (* if any error was present, raise first one, so that + trigger_cleanup_after_failure is called *) + List.iter (fun err -> match err with None -> () | Some e -> raise e) errors + +and queue_atomic_int ~progress_callback dbg id op redirector = let task = Xenops_task.add tasks dbg (let r = ref None in @@ -2369,10 +2478,12 @@ and queue_atomic_int ~progress_callback dbg id op = !r ) in - Redirector.push Redirector.parallel_queues id (Atomic op, task) ; + debug "Adding to %s queues" (Redirector.to_string redirector) ; + Redirector.push redirector id (Atomic op, task) ; task -and queue_atomics_and_wait ~progress_callback ~max_parallel_atoms dbg id ops = +and queue_atomics_and_wait ~progress_callback ~max_parallel_atoms dbg id ops + redirector = let from = Updates.last_id dbg updates in Xenops_utils.chunks max_parallel_atoms ops |> List.mapi (fun chunk_idx ops -> @@ -2385,7 +2496,9 @@ and queue_atomics_and_wait ~progress_callback ~max_parallel_atoms dbg id ops = let atom_id = Printf.sprintf "%s.chunk=%d.atom=%d" id chunk_idx atom_idx in - (queue_atomic_int ~progress_callback dbg atom_id op, op) + ( queue_atomic_int ~progress_callback dbg atom_id op redirector + , op + ) ) ops in @@ -2561,7 +2674,9 @@ and trigger_cleanup_after_failure_atom op t = immediate_operation dbg id (VM_check_state id) | Best_effort op -> trigger_cleanup_after_failure_atom op t - | Parallel (_id, _description, ops) | Serial (_id, _description, ops) -> + | Parallel (_id, _description, ops) + | Nested_parallel (_id, _description, ops) + | Serial (_id, _description, ops) -> List.iter (fun op -> trigger_cleanup_after_failure_atom op t) ops | VM_rename (id1, id2, _) -> immediate_operation dbg id1 (VM_check_state id1) ; @@ -2602,9 +2717,9 @@ and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = | VM_restore_vifs id -> debug "VM_restore_vifs %s" id ; perform_atomics (atomics_of_operation op) t - | VM_restore_devices (id, restore_vifs) -> + | VM_restore_devices (id, migration) -> (* XXX: this is delayed due to the 'attach'/'activate' behaviour *) - debug "VM_restore_devices %s %b" id restore_vifs ; + debug "VM_restore_devices %s %b" id migration ; perform_atomics (atomics_of_operation op) t | VM_resume (id, _data) -> debug "VM.resume %s" id ; @@ -2689,19 +2804,30 @@ and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = ~path:(Uri.path_unencoded url ^ snippet ^ id_str) ~query:(Uri.query url) () in - (* CA-78365: set the memory dynamic range to a single value to stop - ballooning. *) - let atomic = - VM_set_memory_dynamic_range - (id, vm.Vm.memory_dynamic_min, vm.Vm.memory_dynamic_min) - in - let (_ : unit) = - perform_atomic ~progress_callback:(fun _ -> ()) atomic t - in - (* Waiting here is not essential but adds a degree of safety and - reducess unnecessary memory copying. *) - ( try B.VM.wait_ballooning t vm - with Xenopsd_error Ballooning_timeout_before_migration -> () + (* CA-78365: set the memory dynamic range to a single value + to stop ballooning, if ballooning is enabled at all *) + ( if vm.memory_dynamic_min <> vm.memory_dynamic_max then + (* There's no need to balloon down when doing localhost migration - + we're not copying any memory in the first place. This would + likely increase VDI migration time as swap would be engaged. + Instead change the ballooning target to the current state *) + let new_balloon_target = + if vmm.vmm_localhost_migration then + (B.VM.get_state vm).memory_actual + else + vm.memory_dynamic_min + in + let atomic = + VM_set_memory_dynamic_range + (id, new_balloon_target, new_balloon_target) + in + let (_ : unit) = + perform_atomic ~progress_callback:(fun _ -> ()) atomic t + in + (* Waiting here is not essential but adds a degree of safety and + reducess unnecessary memory copying. *) + try B.VM.wait_ballooning t vm + with Xenopsd_error Ballooning_timeout_before_migration -> () ) ; (* Find out the VM's current memory_limit: this will be used to allocate memory on the receiver *) @@ -2917,11 +3043,31 @@ and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = ( try let no_sharept = VGPU_DB.vgpus id |> List.exists is_no_sharept in debug "VM %s no_sharept=%b (%s)" id no_sharept __LOC__ ; + (* If plug is split into activate and attach, we could attach + early so that it is outside of the VM downtime (if the SM + supports this) *) + let early_attach = + parallel_map "VBDs.set_active_and_attach" ~id (VBD_DB.vbds id) + (fun vbd -> + if + (not !xenopsd_vbd_plug_unplug_legacy) + && vbd.Vbd.can_attach_early + then + serial "VBD.set_active_and_attach" ~id + [ + VBD_set_active (vbd.Vbd.id, true) + ; VBD_attach vbd.Vbd.id + ] + else + [] + ) + in perform_atomics ([VM_create (id, Some memory_limit, Some final_id, no_sharept)] - @ (* Perform as many operations as possible on the destination - domain before pausing the original domain *) - atomics_of_operation (VM_restore_vifs id) + (* Perform as many operations as possible on the destination + domain before pausing the original domain *) + @ atomics_of_operation (VM_restore_vifs id) + @ early_attach ) t ; Handshake.send s Handshake.Success @@ -3037,7 +3183,7 @@ and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = ) ; debug "VM.receive_memory: restoring remaining devices and unpausing" ; perform_atomics - (atomics_of_operation (VM_restore_devices (final_id, false)) + (atomics_of_operation (VM_restore_devices (final_id, true)) @ [ VM_unpause final_id ; VM_set_domain_action_request (final_id, None) @@ -3264,7 +3410,8 @@ let uses_mxgpu id = ) (VGPU_DB.ids id) -let queue_operation_int ?traceparent dbg id op = +let queue_operation_int ?traceparent ?(redirector = Redirector.default) dbg id + op = let task = Xenops_task.add ?traceparent tasks dbg (let r = ref None in @@ -3272,11 +3419,11 @@ let queue_operation_int ?traceparent dbg id op = ) in let tag = if uses_mxgpu id then "mxgpu" else id in - Redirector.push Redirector.default tag (op, task) ; + Redirector.push redirector tag (op, task) ; task -let queue_operation ?traceparent dbg id op = - let task = queue_operation_int ?traceparent dbg id op in +let queue_operation ?traceparent ?redirector dbg id op = + let task = queue_operation_int ?traceparent ?redirector dbg id op in Xenops_task.id_of_handle task let queue_operation_and_wait dbg id op = @@ -3460,12 +3607,25 @@ module VIF = struct () end -let default_numa_affinity_policy = ref Xenops_interface.Host.Any +let default_numa_affinity_policy = ref Xenops_interface.Host.Best_effort -let numa_placement = ref Xenops_interface.Host.Any +let numa_placement = ref !default_numa_affinity_policy + +type affinity = Soft | Hard let string_of_numa_affinity_policy = - Xenops_interface.Host.(function Any -> "any" | Best_effort -> "best-effort") + let open Xenops_interface.Host in + function + | Any -> + "any" + | Best_effort -> + "best-effort" + | Best_effort_hard -> + "best-effort-hard" + +let affinity_of_numa_affinity_policy = + let open Xenops_interface.Host in + function Any | Best_effort -> Soft | Best_effort_hard -> Hard module HOST = struct let stat _ dbg = @@ -3563,7 +3723,9 @@ end module VM = struct module DB = VM_DB - let add _ dbg x = Debug.with_thread_associated dbg (fun () -> DB.add' x) () + let add _ dbg x = + Debug_info.with_dbg ~with_thread:true ~name:__FUNCTION__ ~dbg @@ fun _ -> + DB.add' x let rename _ dbg id1 id2 when' = queue_operation dbg id1 (Atomic (VM_rename (id1, id2, when'))) @@ -3600,11 +3762,17 @@ module VM = struct in (vm_t, state) - let stat _ dbg id = Debug.with_thread_associated dbg (fun () -> stat' id) () + let stat _ dbg id = + Debug_info.with_dbg ~with_thread:true ~name:__FUNCTION__ ~dbg @@ fun _ -> + stat' id - let exists _ _dbg id = match DB.read id with Some _ -> true | None -> false + let exists _ dbg id = + Debug_info.with_dbg ~name:__FUNCTION__ ~dbg @@ fun _ -> + match DB.read id with Some _ -> true | None -> false - let list _ dbg () = Debug.with_thread_associated dbg (fun () -> DB.list ()) () + let list _ dbg () = + Debug_info.with_dbg ~with_thread:true ~name:__FUNCTION__ ~dbg @@ fun _ -> + DB.list () let create _ dbg id = let no_sharept = false in @@ -3658,7 +3826,7 @@ module VM = struct let s3resume _ dbg id = queue_operation dbg id (Atomic (VM_s3resume id)) let migrate _context dbg id vmm_vdi_map vmm_vif_map vmm_vgpu_pci_map vmm_url - (compress : bool) (verify_dest : bool) = + (compress : bool) (localhost_migration : bool) (verify_dest : bool) = let tmp_uuid_of uuid ~kind = Printf.sprintf "%s00000000000%c" (String.sub uuid 0 24) (match kind with `dest -> '1' | `src -> '0') @@ -3675,6 +3843,7 @@ module VM = struct ; vmm_tmp_dest_id= tmp_uuid_of id ~kind:`dest ; vmm_compress= compress ; vmm_verify_dest= verify_dest + ; vmm_localhost_migration= localhost_migration } ) @@ -3724,7 +3893,12 @@ module VM = struct ; vmr_compressed= compressed_memory } in - let task = Some (queue_operation ?traceparent dbg id op) in + let task = + Some + (queue_operation ?traceparent + ~redirector:Redirector.receive_memory_queues dbg id op + ) + in Option.iter (fun t -> t |> Xenops_client.wait_for_task dbg |> ignore) task @@ -3906,7 +4080,7 @@ module UPDATES = struct Debug.with_thread_associated dbg (fun () -> debug "UPDATES.inject_barrier %s %d" vm_id id ; - let filter k _ = + let filter k = match k with | Dynamic.Task _ -> false @@ -4137,6 +4311,12 @@ module Observer = struct (fun () -> Tracing_export.set_export_interval interval) () + let set_export_chunk_size _ dbg size = + debug "Observer.set_export_chunk_size : dbg=%s" dbg ; + Debug.with_thread_associated dbg + (fun () -> Tracing_export.set_export_chunk_size size) + () + let set_max_spans _ dbg spans = debug "Observer.set_max_spans : dbg=%s" dbg ; Debug.with_thread_associated dbg @@ -4149,6 +4329,12 @@ module Observer = struct (fun () -> Tracing.Spans.set_max_traces traces) () + let set_max_depth _ dbg depth = + debug "Observer.set_max_depth : dbg=%s" dbg ; + Debug.with_thread_associated dbg + (fun () -> Tracing.Spans.set_max_depth depth) + () + let set_max_file_size _ dbg file_size = debug "Observer.set_max_file_size : dbg=%s" dbg ; Debug.with_thread_associated dbg @@ -4272,8 +4458,10 @@ let _ = Server.Observer.init (Observer.init ()) ; Server.Observer.set_trace_log_dir (Observer.set_trace_log_dir ()) ; Server.Observer.set_export_interval (Observer.set_export_interval ()) ; + Server.Observer.set_export_chunk_size (Observer.set_export_chunk_size ()) ; Server.Observer.set_max_spans (Observer.set_max_spans ()) ; Server.Observer.set_max_traces (Observer.set_max_traces ()) ; + Server.Observer.set_max_depth (Observer.set_max_depth ()) ; Server.Observer.set_max_file_size (Observer.set_max_file_size ()) ; Server.Observer.set_host_id (Observer.set_host_id ()) ; Server.Observer.set_compress_tracing_files diff --git a/ocaml/xenopsd/lib/xenops_server_plugin.ml b/ocaml/xenopsd/lib/xenops_server_plugin.ml index 1a52749a9f..e4a61bb9ac 100644 --- a/ocaml/xenopsd/lib/xenops_server_plugin.ml +++ b/ocaml/xenopsd/lib/xenops_server_plugin.ml @@ -84,6 +84,8 @@ module type S = sig -> Vm.t -> Vm.id option -> bool (* no_sharept*) + -> int (* num_of_vbds *) + -> int (* num_of_vifs *) -> unit val build : @@ -211,6 +213,8 @@ module type S = sig val activate : Xenops_task.task_handle -> Vm.id -> Vbd.t -> unit + val unplug : Xenops_task.task_handle -> Vm.id -> Vbd.t -> bool -> unit + val deactivate : Xenops_task.task_handle -> Vm.id -> Vbd.t -> bool -> unit val detach : Xenops_task.task_handle -> Vm.id -> Vbd.t -> unit @@ -288,10 +292,7 @@ module type S = sig end module UPDATES : sig - val get : - Updates.id option - -> int option - -> Dynamic.barrier list * Dynamic.id list * Updates.id + val get : Updates.id option -> int option -> Updates.get_result end module DEBUG : sig diff --git a/ocaml/xenopsd/lib/xenops_server_simulator.ml b/ocaml/xenopsd/lib/xenops_server_simulator.ml index f8c0afab8a..0c6ac3f606 100644 --- a/ocaml/xenopsd/lib/xenops_server_simulator.ml +++ b/ocaml/xenopsd/lib/xenops_server_simulator.ml @@ -547,7 +547,8 @@ module VM = struct let remove _vm = () - let create _ memory_limit vm _ _ = with_lock m (create_nolock memory_limit vm) + let create _ memory_limit vm _ _ _ _ = + with_lock m (create_nolock memory_limit vm) let destroy _ vm = with_lock m (destroy_nolock vm) @@ -677,6 +678,8 @@ module VBD = struct let activate _ (_vm : Vm.id) (_vbd : Vbd.t) = () + let unplug _ vm vbd _ = with_lock m (remove_vbd vm vbd) + let deactivate _ vm vbd _ = with_lock m (remove_vbd vm vbd) let detach _ _vm _vbd = () diff --git a/ocaml/xenopsd/lib/xenops_server_skeleton.ml b/ocaml/xenopsd/lib/xenops_server_skeleton.ml index 2055837c47..1a42aafafb 100644 --- a/ocaml/xenopsd/lib/xenops_server_skeleton.ml +++ b/ocaml/xenopsd/lib/xenops_server_skeleton.ml @@ -27,6 +27,7 @@ module HOST = struct Host.cpu_count= 0 ; socket_count= 0 ; threads_per_core= 0 + ; nr_nodes= 0 ; vendor= "unknown" ; speed= "" ; modelname= "" @@ -64,50 +65,49 @@ module VM = struct let remove _ = () - let create _ _ _ _ = unimplemented "VM.create" + let create _ _ _ _ = unimplemented __FUNCTION__ - let build ?restore_fd:_ _ _ _ _ _ = unimplemented "VM.build" + let build ?restore_fd:_ _ _ _ _ _ = unimplemented __FUNCTION__ - let create_device_model _ _ _ _ _ = unimplemented "VM.create_device_model" + let create_device_model _ _ _ _ _ = unimplemented __FUNCTION__ - let destroy_device_model _ _ = unimplemented "VM.destroy_device_model" + let destroy_device_model _ _ = unimplemented __FUNCTION__ - let destroy _ _ = unimplemented "VM.destroy" + let destroy _ _ = unimplemented __FUNCTION__ - let pause _ _ = unimplemented "VM.pause" + let pause _ _ = unimplemented __FUNCTION__ - let unpause _ _ = unimplemented "VM.unpause" + let unpause _ _ = unimplemented __FUNCTION__ - let set_xsdata _ _ _ = unimplemented "VM.set_xsdata" + let set_xsdata _ _ _ = unimplemented __FUNCTION__ - let set_vcpus _ _ _ = unimplemented "VM.set_vcpus" + let set_vcpus _ _ _ = unimplemented __FUNCTION__ - let set_shadow_multiplier _ _ _ = unimplemented "VM.set_shadow_multipler" + let set_shadow_multiplier _ _ _ = unimplemented __FUNCTION__ - let set_memory_dynamic_range _ _ _ _ = - unimplemented "VM.set_memory_dynamic_range" + let set_memory_dynamic_range _ _ _ _ = unimplemented __FUNCTION__ - let request_shutdown _ _ _ _ = unimplemented "VM.request_shutdown" + let request_shutdown _ _ _ _ = unimplemented __FUNCTION__ - let wait_shutdown _ _ _ _ = unimplemented "VM.wait_shutdown" + let wait_shutdown _ _ _ _ = unimplemented __FUNCTION__ - let assert_can_save _ = unimplemented "VM.assert_can_save" + let assert_can_save _ = unimplemented __FUNCTION__ - let save _ _ _ _ _ _ _ = unimplemented "VM.save" + let save _ _ _ _ _ _ _ = unimplemented __FUNCTION__ - let restore _ _ _ _ _ _ _ = unimplemented "VM.restore" + let restore _ _ _ _ _ _ _ = unimplemented __FUNCTION__ - let s3suspend _ _ = unimplemented "VM.s3suspend" + let s3suspend _ _ = unimplemented __FUNCTION__ - let s3resume _ _ = unimplemented "VM.s3resume" + let s3resume _ _ = unimplemented __FUNCTION__ - let soft_reset _ _ = unimplemented "VM.soft_reset" + let soft_reset _ _ = unimplemented __FUNCTION__ let get_state _ = Xenops_utils.halted_vm - let request_rdp _ _ = unimplemented "VM.request_rdp" + let request_rdp _ _ = unimplemented __FUNCTION__ - let run_script _ _ _ = unimplemented "VM.run_script" + let run_script _ _ _ = unimplemented __FUNCTION__ let set_domain_action_request _ _ = () @@ -131,9 +131,9 @@ module PCI = struct let dequarantine _ = () - let plug _ _ _ = unimplemented "PCI.plug" + let plug _ _ _ = unimplemented __FUNCTION__ - let unplug _ _ _ = unimplemented "PCI.unplug" + let unplug _ _ _ = unimplemented __FUNCTION__ let get_device_action_request _ _ = None end @@ -145,17 +145,19 @@ module VBD = struct let epoch_end _ _ _ = () - let attach _ _ _ = unimplemented "VBD.attach" + let attach _ _ _ = unimplemented __FUNCTION__ - let activate _ _ _ = unimplemented "VBD.activate" + let activate _ _ _ = unimplemented __FUNCTION__ - let deactivate _ _ _ _ = unimplemented "VBD.deactivate" + let unplug _ _ _ _ = unimplemented __FUNCTION__ - let detach _ _ _ = unimplemented "VBD.detach" + let deactivate _ _ _ _ = unimplemented __FUNCTION__ - let insert _ _ _ _ = unimplemented "VBD.insert" + let detach _ _ _ = unimplemented __FUNCTION__ - let eject _ _ _ = unimplemented "VBD.eject" + let insert _ _ _ _ = unimplemented __FUNCTION__ + + let eject _ _ _ = unimplemented __FUNCTION__ let set_qos _ _ _ = () @@ -167,23 +169,21 @@ end module VIF = struct let set_active _ _ _ _ = () - let plug _ _ _ = unimplemented "VIF.plug" + let plug _ _ _ = unimplemented __FUNCTION__ - let unplug _ _ _ _ = unimplemented "VIF.unplug" + let unplug _ _ _ _ = unimplemented __FUNCTION__ - let move _ _ _ _ = unimplemented "VIF.move" + let move _ _ _ _ = unimplemented __FUNCTION__ - let set_carrier _ _ _ _ = unimplemented "VIF.set_carrier" + let set_carrier _ _ _ _ = unimplemented __FUNCTION__ - let set_locking_mode _ _ _ _ = unimplemented "VIF.set_locking_mode" + let set_locking_mode _ _ _ _ = unimplemented __FUNCTION__ - let set_ipv4_configuration _ _ _ _ = - unimplemented "VIF.set_ipv4_configuration" + let set_ipv4_configuration _ _ _ _ = unimplemented __FUNCTION__ - let set_ipv6_configuration _ _ _ _ = - unimplemented "VIF.set_ipv6_configuration" + let set_ipv6_configuration _ _ _ _ = unimplemented __FUNCTION__ - let set_pvs_proxy _ _ _ _ = unimplemented "VIF.set_pvs_proxy" + let set_pvs_proxy _ _ _ _ = unimplemented __FUNCTION__ let get_state _ _ = unplugged_vif @@ -191,7 +191,7 @@ module VIF = struct end module VGPU = struct - let start _ _ _ _ = unimplemented "VGPU.start" + let start _ _ _ _ = unimplemented __FUNCTION__ let set_active _ _ _ _ = () @@ -199,9 +199,9 @@ module VGPU = struct end module VUSB = struct - let plug _ _ _ = unimplemented "VUSB.plug" + let plug _ _ _ = unimplemented __FUNCTION__ - let unplug _ _ _ = unimplemented "VUSB.unplug" + let unplug _ _ _ = unimplemented __FUNCTION__ let get_state _ _ = unplugged_vusb @@ -216,4 +216,4 @@ module UPDATES = struct assert false end -module DEBUG = struct let trigger _ _ = unimplemented "DEBUG.trigger" end +module DEBUG = struct let trigger _ _ = unimplemented __FUNCTION__ end diff --git a/ocaml/xenopsd/lib/xenops_utils.ml b/ocaml/xenopsd/lib/xenops_utils.ml index 481ad1b610..53dc73709a 100644 --- a/ocaml/xenopsd/lib/xenops_utils.ml +++ b/ocaml/xenopsd/lib/xenops_utils.ml @@ -227,11 +227,13 @@ module MemFS = struct match (path, fs) with | [], Dir d -> d - | p :: ps, Dir d -> - if StringMap.mem p !d then - aux ps (StringMap.find p !d) - else + | p :: ps, Dir d -> ( + match StringMap.find_opt p !d with + | Some x -> + aux ps x + | None -> raise Not_dir + ) | _, Leaf _ -> raise Not_dir in @@ -285,14 +287,13 @@ module MemFS = struct (fun p -> let dir = dir_locked (dirname p) in let deletable = - if StringMap.mem (filename p) !dir then - match StringMap.find (filename p) !dir with - | Dir child -> - StringMap.is_empty !child - | Leaf _ -> - true - else - false + match StringMap.find_opt (filename p) !dir with + | Some (Dir child) -> + StringMap.is_empty !child + | Some (Leaf _) -> + true + | None -> + false in if deletable then dir := StringMap.remove (filename p) !dir ) diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index 276192792d..d4a08e92be 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -49,6 +49,15 @@ let default_vbd_backend_kind = ref "vbd" let ca_140252_workaround = ref false +(* Optimize performance: set MTRR WB attribute on Xen PCI MMIO BAR. + This is useful for AMD, and mostly a noop on Intel (which achieves a similar + effect using Intel-only features in Xen) + + Turning on WB is done by disabling UC: + UnCached=false -> WriteBack=true +*) +let xen_platform_pci_bar_uc = ref false + let action_after_qemu_crash = ref None let additional_ballooning_timeout = ref 120. @@ -59,7 +68,7 @@ let feature_flags_path = ref "/etc/xenserver/features.d" let pvinpvh_xen_cmdline = ref "pv-shim console=xen" -let numa_placement_compat = ref false +let numa_placement_compat = ref true (* O(N^2) operations, until we get a xenstore cache, so use a small number here *) let vm_guest_agent_xenstore_quota = ref 128 @@ -207,6 +216,14 @@ let options = , (fun () -> string_of_bool !ca_140252_workaround) , "Workaround for evtchn misalignment for legacy PV tools" ) + ; ( "xen-platform-pci-bar-uc" + , Arg.Bool (fun x -> xen_platform_pci_bar_uc := x) + , (fun () -> string_of_bool !xen_platform_pci_bar_uc) + , "Controls whether, when the VM starts in HVM mode, the Xen PCI MMIO used \ + by grant tables is mapped as Uncached (UC, the default) or WriteBack \ + (WB, the workaround). WB mapping could improve performance of devices \ + using grant tables. This is useful on AMD platform only." + ) ; ( "additional-ballooning-timeout" , Arg.Set_float additional_ballooning_timeout , (fun () -> string_of_float !additional_ballooning_timeout) @@ -300,29 +317,74 @@ let json_path () = path () ^ ".json" let rpc_fn call = (* Upgrade import_metadata API call *) - let call' = + let call', call_name, span_parent = match (call.Rpc.name, call.Rpc.params) with - | "VM.import_metadata", [debug_info; metadata] -> + | ("VM.import_metadata" as call_name), [Rpc.String debug_info; metadata] -> debug "Upgrading VM.import_metadata" ; - Rpc. - { - name= "VM.import_metadata" - ; params= - [Rpc.Dict [("debug_info", debug_info); ("metadata", metadata)]] - ; is_notification= false - } - | "query", [debug_info; unit_p] -> + let span_parent = + let di = debug_info |> Debug_info.of_string in + di.tracing + in + ( Rpc. + { + name= "VM.import_metadata" + ; params= + [ + Rpc.Dict + [ + ("debug_info", Rpc.String debug_info) + ; ("metadata", metadata) + ] + ] + ; is_notification= false + } + , call_name + , span_parent + ) + | ("query" as call_name), [Rpc.String debug_info; unit_p] -> debug "Upgrading query" ; - Rpc. - { - name= "query" - ; params= [Rpc.Dict [("debug_info", debug_info); ("unit", unit_p)]] - ; is_notification= false - } - | _ -> - call + let span_parent = + let di = debug_info |> Debug_info.of_string in + di.tracing + in + ( Rpc. + { + name= "query" + ; params= + [ + Rpc.Dict + [("debug_info", Rpc.String debug_info); ("unit", unit_p)] + ] + ; is_notification= false + } + , call_name + , span_parent + ) + | call_name, [Rpc.Dict kv_list] -> + let span_parent = + kv_list + |> List.find_map (function + | "debug_info", Rpc.String debug_info -> + let di = debug_info |> Debug_info.of_string in + di.tracing + | _ -> + None + ) + in + (call, call_name, span_parent) + | call_name, _ -> + (call, call_name, None) in - Idl.Exn.server Xenops_server.Server.implementation call' + Tracing.with_tracing + ~attributes: + [ + ("messaging.operation.name", "process") + ; ("messaging.system", "message-switch") + ; ("messaging.destination.name", !Xenops_interface.queue_name) + ] + ~span_kind:Tracing.SpanKind.Consumer ~parent:span_parent + ~name:("process" ^ " " ^ call_name) + @@ fun _ -> Idl.Exn.server Xenops_server.Server.implementation call' let handle_received_fd this_connection = let msg_size = 16384 in @@ -359,7 +421,9 @@ let handle_received_fd this_connection = in let do_receive fn = let context = {Xenops_server.transferred_fd= Some received_fd} in - let uri = Uri.of_string req.Xenops_migrate.Forwarded_http_request.uri in + let uri = + Uri.of_string req.Xenops_migrate.Forwarded_http_request.path + in let traceparent = List.assoc_opt "traceparent" req.Xenops_migrate.Forwarded_http_request.additional_headers @@ -367,7 +431,7 @@ let handle_received_fd this_connection = fn uri req.Xenops_migrate.Forwarded_http_request.cookie traceparent this_connection context in - let uri = req.Xenops_migrate.Forwarded_http_request.uri in + let uri = req.Xenops_migrate.Forwarded_http_request.path in if has_prefix uri memory_prefix then do_receive Xenops_server.VM.receive_memory else if has_prefix uri migrate_vgpu_prefix then diff --git a/ocaml/xenopsd/pvs/dune b/ocaml/xenopsd/pvs/dune index bbd88cbb77..1e4d25e713 100644 --- a/ocaml/xenopsd/pvs/dune +++ b/ocaml/xenopsd/pvs/dune @@ -1,6 +1,6 @@ (executable (name pvs_proxy_setup) - (libraries ezxenstore.core bos xapi-consts.xapi_version xapi-idl cmdliner log rresult) + (libraries ezxenstore.core bos xapi-consts.xapi_version xapi-idl cmdliner log rresult unix) ) (install diff --git a/ocaml/xenopsd/scripts/qemu-wrapper b/ocaml/xenopsd/scripts/qemu-wrapper index c8acefbd3f..b1d811e712 100644 --- a/ocaml/xenopsd/scripts/qemu-wrapper +++ b/ocaml/xenopsd/scripts/qemu-wrapper @@ -102,7 +102,15 @@ def prepare_exec(): g = open("/sys/fs/cgroup/cpu/%s/cgroup.procs" % cgroup_slice, 'w') except FileNotFoundError: # cgroup-v2 path: - g = open("/sys/fs/cgroup/%s/cgroup.procs" % cgroup_slice, 'w') + # Note cgroups v2 "no internal processes" rule + # if cgroup.subtree_control is not empty, and we attach a pid + # into cgroup.procs, kernel would return EBUSY + cgroup_slice_dir = os.path.join("/sys/fs/cgroup", cgroup_slice) + qemu_dm_dir = os.path.join(cgroup_slice_dir, "qemu-dm") + if not os.path.exists(qemu_dm_dir): + os.mkdir(qemu_dm_dir) + procs_file = os.path.join(qemu_dm_dir, "cgroup.procs") + g = open(procs_file, 'w') g.write(str(os.getpid())) g.close() except IOError as e: diff --git a/ocaml/xenopsd/suspend_image_viewer/dune b/ocaml/xenopsd/suspend_image_viewer/dune index 706b58bf3f..e4d3457348 100644 --- a/ocaml/xenopsd/suspend_image_viewer/dune +++ b/ocaml/xenopsd/suspend_image_viewer/dune @@ -7,6 +7,7 @@ forkexec result uuid + unix xapi-consts.xapi_version xapi-idl xapi-log diff --git a/ocaml/xenopsd/test/dune b/ocaml/xenopsd/test/dune index 986000138a..4842184ea9 100644 --- a/ocaml/xenopsd/test/dune +++ b/ocaml/xenopsd/test/dune @@ -8,6 +8,7 @@ result rpclib.core rpclib.json + unix xapi-idl xapi-idl.xen.interface xapi-idl.xen.interface.types diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index f7b11e18d2..73f136feca 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -45,6 +45,8 @@ let internal_error fmt = ) fmt +let ( // ) = Filename.concat + (** Definition of available qemu profiles, used by the qemu backend implementations *) module Profile = struct @@ -166,7 +168,7 @@ module Generic = struct let private_data_path = Device_common.get_private_data_path_of_device device in - let key = private_data_path ^ "/" ^ x in + let key = private_data_path // x in try xs.Xs.read key with e -> error "read %s: Noent" key ; raise e let safe_rm ~xs path = @@ -194,7 +196,7 @@ module Generic = struct let can_surprise_remove ~xs (x : device) = (* "(info key in xenstore) && 2" tells us whether a vbd can be surprised removed *) - let key = backend_path_of_device ~xs x ^ "/info" in + let key = backend_path_of_device ~xs x // "info" in try let info = Int64.of_string (xs.Xs.read key) in Int64.logand info 2L <> 0L @@ -211,9 +213,9 @@ module Generic = struct (** When hot-unplugging a device we ask nicely *) let clean_shutdown_async ~xs (x : device) = let backend_path = backend_path_of_device ~xs x in - let state_path = backend_path ^ "/state" in + let state_path = backend_path // "state" in Xs.transaction xs (fun t -> - let online_path = backend_path ^ "/online" in + let online_path = backend_path // "online" in debug "xenstore-write %s = 0" online_path ; t.Xst.write online_path "0" ; let state = @@ -236,13 +238,13 @@ module Generic = struct Watch.map (fun () -> "") (Watch.value_to_become - (frontend_rw_path_of_device ~xs x ^ "/state") + (frontend_rw_path_of_device ~xs x // "state") (Xenbus_utils.string_of Xenbus_utils.Closed) ) let backend_closed ~xs (x : device) = Watch.value_to_become - (backend_path_of_device ~xs x ^ "/state") + (backend_path_of_device ~xs x // "state") (Xenbus_utils.string_of Xenbus_utils.Closed) let is_backend backend_type path = @@ -287,7 +289,7 @@ module Generic = struct in let frontend_gone = ( () - , frontend_rw_path_of_device ~xs x ^ "/state" |> Watch.key_to_disappear + , frontend_rw_path_of_device ~xs x // "state" |> Watch.key_to_disappear ) in let unplugged_watch = ((), unplug_watch ~xs x) in @@ -322,7 +324,7 @@ module Generic = struct let hard_shutdown_request ~xs (x : device) = debug "Device.Generic.hard_shutdown_request %s" (string_of_device x) ; let backend_path = backend_path_of_device ~xs x in - let online_path = backend_path ^ "/online" in + let online_path = backend_path // "online" in debug "xenstore-write %s = 0" online_path ; xs.Xs.write online_path "0" ; debug "Device.Generic.hard_shutdown about to blow away frontend" ; @@ -460,7 +462,7 @@ module Vbd_Common = struct debug "Device.Vbd.request_shutdown %s %s" (string_of_device x) request ; let backend_path = backend_path_of_device ~xs x in let request_path = backend_shutdown_request_path_of_device ~xs x in - let online_path = backend_path ^ "/online" in + let online_path = backend_path // "online" in (* Prevent spurious errors appearing by not writing online=0 if force *) if not force then ( debug "xenstore-write %s = 0" online_path ; @@ -759,7 +761,7 @@ module Vbd_Common = struct let qemu_media_change ~xs device _type params = let backend_path = backend_path_of_device ~xs device in - let params_path = backend_path ^ "/params" in + let params_path = backend_path // "params" in (* unfortunately qemu filter the request if on the same string it has, so we trick it by having a different string, but the same path, adding a spurious '/' character at the beggining of the string. *) @@ -775,7 +777,7 @@ module Vbd_Common = struct debug "Media changed: params = %s" pathtowrite let media_is_ejected ~xs device = - let path = backend_path_of_device ~xs device ^ "/params" in + let path = backend_path_of_device ~xs device // "params" in try xs.Xs.read path = "" with _ -> raise Device_not_found end @@ -872,7 +874,7 @@ module Vif = struct @ front_mtu in let extra_private_keys = - List.map (fun (k, v) -> ("other-config/" ^ k, v)) other_config + List.map (fun (k, v) -> ("other-config" // k, v)) other_config @ extra_private_keys in (* Add the rest of the important configuration to the private bit of @@ -941,7 +943,7 @@ module Vif = struct let move ~xs (x : device) bridge = let xs_bridge_path = - Device_common.get_private_data_path_of_device x ^ "/bridge" + Device_common.get_private_data_path_of_device x // "bridge" in xs.Xs.write xs_bridge_path bridge ; Hotplug.run_hotplug_script x ["move"; "type_if=vif"] ; @@ -1104,6 +1106,8 @@ module PCI = struct (* same as libxl_internal: PROC_PCI_NUM_RESOURCES *) let _proc_pci_num_resources = 7 + let _proc_pci_rom_resource = 6 + (* same as libxl_internal: PCI_BAR_IO *) let _pci_bar_io = 0x01n @@ -1111,6 +1115,16 @@ module PCI = struct let _xen_domctl_dev_rdm_relaxed = 1 + let sysfs_devices = "/sys/bus/pci/devices" + + let sysfs_drivers = "/sys/bus/pci/drivers" + + let sysfs_i915 = sysfs_drivers // "i915" + + let sysfs_nvidia = sysfs_drivers // "nvidia" + + let sysfs_pciback = sysfs_drivers // "pciback" + (* XXX: we don't want to use the 'xl' command here because the "interface" isn't considered as stable as the C API *) let xl_pci cmd pcidevs domid = @@ -1162,7 +1176,7 @@ module PCI = struct List.map (fun x -> ( device_number_of_string x - , Xenops_interface.Pci.address_of_string (xs.Xs.read (path ^ "/" ^ x)) + , Xenops_interface.Pci.address_of_string (xs.Xs.read (path // x)) ) ) all @@ -1170,7 +1184,7 @@ module PCI = struct (* Sort into the order the devices were plugged *) List.sort (fun a b -> compare (fst a) (fst b)) pairs - let encode_bdf pci = + let encode_sbdf pci = (pci.Xenops_interface.Pci.domain lsl 16) lor ((pci.bus land 0xff) lsl 8) lor ((pci.dev land 0x1f) lsl 3) @@ -1178,16 +1192,16 @@ module PCI = struct let _quarantine pci quarantine = if !Xenopsd.pci_quarantine then - let pci_bdf = encode_bdf pci in + let pci_sbdf = encode_sbdf pci in let domid = Xenctrlext.domid_quarantine () in let xcext = Xenctrlext.get_handle () in try match quarantine with | true -> - Xenctrlext.assign_device xcext domid pci_bdf 0 ; + Xenctrlext.assign_device xcext domid pci_sbdf 0 ; true | false -> - Xenctrlext.deassign_device xcext domid pci_bdf ; + Xenctrlext.deassign_device xcext domid pci_sbdf ; true with | Xenctrlext.Unix_error (Unix.ESRCH, _) -> @@ -1205,18 +1219,18 @@ module PCI = struct let _pci_add ~xc ~xs ~hvm domid {host; guest= _, guest_addr; qmp_add} = let open Xenops_interface.Pci in - let sysfs_pci_dev = "/sys/bus/pci/devices/" in + let sysfs_pci_dev = sysfs_devices // string_of_address host in let devfn = match guest_addr with None -> None | Some g -> Some (g.dev, g.fn) in let irq = - sysfs_pci_dev ^ Pci.string_of_address host ^ "/irq" + sysfs_pci_dev // "irq" |> Unixext.string_of_file |> String.trim |> int_of_string in let addresses = - sysfs_pci_dev ^ string_of_address host ^ "/resource" + sysfs_pci_dev // "resource" |> Unixext.string_of_file |> String.split_on_char '\n' in @@ -1224,7 +1238,7 @@ module PCI = struct if i < _proc_pci_num_resources then Scanf.sscanf addr "0x%nx 0x%nx 0x%nx" @@ fun scan_start scan_end scan_flags -> - if scan_start <> 0n then + if scan_start <> 0n then ( let scan_size = Nativeint.(sub scan_end scan_start |> succ) in if Nativeint.(logand scan_flags _pci_bar_io > 0n) then Xenctrl.domain_ioport_permission xc domid @@ -1238,11 +1252,49 @@ module PCI = struct shift_right_logical (add _page_size scan_size |> pred) 12 ) in + (* Linux disables the ROM BARs if not used and by default does + not set the start address. + Force it to set the address using "rom" file. + This method works also with lockdown mode enabled. *) + let enable_rom start = + (* read current configured ROM address to check if enabled *) + let config_fn = sysfs_pci_dev // "config" in + let out = Bytes.make 4 '\x00' in + let current_addr = + Unixext.with_file config_fn [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 + (fun fd -> + Unix.(lseek fd 0x30 SEEK_SET) |> ignore ; + (* this is a virtual file that control PCI configuration, + it will either fail or return 4 *) + Unix.(read fd out 0 4) |> ignore ; + Nativeint.( + logand (of_int32 (Bytes.get_int32_le out 0)) 0xfffff800n + ) + ) + in + if current_addr <> start then ( + (* to enable output "1" on "rom" file and try to read it *) + let rom_fn = sysfs_pci_dev // "rom" in + Unixext.with_file rom_fn [Unix.O_WRONLY; Unix.O_CLOEXEC] 0 + (fun fd -> + Unix.(single_write fd (Bytes.of_string "1\n") 0 2) |> ignore + ) ; + Unixext.with_file rom_fn [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 + (fun fd -> + (* ignore any error, the ROM could be not correct, + just trying to read does the trick *) + try Unix.(read fd out 0 4) |> ignore with _ -> () + ) + ) + in + if i = _proc_pci_rom_resource then + enable_rom scan_start ; Xenctrl.domain_iomem_permission xc domid scan_start scan_size true + ) in let xcext = Xenctrlext.get_handle () in ignore (quarantine host) ; - Xenctrlext.assign_device xcext domid (encode_bdf host) + Xenctrlext.assign_device xcext domid (encode_sbdf host) _xen_domctl_dev_rdm_relaxed ; List.iteri apply_io_permission addresses ; ( if irq > 0 then @@ -1351,23 +1403,11 @@ module PCI = struct | driver -> Unsupported driver - let sysfs_devices = "/sys/bus/pci/devices" - - let sysfs_drivers = "/sys/bus/pci/drivers" - - let sysfs_i915 = Filename.concat sysfs_drivers "i915" - - let sysfs_nvidia = Filename.concat sysfs_drivers "nvidia" - - let sysfs_pciback = Filename.concat sysfs_drivers "pciback" - - let ( // ) = Filename.concat - let get_driver devstr = try - let sysfs_device = Filename.concat sysfs_devices devstr in + let sysfs_device = sysfs_devices // devstr in Some - (Filename.concat sysfs_device "driver" + (sysfs_device // "driver" |> Unix.readlink |> Filename.basename |> driver_of_string @@ -1376,8 +1416,8 @@ module PCI = struct let bind_to_pciback devstr = debug "pci: binding device %s to pciback" devstr ; - let new_slot = Filename.concat sysfs_pciback "new_slot" in - let bind = Filename.concat sysfs_pciback "bind" in + let new_slot = sysfs_pciback // "new_slot" in + let bind = sysfs_pciback // "bind" in write_string_to_file new_slot devstr ; write_string_to_file bind devstr @@ -1408,7 +1448,7 @@ module PCI = struct (Forkhelpers.execute_command_get_output !Resources.modprobe ["i915"]) ; match get_driver devstr with | None -> - write_string_to_file (Filename.concat sysfs_i915 "bind") devstr + write_string_to_file (sysfs_i915 // "bind") devstr | Some (Supported I915) -> () | Some drv -> @@ -1418,8 +1458,8 @@ module PCI = struct let unbind devstr driver = let driverstr = string_of_driver driver in debug "pci: unbinding device %s from %s" devstr driverstr ; - let sysfs_driver = Filename.concat sysfs_drivers driverstr in - let unbind = Filename.concat sysfs_driver "unbind" in + let sysfs_driver = sysfs_drivers // driverstr in + let unbind = sysfs_driver // "unbind" in write_string_to_file unbind devstr let unbind_from_i915 devstr = @@ -1486,7 +1526,7 @@ module PCI = struct let bind_to_nvidia devstr = debug "pci: binding device %s to nvidia" devstr ; - let bind = Filename.concat sysfs_nvidia "bind" in + let bind = sysfs_nvidia // "bind" in write_string_to_file bind devstr let unbind_from_nvidia devstr = @@ -1498,8 +1538,8 @@ module PCI = struct | [] -> failwith (Printf.sprintf "Couldn't find GPU with device ID %s" devstr) | gpu :: rest -> - let gpu_path = Filename.concat procfs_nvidia gpu in - let gpu_info_file = Filename.concat gpu_path "information" in + let gpu_path = procfs_nvidia // gpu in + let gpu_info_file = gpu_path // "information" in let gpu_info = Unixext.string_of_file gpu_info_file in (* Work around due to PCI ID formatting inconsistency. *) let devstr2 = @@ -1522,9 +1562,7 @@ module PCI = struct Forkhelpers.execute_command_get_output nvidia_smi ["--id=" ^ devstr; "--persistence-mode=0"] in - let unbind_lock_path = - Filename.concat (find_gpu (Array.to_list gpus)) "unbindLock" - in + let unbind_lock_path = find_gpu (Array.to_list gpus) // "unbindLock" in (* Grab the unbind lock. *) write_string_to_file unbind_lock_path "1\n" ; (* Unbind if we grabbed the lock; fail otherwise. *) @@ -1586,12 +1624,12 @@ module PCI = struct let enumerate_devs ~xs (x : device) = let backend_path = backend_path_of_device ~xs x in let num = - try int_of_string (xs.Xs.read (backend_path ^ "/num_devs")) with _ -> 0 + try int_of_string (xs.Xs.read (backend_path // "num_devs")) with _ -> 0 in let devs = Array.make num None in for i = 0 to num do try - let devstr = xs.Xs.read (backend_path ^ "/dev-" ^ string_of_int i) in + let devstr = xs.Xs.read (backend_path // ("dev-" ^ string_of_int i)) in let dev = Xenops_interface.Pci.address_of_string devstr in devs.(i) <- Some dev with _ -> () @@ -1655,7 +1693,7 @@ module Vfs = struct let perms = Xs_protocol.ACL.{owner= domid; other= NONE; acl= []} in let request_path = Printf.sprintf "%s/%d" request_path 0 in t.Xst.mkdirperms request_path perms ; - t.Xst.write (request_path ^ "/frontend") frontend_path + t.Xst.write (request_path // "frontend") frontend_path ) ; () @@ -2054,16 +2092,16 @@ module Dm_Common = struct ?param cmd = let cmdpath = device_model_path ~qemu_domid domid in Xs.transaction xs (fun t -> - t.Xst.write (cmdpath ^ "/command") cmd ; + t.Xst.write (cmdpath // "command") cmd ; match param with | None -> () | Some param -> - t.Xst.write (cmdpath ^ "/parameter") param + t.Xst.write (cmdpath // "parameter") param ) ; match wait_for with | Some state -> - let pw = cmdpath ^ "/state" in + let pw = cmdpath // "state" in (* MTC: The default timeout for this operation was 20mins, which is way too long for our software to recover successfully. Talk to Citrix about this *) @@ -2196,7 +2234,7 @@ module Dm_Common = struct xs.Xs.directory root |> List.concat_map (fun domid -> let path = Printf.sprintf "%s/%s/device/vgpu" root domid in - try List.map (fun x -> path ^ "/" ^ x) (xs.Xs.directory path) + try List.map (fun x -> path // x) (xs.Xs.directory path) with Xs_protocol.Enoent _ -> [] ) |> List.exists (fun vgpu -> diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index 19f28e4198..4af94d7b96 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -153,7 +153,7 @@ type build_info = { ; kernel: string (** in hvm case, point to hvmloader *) ; vcpus: int (** vcpus max *) ; priv: builder_spec_info - ; has_hard_affinity: bool [@default false] + ; hard_affinity: int list list [@default []] } [@@deriving rpcty] @@ -269,7 +269,8 @@ let wait_xen_free_mem ~xc ?(maximum_wait_time_seconds = 64) required_memory_kib in wait 0 -let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept = +let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept + num_of_vbds num_of_vifs = let open Xenctrl in let host_info = Xenctrl.physinfo xc in @@ -385,12 +386,80 @@ let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept = ; max_evtchn_port= -1 ; max_grant_frames= ( try int_of_string (List.assoc "max_grant_frames" vm_info.platformdata) - with _ -> 64 + with _ -> + let max_per_vif = 8 in + (* 1 VIF takes up (256 rx entries + 256 tx entries) * 8 queues max + * 8 bytes per grant table entry / 4096 bytes size of frame *) + let reasonable_per_vbd = 1 in + (* (1 ring (itself taking up one granted page) + 1 ring * + 32 requests * 11 grant refs contained in each * 8 bytes ) / + 4096 bytes size of frame = 0.6875, rounded up *) + let frames_number = + max 64 + ((max_per_vif * (num_of_vifs + 1)) + + (reasonable_per_vbd * (num_of_vbds + 1)) + ) + in + debug "estimated max_grant_frames = %d" frames_number ; + frames_number + (* max_per_vif * (num_of_vifs + 1 hotplugged future one) + + max_per_vbd * (num_of_vbds + 1 hotplugged future one) *) + + (* NOTE: While the VIF calculation is precise, the VBD one is a + very rough approximation of a reasonable value of + RING_SIZE * MAX_SEGMENTS_PER_REQUEST + PAGES_FOR_RING_ITSELF + The following points should allow for a rough understanding + of the scale of the problem of better estimation: + + 1) The blkfront driver can consume different numbers of grant + pages depending on the features advertised by the back driver + (and negotiated with it). These features can differ per VBD, and + right now aren't even known at the time of domain creation. + These include: + 1.1) indirect segments - these contain + BLKIF_MAX_INDIRECT_PAGES_PER_REQUEST grants at most, and each + of these frames contains GRANTS_PER_INDIRECT_FRAME grants in + turn (stored in blkif_request_segment). + In practice, this means a catastrophic explosion - we should + not really aim to detect if indirect requests feature is on, + but turn it off to get reasonable estimates. + 1.2) persistent grants - these are an optimization, so + shouldn't really change the calculations, worst case is none + of the grants are persistent. + 1.3) multi-page rings - these change the RING_SIZE, but not in + a trivial manner (see ring-page-order) + 1.4) multi-queue - these change the number of rings, adding + another multiplier. + 2) The "8 bytes" multiplier for a grant table entry only applies + to grants_v1. v2 grants take up 16 bytes per entry. And it's + impossible to detect this feature at the moment. + 3) A dynamically-sized grant table itself could be a solution? + Used to exist before, caused a lot of XSAs, hard to get right. + 4) Drivers might need to be more explicitly limited in how many + pages they can consume + 5) VBD backdriver's features should be managed by XAPI on the + object itself and (their max bound) known at the time of domain + creation. + + So for this estimate, there is only 1 ring which is 1 page, with + 32 entries, each entry (request) can have up to 11 pages + (excluding indirect pages and other complications). + + SEE: xen-blkfront.c, blkif.h, and the backdriver to understand + the process of negotiation (visible in xenstore, in kernel + module parameters in the sys filesystem afterwards) + *) ) ; max_maptrack_frames= ( try int_of_string (List.assoc "max_maptrack_frames" vm_info.platformdata) - with _ -> 1024 + with _ -> + 0 + (* This should be >0 only for driver domains (Dom0 startup is not + handled by the toolstack), which currently do not exist. + To support these in the future, xenopsd would need to check what + type of domain is being started. + *) ) ; max_grant_version= (if List.mem CAP_Gnttab_v2 host_info.capabilities then 2 else 1) @@ -501,6 +570,9 @@ let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept = xs.Xs.writev (dom_path ^ "/bios-strings") vm_info.bios_strings ; if vm_info.is_uefi then xs.Xs.write (dom_path ^ "/hvmloader/bios") "ovmf" ; + xs.Xs.write + (dom_path ^ "/hvmloader/pci/xen-platform-pci-bar-uc") + (if !Xenopsd.xen_platform_pci_bar_uc then "1" else "0") ; (* If a toolstack sees a domain which it should own in this state then the domain is not completely setup and should be shutdown. *) xs.Xs.write (dom_path ^ "/action-request") "poweroff" ; @@ -857,7 +929,13 @@ let numa_init () = ) mem -let numa_placement domid ~vcpus ~memory = +let set_affinity = function + | Xenops_server.Hard -> + Xenctrlext.vcpu_setaffinity_hard + | Xenops_server.Soft -> + Xenctrlext.vcpu_setaffinity_soft + +let numa_placement domid ~vcpus ~memory affinity = let open Xenctrlext in let open Topology in with_lock numa_mutex (fun () -> @@ -880,7 +958,7 @@ let numa_placement domid ~vcpus ~memory = Array.map2 NUMAResource.min_memory (Array.of_list nodes) a in numa_resources := Some nodea ; - let _ = + let memory_plan = match Softaffinity.plan ~vm host nodea with | None -> D.debug "NUMA-aware placement failed for domid %d" domid ; @@ -888,17 +966,41 @@ let numa_placement domid ~vcpus ~memory = | Some (cpu_affinity, mem_plan) -> let cpus = CPUSet.to_mask cpu_affinity in for i = 0 to vcpus - 1 do - Xenctrlext.vcpu_setaffinity_soft xcext domid i cpus + set_affinity affinity xcext domid i cpus done ; mem_plan in - (* Neither xenguest nor emu-manager allow allocating pages to a single - NUMA node, don't return any NUMA in any case. Claiming the memory - would be done here, but it conflicts with DMC. *) - None + (* Xen only allows a single node when using memory claims, or none at all. *) + let* numa_node, node = + match memory_plan with + | [Node node] -> + Some (Xenctrlext.NumaNode.from node, node) + | [] | _ :: _ :: _ -> + D.debug + "%s: domain %d can't fit a single NUMA node, falling back to \ + default behaviour" + __FUNCTION__ domid ; + None + in + let nr_pages = Int64.div memory 4096L |> Int64.to_int in + try + Xenctrlext.domain_claim_pages xcext domid ~numa_node nr_pages ; + Some (node, memory) + with + | Xenctrlext.Not_available -> + (* Xen does not provide the interface to claim pages from a single NUMA + node, ignore the error and continue. *) + None + | Xenctrlext.Unix_error (errno, _) -> + D.info + "%s: unable to claim enough memory, domain %d won't be hosted in a \ + single NUMA node. (error %s)" + __FUNCTION__ domid + Unix.(error_message errno) ; + None ) -let build_pre ~xc ~xs ~vcpus ~memory ~has_hard_affinity domid = +let build_pre ~xc ~xs ~vcpus ~memory ~hard_affinity domid = let open Memory in let uuid = get_uuid ~xc domid in debug "VM = %s; domid = %d; waiting for %Ld MiB of free host memory" @@ -950,18 +1052,46 @@ let build_pre ~xc ~xs ~vcpus ~memory ~has_hard_affinity domid = log_reraise (Printf.sprintf "shadow_allocation_set %d MiB" shadow_mib) (fun () -> Xenctrl.shadow_allocation_set xc domid shadow_mib ) ; + let apply_hard_vcpu_map () = + let xcext = Xenctrlext.get_handle () in + let pcpus = Xenctrlext.get_max_nr_cpus xcext in + let bitmap cpus : bool array = + (* convert a mask into a boolean array, one element per pCPU *) + let cpus = List.filter (fun x -> x >= 0 && x < pcpus) cpus in + let result = Array.init pcpus (fun _ -> false) in + List.iter (fun cpu -> result.(cpu) <- true) cpus ; + result + in + ( match hard_affinity with + | [] -> + [] + | m :: ms -> + (* Treat the first as the template for the rest *) + let all_vcpus = List.init vcpus Fun.id in + let defaults = List.map (fun _ -> m) all_vcpus in + Xapi_stdext_std.Listext.List.take vcpus ((m :: ms) @ defaults) + ) + |> List.iteri (fun vcpu mask -> + Xenctrlext.vcpu_setaffinity_hard xcext domid vcpu (bitmap mask) + ) + in + apply_hard_vcpu_map () ; let node_placement = match !Xenops_server.numa_placement with | Any -> None - | Best_effort -> + | (Best_effort | Best_effort_hard) as pin -> log_reraise (Printf.sprintf "NUMA placement") (fun () -> - if has_hard_affinity then ( + if hard_affinity <> [] then ( D.debug "VM has hard affinity set, skipping NUMA optimization" ; None ) else + let affinity = + Xenops_server.affinity_of_numa_affinity_policy pin + in numa_placement domid ~vcpus ~memory:(Int64.mul memory.xen_max_mib 1048576L) + affinity |> Option.map fst ) in @@ -1084,8 +1214,8 @@ let correct_shadow_allocation xc domid uuid shadow_mib = ) (* puts value in store after the domain build succeed *) -let build_post ~xc ~xs ~vcpus:_ ~static_max_mib ~target_mib domid domain_type - store_mfn store_port ents vments = +let build_post ~xc ~xs ~static_max_mib ~target_mib domid domain_type store_mfn + store_port ents vments = let uuid = get_uuid ~xc domid in let dom_path = xs.Xs.getdomainpath domid in (* Unit conversion. *) @@ -1129,7 +1259,7 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid let target_kib = info.memory_target in let vcpus = info.vcpus in let kernel = info.kernel in - let has_hard_affinity = info.has_hard_affinity in + let hard_affinity = info.hard_affinity in let force_arg = if force then ["--force"] else [] in assert_file_is_readable kernel ; (* Convert memory configuration values into the correct units. *) @@ -1148,7 +1278,7 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid in maybe_ca_140252_workaround ~xc ~vcpus domid ; let store_port, console_port, numa_placement = - build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity domid + build_pre ~xc ~xs ~memory ~vcpus ~hard_affinity domid in let store_mfn, console_mfn = let args = @@ -1176,7 +1306,7 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid in Option.iter assert_file_is_readable pvinfo.ramdisk ; let store_port, console_port, numa_placement = - build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity domid + build_pre ~xc ~xs ~memory ~vcpus ~hard_affinity domid in let store_mfn, console_mfn = let args = @@ -1199,7 +1329,7 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid in maybe_ca_140252_workaround ~xc ~vcpus domid ; let store_port, console_port, numa_placement = - build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity domid + build_pre ~xc ~xs ~memory ~vcpus ~hard_affinity domid in let store_mfn, console_mfn = let args = @@ -1220,8 +1350,8 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid ) in let local_stuff = console_keys console_port console_mfn in - build_post ~xc ~xs ~vcpus ~target_mib ~static_max_mib domid domain_type - store_mfn store_port local_stuff vm_stuff + build_post ~xc ~xs ~target_mib ~static_max_mib domid domain_type store_mfn + store_port local_stuff vm_stuff type suspend_flag = Live | Debug @@ -1322,8 +1452,7 @@ let consume_qemu_record fd limit domid uuid = (fun () -> Unix.close fd2) let restore_common (task : Xenops_task.task_handle) ~xc ~xs - ~(dm : Device.Profile.t) ~domain_type ~store_port ~store_domid:_ - ~console_port ~console_domid:_ ~no_incr_generationid:_ ~vcpus:_ ~extras + ~(dm : Device.Profile.t) ~domain_type ~store_port ~console_port ~extras ~vtpm ~numa_placements manager_path domid main_fd vgpu_fd = let module DD = Debug.Make (struct let name = "mig64" end) in let open DD in @@ -1589,9 +1718,8 @@ let restore_common (task : Xenops_task.task_handle) ~xc ~xs (Uuidx.to_string uuid) domid e ; raise Suspend_image_failure -let restore (task : Xenops_task.task_handle) ~xc ~xs ~dm ~store_domid - ~console_domid ~no_incr_generationid ~timeoffset ~extras info ~manager_path - ~vtpm domid fd vgpu_fd = +let restore (task : Xenops_task.task_handle) ~xc ~xs ~dm ~timeoffset ~extras + info ~manager_path ~vtpm domid fd vgpu_fd = let static_max_kib = info.memory_max in let target_kib = info.memory_target in let vcpus = info.vcpus in @@ -1633,20 +1761,18 @@ let restore (task : Xenops_task.task_handle) ~xc ~xs ~dm ~store_domid (memory, vm_stuff, `pvh) in let store_port, console_port, numa_placements = - build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity:info.has_hard_affinity - domid + build_pre ~xc ~xs ~memory ~vcpus ~hard_affinity:info.hard_affinity domid in let store_mfn, console_mfn = - restore_common task ~xc ~xs ~dm ~domain_type ~store_port ~store_domid - ~console_port ~console_domid ~no_incr_generationid ~vcpus ~extras ~vtpm - ~numa_placements manager_path domid fd vgpu_fd + restore_common task ~xc ~xs ~dm ~domain_type ~store_port ~console_port + ~extras ~vtpm ~numa_placements manager_path domid fd vgpu_fd in let local_stuff = console_keys console_port console_mfn in (* And finish domain's building *) - build_post ~xc ~xs ~vcpus ~target_mib ~static_max_mib domid domain_type - store_mfn store_port local_stuff vm_stuff + build_post ~xc ~xs ~target_mib ~static_max_mib domid domain_type store_mfn + store_port local_stuff vm_stuff -let suspend_emu_manager ~(task : Xenops_task.task_handle) ~xc:_ ~xs ~domain_type +let suspend_emu_manager ~(task : Xenops_task.task_handle) ~xs ~domain_type ~is_uefi ~vtpm ~dm ~manager_path ~domid ~uuid ~main_fd ~vgpu_fd ~flags ~progress_callback ~qemu_domid ~do_suspend_callback = let open Suspend_image in @@ -1858,9 +1984,9 @@ let suspend (task : Xenops_task.task_handle) ~xc ~xs ~domain_type ~is_uefi ~dm write_header main_fd (Xenops, Int64.of_int xenops_rec_len) >>= fun () -> debug "Writing Xenops record contents" ; Io.write main_fd xenops_record ; - suspend_emu_manager ~task ~xc ~xs ~domain_type ~is_uefi ~vtpm ~dm - ~manager_path ~domid ~uuid ~main_fd ~vgpu_fd ~flags ~progress_callback - ~qemu_domid ~do_suspend_callback + suspend_emu_manager ~task ~xs ~domain_type ~is_uefi ~vtpm ~dm ~manager_path + ~domid ~uuid ~main_fd ~vgpu_fd ~flags ~progress_callback ~qemu_domid + ~do_suspend_callback >>= fun () -> ( if is_uefi then write_varstored_record task ~xs domid main_fd >>= fun () -> diff --git a/ocaml/xenopsd/xc/domain.mli b/ocaml/xenopsd/xc/domain.mli index c8f83b0994..40f154561a 100644 --- a/ocaml/xenopsd/xc/domain.mli +++ b/ocaml/xenopsd/xc/domain.mli @@ -133,7 +133,7 @@ type build_info = { ; kernel: string (** image to load. In HVM case, point to hvmloader *) ; vcpus: int (** vcpus max *) ; priv: builder_spec_info - ; has_hard_affinity: bool + ; hard_affinity: int list list (** vcpu -> pcpu map *) } val typ_of_build_info : build_info Rpc.Types.typ @@ -149,6 +149,8 @@ val make : -> [`VM] Uuidx.t -> string option -> bool (* no_sharept *) + -> int (* num_of_vbds *) + -> int (* num_of_vifs *) -> domid (** Create a fresh (empty) domain with a specific UUID, returning the domain ID *) @@ -245,9 +247,6 @@ val restore : -> xc:Xenctrl.handle -> xs:Ezxenstore_core.Xenstore.Xs.xsh -> dm:Device.Profile.t - -> store_domid:int - -> console_domid:int - -> no_incr_generationid:bool -> timeoffset:string -> extras:string list -> build_info diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index 1bf73af404..2c10982df0 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -32,6 +32,7 @@ sexplib0 qmp threads.posix + unix uri uuid uuidm @@ -58,6 +59,7 @@ xapi_xenopsd_c_stubs xapi_xenopsd_xc_c_stubs xenctrl + xenctrl_ext xenstore xenstore_transport.unix ) @@ -73,7 +75,8 @@ (executable (name numa) (modules numa) - (libraries fmt logs logs.fmt mtime mtime.clock threads.posix xenctrl xenopsd_xc) + (libraries fmt logs logs.fmt mtime mtime.clock threads.posix xenctrl + xenctrl_ext xenopsd_xc unix) ) (executable @@ -82,6 +85,7 @@ (modules xenops_xc_main) (libraries ezxenstore.core + unix uuid xapi-idl xapi-idl.xen.interface @@ -89,6 +93,7 @@ xapi-stdext-unix xapi_xenopsd xenctrl + xenctrl_ext xenstore_transport.unix xenopsd_xc ) @@ -101,13 +106,14 @@ (libraries astring cmdliner - ezxenstore.core uuid + unix xapi-idl.memory clock xapi-stdext-unix xenctrl + xenctrl_ext xenopsd_xc xenstore_transport.unix ) @@ -129,6 +135,7 @@ xapi-stdext-unix xapi_xenopsd xenctrl + xenctrl_ext ) ) @@ -140,6 +147,7 @@ cmdliner ezxenstore xenctrl + xenctrl_ext ) ) @@ -155,6 +163,7 @@ xapi-idl.xen.interface xapi_xenopsd xenctrl + xenctrl_ext xenopsd_xc xenstore_transport.unix ) diff --git a/ocaml/xenopsd/xc/xenguestHelper.ml b/ocaml/xenopsd/xc/xenguestHelper.ml index b76fec51c2..06a28d92f3 100644 --- a/ocaml/xenopsd/xc/xenguestHelper.ml +++ b/ocaml/xenopsd/xc/xenguestHelper.ml @@ -200,13 +200,14 @@ let rec non_debug_receive ?(debug_callback = fun s -> debug "%s" s) cnx = (* Dump memory statistics on failure *) let non_debug_receive ?debug_callback cnx = - let debug_memory () = + let debug_memory log_type = Xenctrl.with_intf (fun xc -> let open Memory in let open Int64 in let open Xenctrl in let p = Xenctrl.physinfo xc in - error "Memory F %Ld KiB S %Ld KiB T %Ld MiB" + (match log_type with Syslog.Debug -> debug | _ -> error) + "Memory F %Ld KiB S %Ld KiB T %Ld MiB" (p.free_pages |> of_nativeint |> kib_of_pages) (p.scrub_pages |> of_nativeint |> kib_of_pages) (p.total_pages |> of_nativeint |> mib_of_pages_free) @@ -215,10 +216,18 @@ let non_debug_receive ?debug_callback cnx = try match non_debug_receive ?debug_callback cnx with | Error y as x -> - error "Received: %s" y ; debug_memory () ; x + error "Received: %s" y ; debug_memory Syslog.Err ; x | x -> x - with e -> debug_memory () ; raise e + with + | End_of_file as e -> + Unixext.raise_with_preserved_backtrace e (fun () -> + debug_memory Syslog.Debug + ) + | e -> + Unixext.raise_with_preserved_backtrace e (fun () -> + debug_memory Syslog.Err + ) (** For the simple case where we just want the successful result, return it. If we get an error message (or suspend) then throw an exception. *) diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index 9eae9cb76b..3e7bd2a358 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -25,6 +25,7 @@ module D = Debug.Make (struct let name = service_name end) open D module RRDD = Rrd_client.Client module StringSet = Set.Make (String) +module IntMap = Map.Make (Int) let finally = Xapi_stdext_pervasives.Pervasiveext.finally @@ -187,7 +188,7 @@ module VmExtra = struct ; pv_drivers_detected: bool [@default false] ; xen_platform: (int * int) option (* (device_id, revision) for QEMU *) ; platformdata: (string * string) list [@default []] - ; attached_vdis: (Vbd.id * attached_vdi) list [@default []] + ; attached_vdis: (string * attached_vdi) list [@default []] } [@@deriving rpcty] @@ -989,6 +990,7 @@ module HOST = struct p.nr_cpus / (p.threads_per_core * p.cores_per_socket) in let threads_per_core = p.threads_per_core in + let nr_nodes = Xenctrlext.(get_handle () |> get_nr_nodes) in let features = get_cpu_featureset xc Featureset_host in (* this is Default policy in Xen's terminology, used on boot for new VMs *) let features_pv_host = get_cpu_featureset xc Featureset_pv in @@ -1017,6 +1019,7 @@ module HOST = struct Host.cpu_count ; socket_count ; threads_per_core + ; nr_nodes ; vendor ; speed ; modelname @@ -1164,102 +1167,439 @@ let dm_of ~vm = let vtpm_of ~vm = match vm.Vm.ty with Vm.HVM h -> h.tpm | _ -> None -module VM = struct - open Vm +module Actions = struct + (* CA-76600: the rtc/timeoffset needs to be maintained over a migrate. *) + let store_rtc_timeoffset vm timeoffset = + let _ = + DB.update vm + (Option.map (function {VmExtra.persistent} as extra -> + ( match persistent with + | {VmExtra.ty= Some (Vm.HVM hvm_info); _} -> + let platformdata = + ("timeoffset", timeoffset) + :: List.remove_assoc "timeoffset" persistent.platformdata + in + let persistent = + { + persistent with + VmExtra.ty= Some (Vm.HVM {hvm_info with Vm.timeoffset}) + ; platformdata + } + in + debug "VM = %s; rtc/timeoffset <- %s" vm timeoffset ; + VmExtra.{persistent} + | _ -> + extra + ) + ) + ) + in + () - let will_be_hvm vm = match vm.ty with HVM _ -> true | _ -> false + let xenbus_connected = Xenbus_utils.(int_of Connected) |> string_of_int - let profile_of ~vm = - if will_be_hvm vm then - Some (choose_qemu_dm vm.Xenops_interface.Vm.platformdata) - else - None + let maybe_update_pv_drivers_detected ~xc ~xs domid path = + let vm = get_uuid ~xc domid |> Uuidx.to_string in + Option.iter + (function + | {VmExtra.persistent} -> ( + try + let value = xs.Xs.read path in + let pv_drivers_detected = + match + ( value = xenbus_connected + , persistent.VmExtra.pv_drivers_detected + ) + with + | true, false -> + (* State "connected" (4) means that PV drivers are present for + this device *) + debug "VM = %s; found PV driver evidence on %s (value = %s)" + vm path value ; + true + | false, true -> + (* This device is not connected, while earlier we detected PV + drivers. We conclude that drivers are still present if any + other device is connected. *) + let devices = Device_common.list_frontends ~xs domid in + let found = + (* Return `true` as soon as a device in state 4 is found. *) + List.exists + (fun device -> + try + xs.Xs.read + (Device_common.backend_state_path_of_device ~xs + device + ) + = xenbus_connected + with Xs_protocol.Enoent _ -> false + ) + devices + in + if not found then (* No devices in state "connected" (4) *) + debug "VM = %s; lost PV driver evidence" vm ; + found + | _ -> + (* No change *) + persistent.VmExtra.pv_drivers_detected + in + let updated = + DB.update vm + (Option.map (function {VmExtra.persistent} -> + let persistent = + {persistent with VmExtra.pv_drivers_detected} + in + VmExtra.{persistent} + ) + ) + in + if updated then + Updates.add (Dynamic.Vm vm) internal_updates + with Xs_protocol.Enoent _ -> + warn "Watch event on %s fired but couldn't read from it" path ; + () + (* the path must have disappeared immediately after the watch fired. + Let's treat this as if we never saw it. *) + ) + ) + (DB.read vm) - let dm_of ~vm = dm_of ~vm:vm.Vm.id + let interesting_paths_for_domain domid uuid = + let open Printf in + [ + sprintf "/local/domain/%d/attr" domid + ; sprintf "/local/domain/%d/data/ts" domid + ; sprintf "/local/domain/%d/data/service" domid + ; sprintf "/local/domain/%d/data/pvs_target" domid + ; sprintf "/local/domain/%d/memory/target" domid + ; sprintf "/local/domain/%d/memory/uncooperative" domid + ; sprintf "/local/domain/%d/console/vnc-port" domid + ; sprintf "/local/domain/%d/console/tc-port" domid + ; Service.Qemu.pidxenstore_path_signal domid + ; sprintf "/local/domain/%d/control" domid + ; sprintf "/local/domain/%d/device" domid + ; sprintf "/local/domain/%d/rrd" domid + ; sprintf "/local/domain/%d/vm-data" domid + ; sprintf "/local/domain/%d/feature" domid + ; sprintf "/vm/%s/rtc/timeoffset" uuid + ; sprintf "/local/domain/%d/xenserver/attr" domid + ] - let compute_overhead persistent vcpu_max memory_static_max shadow_multiplier = - let open VmExtra in - let static_max_mib = Memory.mib_of_bytes_used memory_static_max in - let model = - match persistent.ty with - | Some (PV _) -> - Memory.Linux.overhead_mib - | Some (PVinPVH _) -> - Memory.PVinPVH.overhead_mib - | Some (HVM _ | PVH _) -> - Memory.HVM.overhead_mib - | None -> - failwith - "cannot compute memory overhead: unable to determine domain type" + let watch_token domid = Printf.sprintf "xenopsd-xc:domain-%d" domid + + let watches_of_device dev = + let interesting_backend_keys = + [ + "kthread-pid" + ; "tapdisk-pid" + ; "shutdown-done" + ; "hotplug-status" + ; "params" + ; "state" + ] in - model static_max_mib vcpu_max shadow_multiplier |> Memory.bytes_of_mib + let open Device_common in + let be = dev.backend.domid in + let fe = dev.frontend.domid in + let kind = string_of_kind dev.backend.kind in + let devid = dev.frontend.devid in + List.map + (fun k -> + Printf.sprintf "/local/domain/%d/backend/%s/%d/%d/%s" be kind fe devid k + ) + interesting_backend_keys - let shutdown_reason = function - | Reboot -> - Domain.Reboot - | PowerOff -> - Domain.PowerOff - | Suspend -> - Domain.Suspend - | Halt -> - Domain.Halt - | S3Suspend -> - Domain.S3Suspend + let unmanaged_domain domid id = domid > 0 && not (DB.exists id) - (* We compute our initial target at memory reservation time, done before the - domain is created. We consume this information later when the domain is - built. *) - let set_initial_target ~xs domid initial_target = - xs.Xs.write - (Printf.sprintf "/local/domain/%d/memory/initial-target" domid) - (Int64.to_string initial_target) + let found_running_domain _domid id = + Updates.add (Dynamic.Vm id) internal_updates - let get_initial_target ~xs domid = - Int64.of_string - (xs.Xs.read - (Printf.sprintf "/local/domain/%d/memory/initial-target" domid) - ) + let device_watches = ref IntMap.empty - let domain_type_path domid = - Printf.sprintf "/local/domain/%d/domain-type" domid + let domain_appeared _xc _xs domid = + device_watches := IntMap.add domid [] !device_watches - let set_domain_type ~xs domid vm = - let domain_type = - match vm.ty with - | HVM _ -> - "hvm" - | PV _ -> - "pv" - | PVinPVH _ -> - "pv-in-pvh" - | PVH _ -> - "pvh" - in - xs.Xs.write (domain_type_path domid) domain_type + let domain_disappeared _xc xs domid = + let token = watch_token domid in + List.iter + (fun d -> + List.iter (Xenstore_watch.unwatch ~xs token) (watches_of_device d) + ) + (try IntMap.find domid !device_watches with Not_found -> []) ; + device_watches := IntMap.remove domid !device_watches ; + (* Anyone blocked on a domain/device operation which won't happen because + the domain just shutdown should be cancelled here. *) + debug "Cancelling watches for: domid %d" domid ; + Cancel_utils.on_shutdown ~xs domid ; + (* Finally, discard any device caching for the domid destroyed *) + DeviceCache.discard device_cache domid - let get_domain_type ~xs di = - try - match xs.Xs.read (domain_type_path di.Xenctrl.domid) with - | "hvm" -> - Domain_HVM - | "pv" -> - Domain_PV - | "pv-in-pvh" -> - Domain_PVinPVH - | "pvh" -> - Domain_PVH - | x -> - warn "domid = %d; Undefined domain type found (%s)" di.Xenctrl.domid x ; - Domain_undefined - with Xs_protocol.Enoent _ -> - (* Fallback for the upgrade case, where the new xs key may not exist *) - if di.Xenctrl.hvm_guest then - Domain_HVM - else - Domain_PV + let qemu_disappeared di xc xs = + match !Xenopsd.action_after_qemu_crash with + | None -> + () + | Some action -> ( + debug "action-after-qemu-crash=%s" action ; + match action with + | "poweroff" -> + (* we do not expect a HVM guest to survive qemu disappearing, so + kill the VM *) + Domain.set_action_request ~xs di.Xenctrl.domid (Some "poweroff") + | "pause" -> + (* useful for debugging qemu *) + Domain.pause ~xc di.Xenctrl.domid + | _ -> + () + ) - (* Called from a xenops client if it needs to resume a VM that was suspended - on a pre-xenopsd host. *) + let add_device_watch xs dev = + let open Device_common in + debug "Adding watches for: %s" (string_of_device dev) ; + let domid = dev.frontend.domid in + let token = watch_token domid in + List.iter (Xenstore_watch.watch ~xs token) (watches_of_device dev) ; + device_watches := + IntMap.add domid + (dev :: IntMap.find domid !device_watches) + !device_watches + + let remove_device_watch xs dev = + let open Device_common in + debug "Removing watches for: %s" (string_of_device dev) ; + let domid = dev.frontend.domid in + let current = IntMap.find domid !device_watches in + let token = watch_token domid in + List.iter (Xenstore_watch.unwatch ~xs token) (watches_of_device dev) ; + device_watches := + IntMap.add domid (List.filter (fun x -> x <> dev) current) !device_watches + + let watch_fired xc xs path domains watches = + let look_for_different_devices domid = + if not (Xenstore_watch.IntSet.mem domid watches) then + debug "Ignoring frontend device watch on unmanaged domain: %d" domid + else if not (IntMap.mem domid !device_watches) then + warn + "Xenstore watch fired, but no entry for domid %d in device watches \ + list" + domid + else + let devices = IntMap.find domid !device_watches in + let devices' = Device_common.list_frontends ~xs domid in + let old_devices = + Xapi_stdext_std.Listext.List.set_difference devices devices' + in + let new_devices = + Xapi_stdext_std.Listext.List.set_difference devices' devices + in + List.iter (add_device_watch xs) new_devices ; + List.iter (remove_device_watch xs) old_devices + in + let uuid_of_domain di = + let string_of_domain_handle handle = + Array.to_list handle |> List.map string_of_int |> String.concat "; " + in + match Uuidx.of_int_array di.Xenctrl.handle with + | Some x -> + x + | None -> + failwith + (Printf.sprintf "VM handle for domain %i is an invalid uuid: %a" + di.Xenctrl.domid + (fun () -> string_of_domain_handle) + di.Xenctrl.handle + ) + in + let fire_event_on_vm domid = + let d = int_of_string domid in + let open Xenstore_watch in + if not (IntMap.mem d domains) then + debug "Ignoring watch on shutdown domain %d" d + else + let di = IntMap.find d domains in + let id = Uuidx.to_string (uuid_of_domain di) in + Updates.add (Dynamic.Vm id) internal_updates + in + let fire_event_on_device domid kind devid = + let d = int_of_string domid in + let open Xenstore_watch in + if not (IntMap.mem d domains) then + debug "Ignoring watch on shutdown domain %d" d + else + let di = IntMap.find d domains in + let id = Uuidx.to_string (uuid_of_domain di) in + let update = + match kind with + | "vbd" | "vbd3" | "qdisk" | "9pfs" -> + let devid' = + devid + |> int_of_string + |> Device_number.of_xenstore_key + |> Device_number.to_linux_device + in + Some (Dynamic.Vbd (id, devid')) + | "vif" -> + Some (Dynamic.Vif (id, devid)) + | x -> + debug "Unknown device kind: '%s'" x ; + None + in + Option.iter (fun x -> Updates.add x internal_updates) update + in + let fire_event_on_qemu domid = + let d = int_of_string domid in + let open Xenstore_watch in + if not (IntMap.mem d domains) then + debug "Ignoring qemu-pid-signal watch on shutdown domain %d" d + else + let signal = + try Some (xs.Xs.read (Service.Qemu.pidxenstore_path_signal d)) + with _ -> None + in + match signal with + | None -> + () + | Some signal -> + debug "Received unexpected qemu-pid-signal %s for domid %d" signal d ; + let di = IntMap.find d domains in + let id = Uuidx.to_string (uuid_of_domain di) in + qemu_disappeared di xc xs ; + Updates.add (Dynamic.Vm id) internal_updates + in + match Astring.String.cuts ~empty:false ~sep:"/" path with + | "local" + :: "domain" + :: domid + :: "backend" + :: kind + :: frontend + :: devid + :: key -> + debug + "Watch on backend domid: %s kind: %s -> frontend domid: %s devid: %s" + domid kind frontend devid ; + fire_event_on_device frontend kind devid ; + (* If this event was a state change then this might be the first time we + see evidence of PV drivers *) + if key = ["state"] then + maybe_update_pv_drivers_detected ~xc ~xs (int_of_string frontend) path + | "local" :: "domain" :: frontend :: "device" :: _ -> + look_for_different_devices (int_of_string frontend) + | ["local"; "domain"; domid; "qemu-pid-signal"] -> + fire_event_on_qemu domid + | "local" :: "domain" :: domid :: _ -> + fire_event_on_vm domid + | ["vm"; uuid; "rtc"; "timeoffset"] -> + let timeoffset = try Some (xs.Xs.read path) with _ -> None in + Option.iter + (fun timeoffset -> + (* Store the rtc/timeoffset for migrate *) + store_rtc_timeoffset uuid timeoffset ; + (* Tell the higher-level toolstack about this too *) + Updates.add (Dynamic.Vm uuid) internal_updates + ) + timeoffset + | _ -> + debug "Ignoring unexpected watch: %s" path +end + +module Watcher = Xenstore_watch.WatchXenstore (Actions) + +module VM = struct + open Vm + + let will_be_hvm vm = match vm.ty with HVM _ -> true | _ -> false + + let profile_of ~vm = + if will_be_hvm vm then + Some (choose_qemu_dm vm.Xenops_interface.Vm.platformdata) + else + None + + let dm_of ~vm = dm_of ~vm:vm.Vm.id + + let compute_overhead persistent vcpu_max memory_static_max shadow_multiplier = + let open VmExtra in + let static_max_mib = Memory.mib_of_bytes_used memory_static_max in + let model = + match persistent.ty with + | Some (PV _) -> + Memory.Linux.overhead_mib + | Some (PVinPVH _) -> + Memory.PVinPVH.overhead_mib + | Some (HVM _ | PVH _) -> + Memory.HVM.overhead_mib + | None -> + failwith + "cannot compute memory overhead: unable to determine domain type" + in + model static_max_mib vcpu_max shadow_multiplier |> Memory.bytes_of_mib + + let shutdown_reason = function + | Reboot -> + Domain.Reboot + | PowerOff -> + Domain.PowerOff + | Suspend -> + Domain.Suspend + | Halt -> + Domain.Halt + | S3Suspend -> + Domain.S3Suspend + + (* We compute our initial target at memory reservation time, done before the + domain is created. We consume this information later when the domain is + built. *) + let set_initial_target ~xs domid initial_target = + xs.Xs.write + (Printf.sprintf "/local/domain/%d/memory/initial-target" domid) + (Int64.to_string initial_target) + + let get_initial_target ~xs domid = + Int64.of_string + (xs.Xs.read + (Printf.sprintf "/local/domain/%d/memory/initial-target" domid) + ) + + let domain_type_path domid = + Printf.sprintf "/local/domain/%d/domain-type" domid + + let set_domain_type ~xs domid vm = + let domain_type = + match vm.ty with + | HVM _ -> + "hvm" + | PV _ -> + "pv" + | PVinPVH _ -> + "pv-in-pvh" + | PVH _ -> + "pvh" + in + xs.Xs.write (domain_type_path domid) domain_type + + let get_domain_type ~xs di = + try + match xs.Xs.read (domain_type_path di.Xenctrl.domid) with + | "hvm" -> + Domain_HVM + | "pv" -> + Domain_PV + | "pv-in-pvh" -> + Domain_PVinPVH + | "pvh" -> + Domain_PVH + | x -> + warn "domid = %d; Undefined domain type found (%s)" di.Xenctrl.domid x ; + Domain_undefined + with Xs_protocol.Enoent _ -> + (* Fallback for the upgrade case, where the new xs key may not exist *) + if di.Xenctrl.hvm_guest then + Domain_HVM + else + Domain_PV + + (* Called from a xenops client if it needs to resume a VM that was suspended + on a pre-xenopsd host. *) let generate_state_string vm = let open Memory in let builder_spec_info = @@ -1287,7 +1627,7 @@ module VM = struct ; kernel= "" ; vcpus= vm.vcpu_max ; priv= builder_spec_info - ; has_hard_affinity= vm.scheduler_params.affinity <> [] + ; hard_affinity= vm.scheduler_params.affinity } in VmExtra. @@ -1303,8 +1643,6 @@ module VM = struct |> rpc_of VmExtra.persistent_t |> Jsonrpc.to_string - let mkints n = List.init n Fun.id - let generate_create_info ~xs:_ vm persistent = let ty = match persistent.VmExtra.ty with Some ty -> ty | None -> vm.ty in let hvm = @@ -1312,38 +1650,6 @@ module VM = struct in (* XXX add per-vcpu information to the platform data *) (* VCPU configuration *) - let xcext = Xenctrlext.get_handle () in - let pcpus = Xenctrlext.get_max_nr_cpus xcext in - let all_pcpus = mkints pcpus in - let all_vcpus = mkints vm.vcpu_max in - let masks = - match vm.scheduler_params.affinity with - | [] -> - (* Every vcpu can run on every pcpu *) - List.map (fun _ -> all_pcpus) all_vcpus - | m :: ms -> - (* Treat the first as the template for the rest *) - let defaults = List.map (fun _ -> m) all_vcpus in - Xapi_stdext_std.Listext.List.take vm.vcpu_max ((m :: ms) @ defaults) - in - (* convert a mask into a binary string, one char per pCPU *) - let bitmap cpus : string = - let cpus = List.filter (fun x -> x >= 0 && x < pcpus) cpus in - let result = Bytes.make pcpus '0' in - List.iter (fun cpu -> Bytes.set result cpu '1') cpus ; - Bytes.unsafe_to_string result - in - let affinity = - snd - (List.fold_left - (fun (idx, acc) mask -> - ( idx + 1 - , (Printf.sprintf "vcpu/%d/affinity" idx, bitmap mask) :: acc - ) - ) - (0, []) masks - ) - in let weight = vm.scheduler_params.priority |> Option.map (fun (w, c) -> @@ -1359,7 +1665,6 @@ module VM = struct (match vm.ty with PVinPVH _ -> vm.vcpu_max | _ -> vm.vcpus) ) ] - @ affinity @ weight in let set_generation_id platformdata = @@ -1424,7 +1729,8 @@ module VM = struct in (device_id, revision) - let create_exn task memory_upper_bound vm final_id no_sharept = + let create_exn task memory_upper_bound vm final_id no_sharept num_of_vbds + num_of_vifs = let k = vm.Vm.id in with_xc_and_xs (fun xc xs -> (* Ensure the DB contains something for this VM - this is to avoid a @@ -1553,7 +1859,8 @@ module VM = struct let create_info = generate_create_info ~xs vm persistent in let domid = Domain.make ~xc ~xs create_info vm.vcpu_max domain_config - (uuid_of_vm vm) final_id no_sharept + (uuid_of_vm vm) final_id no_sharept num_of_vbds + num_of_vifs in Mem.transfer_reservation_to_domain dbg domid reservation_id ; let initial_target = @@ -1683,7 +1990,8 @@ module VM = struct ) ; debug "Moving xenstore tree" ; Domain.move_xstree ~xs di.Xenctrl.domid old_name new_name ; - DB.rename old_name new_name + DB.rename old_name new_name ; + Watcher.mark_refresh_domains () in Option.iter rename_domain (di_of_uuid ~xc (uuid_of_string old_name)) @@ -2040,7 +2348,7 @@ module VM = struct ; kernel ; vcpus= vm.vcpu_max ; priv - ; has_hard_affinity= vm.scheduler_params.affinity <> [] + ; hard_affinity= vm.scheduler_params.affinity } in debug "static_max_mib=%Ld" static_max_mib ; @@ -2661,7 +2969,6 @@ module VM = struct in ({x with Domain.memory_target= initial_target}, timeoffset) in - let no_incr_generationid = false in let vtpm = vtpm_of ~vm in ( try with_data ~xc ~xs task data false @@ fun fd -> @@ -2677,9 +2984,8 @@ module VM = struct None in let manager_path = choose_emu_manager vm.Vm.platformdata in - Domain.restore task ~xc ~xs ~dm:(dm_of ~vm) ~store_domid - ~console_domid ~no_incr_generationid ~timeoffset ~extras build_info - ~manager_path ~vtpm domid fd vgpu_fd + Domain.restore task ~xc ~xs ~dm:(dm_of ~vm) ~timeoffset ~extras + build_info ~manager_path ~vtpm domid fd vgpu_fd with e -> error "VM %s: restore failed: %s" vm.Vm.id (Printexc.to_string e) ; (* As of xen-unstable.hg 779c0ef9682 libxenguest will destroy @@ -2867,6 +3173,8 @@ module VM = struct ; ("data", None, 0) (* in particular avoid data/volumes which contains many entries for each disk *) ; ("data/service", None, 1) (* data/service//*) + ; ("data/pvs_target", None, 0) + (* data/pvs_target/*) ] |> List.fold_left (fun acc (dir, excludes, depth) -> @@ -3717,9 +4025,13 @@ module VBD = struct persistent= { vm_t.VmExtra.persistent with + (* Index by id_of vbd rather than vbd.id as VmExtra is + already indexed by VM id, so the VM id part of + vbd.id is unnecessary and causes issues finding the + attached_vdi when the VM is renamed. *) attached_vdis= - (vbd.Vbd.id, vdi) - :: List.remove_assoc vbd.Vbd.id + (id_of vbd, vdi) + :: List.remove_assoc (id_of vbd) vm_t.persistent.attached_vdis } } @@ -3741,7 +4053,7 @@ module VBD = struct let activate task vm vbd = let vmextra = DB.read_exn vm in - match List.assoc_opt vbd.id vmextra.persistent.attached_vdis with + match List.assoc_opt (id_of vbd) vmextra.persistent.attached_vdis with | None -> debug "No attached_vdi info, so not activating" | Some vdi -> @@ -3892,9 +4204,130 @@ module VBD = struct ) vm ) - (fun () -> cleanup_attached_vdis vm vbd.id) + (fun () -> cleanup_attached_vdis vm (id_of vbd)) - let deactivate task vm vbd force = + let unplug task vm vbd force = + with_xc_and_xs (fun xc xs -> + try + (* On destroying the datapath + + 1. if the device has already been shutdown and deactivated (as in + suspend) we must call DP.destroy here to avoid leaks + + 2. if the device is successfully shutdown here then we must call + DP.destroy because no-one else will + + 3. if the device shutdown is rejected then we should leave the DP + alone and rely on the event thread calling us again later. *) + let domid = domid_of_uuid ~xs (uuid_of_string vm) in + (* If the device is gone then we don't need to shut it down but we do + need to free any storage resources. *) + let dev = + try + Some (device_by_id xc xs vm (device_kind_of ~xs vbd) (id_of vbd)) + with + | Xenopsd_error (Does_not_exist (_, _)) -> + debug "VM = %s; VBD = %s; Ignoring missing domain" vm (id_of vbd) ; + None + | Xenopsd_error Device_not_connected -> + debug "VM = %s; VBD = %s; Ignoring missing device" vm (id_of vbd) ; + None + in + let backend = + match dev with + | None -> + None + | Some dv -> ( + match + Rpcmarshal.unmarshal typ_of_backend + (Device.Generic.get_private_key ~xs dv _vdi_id + |> Jsonrpc.of_string + ) + with + | Ok x -> + x + | Error (`Msg m) -> + internal_error "Failed to unmarshal VBD backend: %s" m + ) + in + Option.iter + (fun dev -> + if force && not (Device.can_surprise_remove ~xs dev) then + debug + "VM = %s; VBD = %s; Device is not surprise-removable \ + (ignoring and removing anyway)" + vm (id_of vbd) ; + (* this happens on normal shutdown too *) + (* Case (1): success; Case (2): success; Case (3): an exception is + thrown *) + with_tracing ~task ~name:"VBD_device_shutdown" @@ fun () -> + Xenops_task.with_subtask task + (Printf.sprintf "Vbd.clean_shutdown %s" (id_of vbd)) + (fun () -> + (if force then Device.hard_shutdown else Device.clean_shutdown) + task ~xs dev + ) + ) + dev ; + (* We now have a shutdown device but an active DP: we should destroy + the DP if the backend is of type VDI *) + finally + (fun () -> + with_tracing ~task ~name:"VBD_device_release" (fun () -> + Option.iter + (fun dev -> + Xenops_task.with_subtask task + (Printf.sprintf "Vbd.release %s" (id_of vbd)) + (fun () -> Device.Vbd.release task ~xc ~xs dev) + ) + dev + ) ; + (* If we have a qemu frontend, detach this too. *) + with_tracing ~task ~name:"VBD_detach_qemu" @@ fun () -> + let _ = + DB.update vm + (Option.map (fun vm_t -> + let persistent = vm_t.VmExtra.persistent in + if List.mem_assoc vbd.Vbd.id persistent.VmExtra.qemu_vbds + then ( + let _, qemu_vbd = + List.assoc vbd.Vbd.id persistent.VmExtra.qemu_vbds + in + (* destroy_vbd_frontend ignores 'refusing to close' + transients' *) + destroy_vbd_frontend ~xc ~xs task qemu_vbd ; + VmExtra. + { + persistent= + { + persistent with + qemu_vbds= + List.remove_assoc vbd.Vbd.id + persistent.qemu_vbds + } + } + ) else + vm_t + ) + ) + in + () + ) + (fun () -> + with_tracing ~task ~name:"VBD_dp_destroy" @@ fun () -> + match (domid, backend) with + | Some x, None | Some x, Some (VDI _) -> + Storage.dp_destroy task + (Storage.id_of (string_of_int x) vbd.Vbd.id) + | _ -> + () + ) + with Device_common.Device_error (_, s) -> + debug "Caught Device_error: %s" s ; + raise (Xenopsd_error (Device_detach_rejected ("VBD", id_of vbd, s))) + ) + + let deactivate task vm vbd force = with_xc_and_xs (fun xc xs -> try (* On destroying the datapath @@ -4056,7 +4489,7 @@ module VBD = struct | _ -> () ) ; - cleanup_attached_vdis vm vbd.id + cleanup_attached_vdis vm (id_of vbd) let insert task vm vbd d = on_frontend @@ -4863,349 +5296,6 @@ module UPDATES = struct let get last timeout = Updates.get "UPDATES.get" last timeout internal_updates end -module IntMap = Map.Make (struct - type t = int - - let compare = compare -end) - -module Actions = struct - (* CA-76600: the rtc/timeoffset needs to be maintained over a migrate. *) - let store_rtc_timeoffset vm timeoffset = - let _ = - DB.update vm - (Option.map (function {VmExtra.persistent} as extra -> - ( match persistent with - | {VmExtra.ty= Some (Vm.HVM hvm_info); _} -> - let platformdata = - ("timeoffset", timeoffset) - :: List.remove_assoc "timeoffset" persistent.platformdata - in - let persistent = - { - persistent with - VmExtra.ty= Some (Vm.HVM {hvm_info with Vm.timeoffset}) - ; platformdata - } - in - debug "VM = %s; rtc/timeoffset <- %s" vm timeoffset ; - VmExtra.{persistent} - | _ -> - extra - ) - ) - ) - in - () - - let xenbus_connected = Xenbus_utils.(int_of Connected) |> string_of_int - - let maybe_update_pv_drivers_detected ~xc ~xs domid path = - let vm = get_uuid ~xc domid |> Uuidx.to_string in - Option.iter - (function - | {VmExtra.persistent} -> ( - try - let value = xs.Xs.read path in - let pv_drivers_detected = - match - ( value = xenbus_connected - , persistent.VmExtra.pv_drivers_detected - ) - with - | true, false -> - (* State "connected" (4) means that PV drivers are present for - this device *) - debug "VM = %s; found PV driver evidence on %s (value = %s)" - vm path value ; - true - | false, true -> - (* This device is not connected, while earlier we detected PV - drivers. We conclude that drivers are still present if any - other device is connected. *) - let devices = Device_common.list_frontends ~xs domid in - let found = - (* Return `true` as soon as a device in state 4 is found. *) - List.exists - (fun device -> - try - xs.Xs.read - (Device_common.backend_state_path_of_device ~xs - device - ) - = xenbus_connected - with Xs_protocol.Enoent _ -> false - ) - devices - in - if not found then (* No devices in state "connected" (4) *) - debug "VM = %s; lost PV driver evidence" vm ; - found - | _ -> - (* No change *) - persistent.VmExtra.pv_drivers_detected - in - let updated = - DB.update vm - (Option.map (function {VmExtra.persistent} -> - let persistent = - {persistent with VmExtra.pv_drivers_detected} - in - VmExtra.{persistent} - ) - ) - in - if updated then - Updates.add (Dynamic.Vm vm) internal_updates - with Xs_protocol.Enoent _ -> - warn "Watch event on %s fired but couldn't read from it" path ; - () - (* the path must have disappeared immediately after the watch fired. - Let's treat this as if we never saw it. *) - ) - ) - (DB.read vm) - - let interesting_paths_for_domain domid uuid = - let open Printf in - [ - sprintf "/local/domain/%d/attr" domid - ; sprintf "/local/domain/%d/data/updated" domid - ; sprintf "/local/domain/%d/data/ts" domid - ; sprintf "/local/domain/%d/data/service" domid - ; sprintf "/local/domain/%d/memory/target" domid - ; sprintf "/local/domain/%d/memory/uncooperative" domid - ; sprintf "/local/domain/%d/console/vnc-port" domid - ; sprintf "/local/domain/%d/console/tc-port" domid - ; Service.Qemu.pidxenstore_path_signal domid - ; sprintf "/local/domain/%d/control" domid - ; sprintf "/local/domain/%d/device" domid - ; sprintf "/local/domain/%d/rrd" domid - ; sprintf "/local/domain/%d/vm-data" domid - ; sprintf "/local/domain/%d/feature" domid - ; sprintf "/vm/%s/rtc/timeoffset" uuid - ; sprintf "/local/domain/%d/xenserver/attr" domid - ] - - let watch_token domid = Printf.sprintf "xenopsd-xc:domain-%d" domid - - let watches_of_device dev = - let interesting_backend_keys = - [ - "kthread-pid" - ; "tapdisk-pid" - ; "shutdown-done" - ; "hotplug-status" - ; "params" - ; "state" - ] - in - let open Device_common in - let be = dev.backend.domid in - let fe = dev.frontend.domid in - let kind = string_of_kind dev.backend.kind in - let devid = dev.frontend.devid in - List.map - (fun k -> - Printf.sprintf "/local/domain/%d/backend/%s/%d/%d/%s" be kind fe devid k - ) - interesting_backend_keys - - let unmanaged_domain domid id = domid > 0 && not (DB.exists id) - - let found_running_domain _domid id = - Updates.add (Dynamic.Vm id) internal_updates - - let device_watches = ref IntMap.empty - - let domain_appeared _xc _xs domid = - device_watches := IntMap.add domid [] !device_watches - - let domain_disappeared _xc xs domid = - let token = watch_token domid in - List.iter - (fun d -> - List.iter (Xenstore_watch.unwatch ~xs token) (watches_of_device d) - ) - (try IntMap.find domid !device_watches with Not_found -> []) ; - device_watches := IntMap.remove domid !device_watches ; - (* Anyone blocked on a domain/device operation which won't happen because - the domain just shutdown should be cancelled here. *) - debug "Cancelling watches for: domid %d" domid ; - Cancel_utils.on_shutdown ~xs domid ; - (* Finally, discard any device caching for the domid destroyed *) - DeviceCache.discard device_cache domid - - let qemu_disappeared di xc xs = - match !Xenopsd.action_after_qemu_crash with - | None -> - () - | Some action -> ( - debug "action-after-qemu-crash=%s" action ; - match action with - | "poweroff" -> - (* we do not expect a HVM guest to survive qemu disappearing, so - kill the VM *) - Domain.set_action_request ~xs di.Xenctrl.domid (Some "poweroff") - | "pause" -> - (* useful for debugging qemu *) - Domain.pause ~xc di.Xenctrl.domid - | _ -> - () - ) - - let add_device_watch xs dev = - let open Device_common in - debug "Adding watches for: %s" (string_of_device dev) ; - let domid = dev.frontend.domid in - let token = watch_token domid in - List.iter (Xenstore_watch.watch ~xs token) (watches_of_device dev) ; - device_watches := - IntMap.add domid - (dev :: IntMap.find domid !device_watches) - !device_watches - - let remove_device_watch xs dev = - let open Device_common in - debug "Removing watches for: %s" (string_of_device dev) ; - let domid = dev.frontend.domid in - let current = IntMap.find domid !device_watches in - let token = watch_token domid in - List.iter (Xenstore_watch.unwatch ~xs token) (watches_of_device dev) ; - device_watches := - IntMap.add domid (List.filter (fun x -> x <> dev) current) !device_watches - - let watch_fired xc xs path domains watches = - let look_for_different_devices domid = - if not (Xenstore_watch.IntSet.mem domid watches) then - debug "Ignoring frontend device watch on unmanaged domain: %d" domid - else if not (IntMap.mem domid !device_watches) then - warn - "Xenstore watch fired, but no entry for domid %d in device watches \ - list" - domid - else - let devices = IntMap.find domid !device_watches in - let devices' = Device_common.list_frontends ~xs domid in - let old_devices = - Xapi_stdext_std.Listext.List.set_difference devices devices' - in - let new_devices = - Xapi_stdext_std.Listext.List.set_difference devices' devices - in - List.iter (add_device_watch xs) new_devices ; - List.iter (remove_device_watch xs) old_devices - in - let uuid_of_domain di = - let string_of_domain_handle handle = - Array.to_list handle |> List.map string_of_int |> String.concat "; " - in - match Uuidx.of_int_array di.Xenctrl.handle with - | Some x -> - x - | None -> - failwith - (Printf.sprintf "VM handle for domain %i is an invalid uuid: %a" - di.Xenctrl.domid - (fun () -> string_of_domain_handle) - di.Xenctrl.handle - ) - in - let fire_event_on_vm domid = - let d = int_of_string domid in - let open Xenstore_watch in - if not (IntMap.mem d domains) then - debug "Ignoring watch on shutdown domain %d" d - else - let di = IntMap.find d domains in - let id = Uuidx.to_string (uuid_of_domain di) in - Updates.add (Dynamic.Vm id) internal_updates - in - let fire_event_on_device domid kind devid = - let d = int_of_string domid in - let open Xenstore_watch in - if not (IntMap.mem d domains) then - debug "Ignoring watch on shutdown domain %d" d - else - let di = IntMap.find d domains in - let id = Uuidx.to_string (uuid_of_domain di) in - let update = - match kind with - | "vbd" | "vbd3" | "qdisk" | "9pfs" -> - let devid' = - devid - |> int_of_string - |> Device_number.of_xenstore_key - |> Device_number.to_linux_device - in - Some (Dynamic.Vbd (id, devid')) - | "vif" -> - Some (Dynamic.Vif (id, devid)) - | x -> - debug "Unknown device kind: '%s'" x ; - None - in - Option.iter (fun x -> Updates.add x internal_updates) update - in - let fire_event_on_qemu domid = - let d = int_of_string domid in - let open Xenstore_watch in - if not (IntMap.mem d domains) then - debug "Ignoring qemu-pid-signal watch on shutdown domain %d" d - else - let signal = - try Some (xs.Xs.read (Service.Qemu.pidxenstore_path_signal d)) - with _ -> None - in - match signal with - | None -> - () - | Some signal -> - debug "Received unexpected qemu-pid-signal %s for domid %d" signal d ; - let di = IntMap.find d domains in - let id = Uuidx.to_string (uuid_of_domain di) in - qemu_disappeared di xc xs ; - Updates.add (Dynamic.Vm id) internal_updates - in - match Astring.String.cuts ~empty:false ~sep:"/" path with - | "local" - :: "domain" - :: domid - :: "backend" - :: kind - :: frontend - :: devid - :: key -> - debug - "Watch on backend domid: %s kind: %s -> frontend domid: %s devid: %s" - domid kind frontend devid ; - fire_event_on_device frontend kind devid ; - (* If this event was a state change then this might be the first time we - see evidence of PV drivers *) - if key = ["state"] then - maybe_update_pv_drivers_detected ~xc ~xs (int_of_string frontend) path - | "local" :: "domain" :: frontend :: "device" :: _ -> - look_for_different_devices (int_of_string frontend) - | ["local"; "domain"; domid; "qemu-pid-signal"] -> - fire_event_on_qemu domid - | "local" :: "domain" :: domid :: _ -> - fire_event_on_vm domid - | ["vm"; uuid; "rtc"; "timeoffset"] -> - let timeoffset = try Some (xs.Xs.read path) with _ -> None in - Option.iter - (fun timeoffset -> - (* Store the rtc/timeoffset for migrate *) - store_rtc_timeoffset uuid timeoffset ; - (* Tell the higher-level toolstack about this too *) - Updates.add (Dynamic.Vm uuid) internal_updates - ) - timeoffset - | _ -> - debug "Ignoring unexpected watch: %s" path -end - -module Watcher = Xenstore_watch.WatchXenstore (Actions) - (* Here we analyse common startup errors in more detail and suggest the most likely fixes (e.g. switch to root, start missing service) *) diff --git a/ocaml/xenopsd/xenopsd.conf b/ocaml/xenopsd/xenopsd.conf index e80194c1f5..e1c3c87c7c 100644 --- a/ocaml/xenopsd/xenopsd.conf +++ b/ocaml/xenopsd/xenopsd.conf @@ -108,3 +108,11 @@ disable-logging-for=http tracing tracing_export # time to wait for in-guest PV drivers to acknowledge a shutdown request # before we conclude that the drivers have failed # domain_shutdown_ack_timeout = 60 + +# Controls whether, when the VM starts in HVM mode, the Xen PCI MMIO used +# by grant tables is mapped as Uncached (UC, the default) or WriteBack +# (WB, the workaround). WB mapping could improve performance of devices +# using grant tables. This is useful on AMD platform only. +# On Intel a similar effect is already achieved with iPAT in Xen, +# but setting this to 0 works on Intel too. +# xen-platform-pci-bar-uc=false diff --git a/ocaml/xs-trace/dune b/ocaml/xs-trace/dune index e34fc7e557..ab41958c1c 100644 --- a/ocaml/xs-trace/dune +++ b/ocaml/xs-trace/dune @@ -1,23 +1,18 @@ (executable - (modes exe) - (name xs_trace) - (public_name xs-trace) - (package xapi-tools) - (libraries - uri - tracing - cmdliner - tracing_export - xapi-stdext-unix - zstd - ) -) + (modes exe) + (name xs_trace) + (public_name xs-trace) + (package xapi-tools) + (libraries uri tracing cmdliner tracing_export yojson xapi-stdext-unix zstd unix)) (rule - (targets xs-trace.1) - (deps (:exe xs_trace.exe)) - (action (with-stdout-to %{targets} (run %{exe} --help=groff))) -) + (targets xs-trace.1) + (deps + (:exe xs_trace.exe)) + (action + (with-stdout-to + %{targets} + (run %{exe} --help=groff)))) ; not expected by the specfile ;(install diff --git a/ocaml/xs-trace/xs_trace.ml b/ocaml/xs-trace/xs_trace.ml index 6360649fb2..a5f0c8bece 100644 --- a/ocaml/xs-trace/xs_trace.ml +++ b/ocaml/xs-trace/xs_trace.ml @@ -25,10 +25,7 @@ module Exporter = struct | _ -> () - (** Export traces from file system to a remote endpoint. *) - let export erase src dst = - let dst = Uri.of_string dst in - let submit_json = submit_json dst in + let iter_src src f = let rec export_file = function | path when Sys.is_directory path -> (* Recursively export trace files. *) @@ -38,7 +35,7 @@ module Exporter = struct (* Decompress compressed trace file and submit each line iteratively *) let args = [|"zstdcat"; path|] in let ic = Unix.open_process_args_in args.(0) args in - Unixext.lines_iter submit_json ic ; + Unixext.lines_iter f ic ; match Unix.close_process_in ic with | Unix.WEXITED 0 -> () @@ -47,15 +44,27 @@ module Exporter = struct ) | path when Filename.check_suffix path ".ndjson" -> (* Submit traces line by line. *) - Unixext.readfile_line submit_json path + Unixext.readfile_line f path | path -> (* Assume any other extension is a valid JSON file. *) let json = Unixext.string_of_file path in - submit_json json + f json in - export_file src ; + export_file src + + (** Export traces from file system to a remote endpoint. *) + let export erase src dst = + let dst = Uri.of_string dst in + let submit_json = submit_json dst in + iter_src src submit_json ; if erase then Unixext.rm_rec ~rm_top:true src + + let pretty_print src = + iter_src src @@ fun line -> + line + |> Yojson.Safe.from_string + |> Yojson.Safe.pretty_to_channel ~std:true stdout end module Cli = struct @@ -83,6 +92,11 @@ module Cli = struct let doc = "copy a trace to an endpoint and erase it afterwards" in Cmd.(v (info "mv" ~doc) term) + let pp_cmd = + let term = Term.(const Exporter.pretty_print $ src) in + let doc = "Pretty print NDJSON traces" in + Cmd.(v (info "pp" ~doc) term) + let xs_trace_cmd = let man = [ @@ -94,7 +108,7 @@ module Cli = struct let doc = "utility for working with local trace files" in Cmd.info "xs-trace" ~doc ~version:"0.1" ~man in - Cmd.group desc [cp_cmd; mv_cmd] + Cmd.group desc [cp_cmd; mv_cmd; pp_cmd] let main () = Cmd.eval xs_trace_cmd end diff --git a/ocaml/xsh/dune b/ocaml/xsh/dune index c908cd4fda..4110308160 100644 --- a/ocaml/xsh/dune +++ b/ocaml/xsh/dune @@ -7,6 +7,7 @@ stunnel safe-resources + unix xapi-consts xapi-log xapi-stdext-unix diff --git a/opam/clock.opam b/opam/clock.opam index 705f280d2b..ff5f874cb8 100644 --- a/opam/clock.opam +++ b/opam/clock.opam @@ -7,7 +7,7 @@ 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.15"} + "dune" {>= "3.20"} "ocaml" {>= "4.12"} "alcotest" {with-test} "astring" @@ -34,3 +34,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/cohttp-posix.opam b/opam/cohttp-posix.opam index e4aba962fa..9702e0b74d 100644 --- a/opam/cohttp-posix.opam +++ b/opam/cohttp-posix.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/ezxenstore.opam b/opam/ezxenstore.opam index d5a1ff58de..13ae6bb99e 100644 --- a/opam/ezxenstore.opam +++ b/opam/ezxenstore.opam @@ -1,5 +1,5 @@ # This file is generated by dune, edit dune-project instead - +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xapi project maintainers" authors: ["Jonathan Ludlam"] diff --git a/opam/forkexec.opam b/opam/forkexec.opam index 68ca75e06d..cf43e8d76a 100644 --- a/opam/forkexec.opam +++ b/opam/forkexec.opam @@ -8,7 +8,7 @@ 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.15"} + "dune" {>= "3.20"} "astring" "base-threads" "fd-send-recv" {>= "2.0.0"} @@ -37,3 +37,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/gzip.opam b/opam/gzip.opam index 7a04554f2a..a88183276f 100644 --- a/opam/gzip.opam +++ b/opam/gzip.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/http-lib.opam b/opam/http-lib.opam index e0e898c81c..900b5593c0 100644 --- a/opam/http-lib.opam +++ b/opam/http-lib.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "alcotest" {with-test} "astring" "base64" {>= "3.1.0"} @@ -50,3 +50,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/message-switch-cli.opam b/opam/message-switch-cli.opam index ccbea62e0b..1db2f98893 100644 --- a/opam/message-switch-cli.opam +++ b/opam/message-switch-cli.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" name: "message-switch-cli" maintainer: "xen-api@lists.xen.org" diff --git a/opam/message-switch-core.opam b/opam/message-switch-core.opam index a6b183bdd7..3afecf2750 100644 --- a/opam/message-switch-core.opam +++ b/opam/message-switch-core.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "astring" "cohttp" {>= "0.21.1"} "ppx_deriving_rpc" @@ -20,6 +20,7 @@ depends: [ "uri" "xapi-log" {= version} "xapi-stdext-threads" {= version} + "xapi-tracing" {= version} "odoc" {with-doc} ] build: [ @@ -37,3 +38,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/message-switch-lwt.opam b/opam/message-switch-lwt.opam index 3688d40a18..0b13843c03 100644 --- a/opam/message-switch-lwt.opam +++ b/opam/message-switch-lwt.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" name: "message-switch-lwt" maintainer: "xen-api@lists.xen.org" diff --git a/opam/message-switch-unix.opam b/opam/message-switch-unix.opam index c9379979e2..4d0c90a405 100644 --- a/opam/message-switch-unix.opam +++ b/opam/message-switch-unix.opam @@ -9,13 +9,14 @@ 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.15"} + "dune" {>= "3.20"} "base-threads" "cohttp" "message-switch-core" {= version} "ppx_deriving_rpc" "rpclib" "xapi-stdext-threads" {= version} + "xapi-tracing" {= version} "odoc" {with-doc} ] build: [ @@ -33,3 +34,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/message-switch.opam b/opam/message-switch.opam index f0dcf7ff22..ff7273d5ea 100644 --- a/opam/message-switch.opam +++ b/opam/message-switch.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" name: "message-switch" maintainer: "xen-api@lists.xen.org" @@ -30,6 +31,7 @@ depends: [ "sexplib" "shared-block-ring" {>= "2.3.0"} "xapi-stdext-unix" + "xapi-tracing" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/opam/message-switch.opam.template b/opam/message-switch.opam.template index a33fe27cb3..0e8ec76c2e 100644 --- a/opam/message-switch.opam.template +++ b/opam/message-switch.opam.template @@ -28,6 +28,7 @@ depends: [ "sexplib" "shared-block-ring" {>= "2.3.0"} "xapi-stdext-unix" + "xapi-tracing" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/opam/pciutil.opam b/opam/pciutil.opam index 4e93f06fcc..9bb2334b46 100644 --- a/opam/pciutil.opam +++ b/opam/pciutil.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/qcow-stream-tool.opam b/opam/qcow-stream-tool.opam new file mode 100644 index 0000000000..8090aec7a3 --- /dev/null +++ b/opam/qcow-stream-tool.opam @@ -0,0 +1,30 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Minimal CLI wrapper for qcow-stream" +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"} + "qcow-stream" + "cmdliner" + "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/rrd-transport.opam b/opam/rrd-transport.opam index 441dbeebbd..9cf1973535 100644 --- a/opam/rrd-transport.opam +++ b/opam/rrd-transport.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "alcotest" {with-test} "astring" "bigarray-compat" @@ -37,3 +37,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/rrdd-plugin.opam b/opam/rrdd-plugin.opam index f59d26a365..fc5ebadbed 100644 --- a/opam/rrdd-plugin.opam +++ b/opam/rrdd-plugin.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "ocaml" "astring" "rpclib" @@ -39,3 +39,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/safe-resources.opam b/opam/safe-resources.opam index b8f0e5b615..e4bd199a64 100644 --- a/opam/safe-resources.opam +++ b/opam/safe-resources.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/sexpr.opam b/opam/sexpr.opam index daa33dc661..0adfec4b10 100644 --- a/opam/sexpr.opam +++ b/opam/sexpr.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/stunnel.opam b/opam/stunnel.opam index a65c7f8810..4f0a5d7640 100644 --- a/opam/stunnel.opam +++ b/opam/stunnel.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "astring" "forkexec" {= version} "safe-resources" {= version} @@ -18,6 +18,7 @@ depends: [ "xapi-inventory" "xapi-log" {= version} "xapi-stdext-pervasives" {= version} + "xapi-stdext-std" {= version} "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} "odoc" {with-doc} @@ -37,3 +38,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/tgroup.opam b/opam/tgroup.opam index 423b462887..6080d67b80 100644 --- a/opam/tgroup.opam +++ b/opam/tgroup.opam @@ -6,7 +6,7 @@ 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.15"} + "dune" {>= "3.20"} "xapi-log" "xapi-stdext-unix" "odoc" {with-doc} @@ -26,3 +26,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/uuid.opam b/opam/uuid.opam index c13b0c5ecf..2fbe23bbd5 100644 --- a/opam/uuid.opam +++ b/opam/uuid.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/varstored-guard.opam b/opam/varstored-guard.opam index d98b387a69..4c509a349d 100644 --- a/opam/varstored-guard.opam +++ b/opam/varstored-guard.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "xen-api@lists.xen.org" ] diff --git a/opam/vhd-format-lwt.opam b/opam/vhd-format-lwt.opam index 0c8401f12b..16d3ccdcc8 100644 --- a/opam/vhd-format-lwt.opam +++ b/opam/vhd-format-lwt.opam @@ -16,7 +16,7 @@ tags: ["org:mirage" "org:xapi-project"] homepage: "https://github.com/mirage/ocaml-vhd" bug-reports: "https://github.com/mirage/ocaml-vhd/issues" depends: [ - "dune" {>= "3.15"} + "dune" {>= "3.20"} "ocaml" {>= "4.10.0"} "alcotest" {with-test} "alcotest-lwt" {with-test & >= "1.0.0"} @@ -46,5 +46,6 @@ build: [ ] ] dev-repo: "git+https://github.com/mirage/ocaml-vhd.git" +x-maintenance-intent: ["(latest)"] available: os = "linux" | os = "macos" depexts: ["linux-headers"] {os-distribution = "alpine"} diff --git a/opam/vhd-format.opam b/opam/vhd-format.opam index d24732c35d..842d43d685 100644 --- a/opam/vhd-format.opam +++ b/opam/vhd-format.opam @@ -1,5 +1,5 @@ # This file is generated by dune, edit dune-project instead - +x-maintenance-intent: ["(latest)"] opam-version: "2.0" name: "vhd-format" synopsis: "Pure OCaml library to read/write VHD format data" diff --git a/opam/vhd-tool.opam b/opam/vhd-tool.opam index 14f0c3c30c..a1e4609137 100644 --- a/opam/vhd-tool.opam +++ b/opam/vhd-tool.opam @@ -8,7 +8,7 @@ tags: ["org.mirage" "org:xapi-project"] homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.15"} + "dune" {>= "3.20"} "alcotest-lwt" {with-test} "astring" "bigarray-compat" @@ -57,3 +57,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-cli-protocol.opam b/opam/xapi-cli-protocol.opam index 31150003aa..31f6cdfefa 100644 --- a/opam/xapi-cli-protocol.opam +++ b/opam/xapi-cli-protocol.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "xen-api@lists.xen.org" ] diff --git a/opam/xapi-client.opam b/opam/xapi-client.opam index 76e1eb6718..4ab1b36384 100644 --- a/opam/xapi-client.opam +++ b/opam/xapi-client.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "xen-api@lists.xen.org" ] diff --git a/opam/xapi-compression.opam b/opam/xapi-compression.opam index a6db319460..7d2e829305 100644 --- a/opam/xapi-compression.opam +++ b/opam/xapi-compression.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/xapi-consts.opam b/opam/xapi-consts.opam index 2b4726399e..c164d2e0dd 100644 --- a/opam/xapi-consts.opam +++ b/opam/xapi-consts.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "xen-api@lists.xen.org" ] diff --git a/opam/xapi-datamodel.opam b/opam/xapi-datamodel.opam index 0042c268a2..e2da59cee8 100644 --- a/opam/xapi-datamodel.opam +++ b/opam/xapi-datamodel.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "xen-api@lists.xen.org" ] diff --git a/opam/xapi-debug.opam b/opam/xapi-debug.opam index a2b7d9dd86..26871b97a7 100644 --- a/opam/xapi-debug.opam +++ b/opam/xapi-debug.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "alcotest" "angstrom" "astring" @@ -58,6 +58,7 @@ depends: [ "xapi-types" "xapi-stdext-pervasives" "xapi-stdext-unix" + "xapi-stdext-zerocheck" "xen-api-client" "xen-api-client-lwt" "xenctrl" @@ -81,3 +82,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-expiry-alerts.opam b/opam/xapi-expiry-alerts.opam index e73b3d0f96..02bdf5c728 100644 --- a/opam/xapi-expiry-alerts.opam +++ b/opam/xapi-expiry-alerts.opam @@ -1,5 +1,5 @@ # This file is generated by dune, edit dune-project instead - +x-maintenance-intent: ["(latest)"] opam-version: "2.0" name: "xapi-expiry-alerts" synopsis: "A library to send expiration-related alerts and removing outdated ones" diff --git a/opam/xapi-forkexecd.opam b/opam/xapi-forkexecd.opam index 6f2ccbffdb..97b16555f1 100644 --- a/opam/xapi-forkexecd.opam +++ b/opam/xapi-forkexecd.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "astring" "forkexec" {= version} "uuid" {= version} @@ -31,3 +31,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-idl.opam b/opam/xapi-idl.opam index 4fcdfc6da9..ad3a9e5da6 100644 --- a/opam/xapi-idl.opam +++ b/opam/xapi-idl.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" authors: "Dave Scott" homepage: "https://github.com/xapi-project/xen-api" diff --git a/opam/xapi-inventory.opam b/opam/xapi-inventory.opam index c54eaf6874..74d94d8a84 100644 --- a/opam/xapi-inventory.opam +++ b/opam/xapi-inventory.opam @@ -1,5 +1,5 @@ # This file is generated by dune, edit dune-project instead - +x-maintenance-intent: ["(latest)"] opam-version: "2.0" name: "xapi-inventory" maintainer: "xen-api@lists.xen.org" diff --git a/opam/xapi-log.opam b/opam/xapi-log.opam index d83f9bec7c..4c77faffce 100644 --- a/opam/xapi-log.opam +++ b/opam/xapi-log.opam @@ -1,31 +1,36 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: "xen-api@lists.xen.org" +synopsis: "A Logs library required by xapi" +description: + "This package is provided for backwards compatibility only. No new package should use it." +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.git" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -available: [ os = "linux" ] +bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "ocaml" - "dune" {>= "3.15"} + "dune" {>= "3.20"} "astring" "fmt" "logs" "mtime" "xapi-backtrace" - "xapi-stdext-pervasives" + "xapi-stdext-pervasives" {= version} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] ] -synopsis: "Library required by xapi" -description: """ -These libraries are provided for backwards compatibility only. -No new code should use these libraries.""" -url { - src: - "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} +dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-log.opam.template b/opam/xapi-log.opam.template deleted file mode 100644 index 00b5cce6fd..0000000000 --- a/opam/xapi-log.opam.template +++ /dev/null @@ -1,29 +0,0 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: "xen-api@lists.xen.org" -homepage: "https://xapi-project.github.io/" -bug-reports: "https://github.com/xapi-project/xen-api.git" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -available: [ os = "linux" ] -depends: [ - "ocaml" - "dune" {>= "3.15"} - "astring" - "fmt" - "logs" - "mtime" - "xapi-backtrace" - "xapi-stdext-pervasives" -] -synopsis: "Library required by xapi" -description: """ -These libraries are provided for backwards compatibility only. -No new code should use these libraries.""" -url { - src: - "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} diff --git a/opam/xapi-nbd.opam b/opam/xapi-nbd.opam index da583e6cbd..b39c334a2d 100644 --- a/opam/xapi-nbd.opam +++ b/opam/xapi-nbd.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: ["dave.scott@citrix.com"] diff --git a/opam/xapi-open-uri.opam b/opam/xapi-open-uri.opam index bb080d7549..0823c9c105 100644 --- a/opam/xapi-open-uri.opam +++ b/opam/xapi-open-uri.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/xapi-rrd.opam b/opam/xapi-rrd.opam index 3c5613224f..c38eb5490b 100644 --- a/opam/xapi-rrd.opam +++ b/opam/xapi-rrd.opam @@ -1,5 +1,5 @@ # This file is generated by dune, edit dune-project instead - +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "Xapi project maintainers" authors: ["Dave Scott" "Jon Ludlam" "John Else"] diff --git a/opam/xapi-schema.opam b/opam/xapi-schema.opam index 9a3b702fcd..99d06a4c52 100644 --- a/opam/xapi-schema.opam +++ b/opam/xapi-schema.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "xen-api@lists.xen.org" ] diff --git a/opam/xapi-sdk.opam b/opam/xapi-sdk.opam index 8adccdf293..6c0670995a 100644 --- a/opam/xapi-sdk.opam +++ b/opam/xapi-sdk.opam @@ -7,7 +7,7 @@ license: "BSD-2-Clause" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.15"} + "dune" {>= "3.20"} "alcotest" {with-test} "astring" "fmt" {with-test} @@ -32,3 +32,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-stdext-encodings.opam b/opam/xapi-stdext-encodings.opam index bed359bb9e..cbd1a98db2 100644 --- a/opam/xapi-stdext-encodings.opam +++ b/opam/xapi-stdext-encodings.opam @@ -7,7 +7,7 @@ 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.15"} + "dune" {>= "3.20"} "ocaml" {>= "4.13.0"} "alcotest" {>= "0.6.0" & with-test} "odoc" {with-doc} @@ -30,4 +30,5 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] available: arch != "arm32" & arch != "x86_32" diff --git a/opam/xapi-stdext-pervasives.opam b/opam/xapi-stdext-pervasives.opam index bfab6d693b..8e8ee0c71f 100644 --- a/opam/xapi-stdext-pervasives.opam +++ b/opam/xapi-stdext-pervasives.opam @@ -7,7 +7,7 @@ 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.15"} + "dune" {>= "3.20"} "ocaml" {>= "4.08"} "logs" "odoc" {with-doc} @@ -28,3 +28,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-stdext-std.opam b/opam/xapi-stdext-std.opam index 753fcd696d..b57a3c90a6 100644 --- a/opam/xapi-stdext-std.opam +++ b/opam/xapi-stdext-std.opam @@ -7,7 +7,7 @@ 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.15"} + "dune" {>= "3.20"} "ocaml" {>= "4.08.0"} "alcotest" {with-test} "odoc" {with-doc} @@ -27,3 +27,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-stdext-threads.opam b/opam/xapi-stdext-threads.opam index 55653e588c..34afaf02d2 100644 --- a/opam/xapi-stdext-threads.opam +++ b/opam/xapi-stdext-threads.opam @@ -7,7 +7,7 @@ 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.15"} + "dune" {>= "3.20"} "ambient-context" "base-threads" "base-unix" @@ -36,3 +36,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-stdext-unix.opam b/opam/xapi-stdext-unix.opam index e41eefb9ef..5e9d467f98 100644 --- a/opam/xapi-stdext-unix.opam +++ b/opam/xapi-stdext-unix.opam @@ -7,7 +7,7 @@ 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.15"} + "dune" {>= "3.20"} "ocaml" {>= "4.12.0"} "alcotest" {with-test} "astring" @@ -41,5 +41,6 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] depexts: ["linux-headers"] {os-distribution = "alpine"} available: [ os = "linux" ] diff --git a/opam/xapi-stdext-zerocheck.opam b/opam/xapi-stdext-zerocheck.opam index d20671b901..2d856581f1 100644 --- a/opam/xapi-stdext-zerocheck.opam +++ b/opam/xapi-stdext-zerocheck.opam @@ -7,7 +7,8 @@ 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.15"} + "dune" {>= "3.20"} + "alcotest" {with-test} "odoc" {with-doc} ] build: [ @@ -25,3 +26,4 @@ build: [ ] ] 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 c2e092eb9f..c91efa5261 100644 --- a/opam/xapi-storage-cli.opam +++ b/opam/xapi-storage-cli.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "cmdliner" "re" "rpclib" @@ -17,6 +17,7 @@ depends: [ "xapi-client" {= version} "xapi-idl" {= version} "xapi-types" {= version} + "xapi-stdext-zerocheck" {= version} "odoc" {with-doc} ] build: [ @@ -34,3 +35,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xapi-storage-script.opam b/opam/xapi-storage-script.opam index 3c0e721602..8b1ba65903 100644 --- a/opam/xapi-storage-script.opam +++ b/opam/xapi-storage-script.opam @@ -1,5 +1,5 @@ # This file is generated by dune, edit dune-project instead - +x-maintenance-intent: ["(latest)"] opam-version: "2.0" name: "xapi-storage-script" maintainer: "xen-api@lists.xen.org" diff --git a/opam/xapi-storage.opam b/opam/xapi-storage.opam index f71b424c43..9fcf82b5d1 100644 --- a/opam/xapi-storage.opam +++ b/opam/xapi-storage.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" name: "xapi-storage" maintainer: "xen-api@lists.xen.org" diff --git a/opam/xapi-tools.opam b/opam/xapi-tools.opam index da2e2ce296..1cf69ff6a7 100644 --- a/opam/xapi-tools.opam +++ b/opam/xapi-tools.opam @@ -8,7 +8,7 @@ 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.15"} + "dune" {>= "3.20"} "astring" "base64" "cmdliner" @@ -24,6 +24,7 @@ depends: [ "rpclib" "rresult" "uri" + "tyre" "xenctrl" "xmlm" "yojson" @@ -39,6 +40,7 @@ depends: [ "odoc" {with-doc} ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] build: [ ["./configure"] ["dune" "subst"] {dev} diff --git a/opam/xapi-tracing-export.opam b/opam/xapi-tracing-export.opam index e17845a1d0..a7054f1907 100644 --- a/opam/xapi-tracing-export.opam +++ b/opam/xapi-tracing-export.opam @@ -11,7 +11,7 @@ bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "ocaml" "cohttp-posix" - "dune" {>= "3.15"} + "dune" {>= "3.20"} "cohttp" "ptime" "result" @@ -42,4 +42,5 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] available: [ os = "linux" ] diff --git a/opam/xapi-tracing.opam b/opam/xapi-tracing.opam index f5c0df48bf..b8f3a4bf8a 100644 --- a/opam/xapi-tracing.opam +++ b/opam/xapi-tracing.opam @@ -10,7 +10,7 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "ocaml" - "dune" {>= "3.15"} + "dune" {>= "3.20"} "alcotest" {with-test} "fmt" {with-test} "ppx_deriving_yojson" @@ -37,4 +37,5 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] available: [ os = "linux" ] diff --git a/opam/xapi-types.opam b/opam/xapi-types.opam index 8a417f7099..d09bb87474 100644 --- a/opam/xapi-types.opam +++ b/opam/xapi-types.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "xen-api@lists.xen.org" ] diff --git a/opam/xapi.opam b/opam/xapi.opam index 06380ac4f8..34dd9af3b0 100644 --- a/opam/xapi.opam +++ b/opam/xapi.opam @@ -9,7 +9,7 @@ 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.15"} + "dune" {>= "3.20"} "ocaml" {>= "4.09"} "alcotest" {with-test} "angstrom" @@ -112,6 +112,7 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] depexts: [ ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "debian"} ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "ubuntu"} diff --git a/opam/xe.opam b/opam/xe.opam index 0e3953ccd2..81da07a089 100644 --- a/opam/xe.opam +++ b/opam/xe.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "xen-api@lists.xen.org" ] diff --git a/opam/xen-api-client-lwt.opam b/opam/xen-api-client-lwt.opam index d1c25f04f3..5b1878a367 100644 --- a/opam/xen-api-client-lwt.opam +++ b/opam/xen-api-client-lwt.opam @@ -1,5 +1,5 @@ # This file is generated by dune, edit dune-project instead - +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: [ "David Scott" "Anil Madhavapeddy" "Jerome Maloberti" "John Else" "Jon Ludlam" "Thomas Sanders" "Mike McClurg" ] diff --git a/opam/xen-api-client.opam b/opam/xen-api-client.opam index 7577385132..6dd9061271 100644 --- a/opam/xen-api-client.opam +++ b/opam/xen-api-client.opam @@ -15,7 +15,7 @@ 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.15"} + "dune" {>= "3.20"} "alcotest" {with-test} "astring" "cohttp" {>= "0.22.0"} @@ -45,3 +45,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" +x-maintenance-intent: ["(latest)"] diff --git a/opam/xml-light2.opam b/opam/xml-light2.opam index 5d2cadac09..92f1b47718 100644 --- a/opam/xml-light2.opam +++ b/opam/xml-light2.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/opam/zstd.opam b/opam/zstd.opam index 7a04554f2a..a88183276f 100644 --- a/opam/zstd.opam +++ b/opam/zstd.opam @@ -1,5 +1,6 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +x-maintenance-intent: ["(latest)"] opam-version: "2.0" maintainer: "xen-api@lists.xen.org" authors: "xen-api@lists.xen.org" diff --git a/python3/Makefile b/python3/Makefile index fb13068ca0..3646ad9f54 100644 --- a/python3/Makefile +++ b/python3/Makefile @@ -30,6 +30,7 @@ install: $(IPROG) libexec/mail-alarm $(DESTDIR)$(LIBEXECDIR) $(IPROG) libexec/backup-sr-metadata.py $(DESTDIR)$(LIBEXECDIR) $(IPROG) libexec/restore-sr-metadata.py $(DESTDIR)$(LIBEXECDIR) + $(IPROG) libexec/qcow2-to-stdout.py $(DESTDIR)$(LIBEXECDIR) $(IPROG) bin/hfx_filename $(DESTDIR)$(OPTDIR)/bin $(IPROG) bin/xe-reset-networking $(DESTDIR)$(OPTDIR)/bin diff --git a/python3/bin/perfmon b/python3/bin/perfmon index 58be93284d..c78c891f60 100644 --- a/python3/bin/perfmon +++ b/python3/bin/perfmon @@ -940,11 +940,11 @@ class SRMonitor(ObjectMonitor): num seconds this alarm disabled after an alarm is sent (default '3600') * consolidation_fn: how to combine variables from rrd_updates into one value - (default is 'get_percent_sr_usage' for 'physical_utilistation', + (default is 'get_percent_sr_usage' for 'physical_utilisation', & 'sum' for everything else) * rrd_regex matches the names of variables from (xe sr-data-sources-list uuid=$sruuid) used to compute value - (has default for "physical_utilistaion") + (has default for "physical_utilisation") """ def __init__(self, *args): @@ -975,7 +975,7 @@ class SRMonitor(ObjectMonitor): elif config_tag == "alarm_auto_inhibit_period": return "3600" # 1 hour elif config_tag == "alarm_trigger_level": - if variable_name == "physical_utilistaion": + if variable_name == "physical_utilisation": return "0.8" # trigger when 80% full else: raise XmlConfigException( diff --git a/python3/bin/xe-reset-networking b/python3/bin/xe-reset-networking index 81b3c57286..2802eee3e1 100755 --- a/python3/bin/xe-reset-networking +++ b/python3/bin/xe-reset-networking @@ -24,7 +24,8 @@ pool_conf = '@ETCXENDIR@/pool.conf' inventory_file = '@INVENTORY@' management_conf = '/etc/firstboot.d/data/management.conf' network_reset = '/var/tmp/network-reset' - +RENAME_SCRIPT = '/etc/sysconfig/network-scripts/interface-rename.py' +rename_script_exists = os.path.exists(RENAME_SCRIPT) @contextmanager def fsync_write(filename): @@ -66,6 +67,16 @@ def valid_vlan(vlan): return False return True +def get_bridge_name(device, vlan): + # Construct bridge name for management interface based on convention + # NOTE: Only correct when interface-rename script exists + if vlan != None: + return 'xentemp' + m = re.match(r'^eth(\d+)$', device) + if m: + return 'xenbr' + m.group(1) + return 'br' + device + if __name__ == "__main__": parser = OptionParser() parser.add_option("-m", "--master", help="Master's address", dest="address", default=None) @@ -208,15 +219,9 @@ Type 'no' to cancel. with fsync_write(pool_conf) as f: f.write('slave:' + address) - # Construct bridge name for management interface based on convention - if device[:3] == 'eth': - bridge = 'xenbr' + device[3:] - else: - bridge = 'br' + device - # Ensure xapi is not running print("Stopping xapi...") - os.system('service xapi stop >/dev/null 2>/dev/null') + os.system('systemctl stop xapi >/dev/null 2>/dev/null') # Reconfigure new management interface print("Reconfiguring " + device + "...") @@ -229,10 +234,10 @@ Type 'no' to cancel. # Update interfaces in inventory file print('Updating inventory file...') inventory = read_inventory() - if vlan != None: - inventory['MANAGEMENT_INTERFACE'] = 'xentemp' - else: - inventory['MANAGEMENT_INTERFACE'] = bridge + # If rename script does not exist, needn't to set MANAGEMENT_INTERFACE in inventory file + # Networkd will handle it while replacing the rename script to sort interfaces + bridge = '' if not rename_script_exists else get_bridge_name(device, vlan) + inventory['MANAGEMENT_INTERFACE'] = bridge inventory['CURRENT_INTERFACES'] = '' write_inventory(inventory) @@ -280,11 +285,11 @@ Type 'no' to cancel. f.write('GATEWAY_V6=' + options.gateway_v6 + '\n') if is_static and options.dns != '': f.write('DNS=' + options.dns + '\n') - - # Reset the domain 0 network interface naming configuration - # back to a fresh-install state for the currently-installed - # hardware. - os.system("/etc/sysconfig/network-scripts/interface-rename.py --reset-to-install") + if rename_script_exists: + # Reset the domain 0 network interface naming configuration + # back to a fresh-install state for the currently-installed + # hardware. + os.system(f"{RENAME_SCRIPT} --reset-to-install") # Reboot os.system("mount -o remount,rw / && reboot -f") diff --git a/python3/libexec/qcow2-to-stdout.py b/python3/libexec/qcow2-to-stdout.py new file mode 100755 index 0000000000..b0638bc590 --- /dev/null +++ b/python3/libexec/qcow2-to-stdout.py @@ -0,0 +1,422 @@ +#!/usr/bin/env python3 + +# This tool reads a disk image in any format and converts it to qcow2, +# writing the result directly to stdout. +# +# Copyright (C) 2024 Igalia, S.L. +# +# Authors: Alberto Garcia +# Madeeha Javed +# +# SPDX-License-Identifier: GPL-2.0-or-later +# +# qcow2 files produced by this script are always arranged like this: +# +# - qcow2 header +# - refcount table +# - refcount blocks +# - L1 table +# - L2 tables +# - Data clusters +# +# A note about variable names: in qcow2 there is one refcount table +# and one (active) L1 table, although each can occupy several +# clusters. For the sake of simplicity the code sometimes talks about +# refcount tables and L1 tables when referring to those clusters. + +import argparse +import math +import os +import struct +import sys + +QCOW2_DEFAULT_CLUSTER_SIZE = 65536 +QCOW2_DEFAULT_REFCOUNT_BITS = 16 +QCOW2_FEATURE_NAME_TABLE = 0x6803F857 +QCOW2_DATA_FILE_NAME_STRING = 0x44415441 +QCOW2_V3_HEADER_LENGTH = 112 # Header length in QEMU 9.0. Must be a multiple of 8 +QCOW2_INCOMPAT_DATA_FILE_BIT = 2 +QCOW2_AUTOCLEAR_DATA_FILE_RAW_BIT = 1 +QCOW_OFLAG_COPIED = 1 << 63 + + +def bitmap_set(bitmap, idx): + bitmap[idx // 8] |= 1 << (idx % 8) + + +def bitmap_is_set(bitmap, idx): + return (bitmap[idx // 8] & (1 << (idx % 8))) != 0 + + +def bitmap_iterator(bitmap, length): + for idx in range(length): + if bitmap_is_set(bitmap, idx): + yield idx + + +def align_up(num, d): + return d * math.ceil(num / d) + + +def write_features(cluster, offset, data_file_name): + if data_file_name is not None: + encoded_name = data_file_name.encode("utf-8") + padded_name_len = align_up(len(encoded_name), 8) + struct.pack_into(f">II{padded_name_len}s", cluster, offset, + QCOW2_DATA_FILE_NAME_STRING, + len(encoded_name), + encoded_name) + offset += 8 + padded_name_len + + qcow2_features = [ + # Incompatible + (0, 0, "dirty bit"), + (0, 1, "corrupt bit"), + (0, 2, "external data file"), + (0, 3, "compression type"), + (0, 4, "extended L2 entries"), + # Compatible + (1, 0, "lazy refcounts"), + # Autoclear + (2, 0, "bitmaps"), + (2, 1, "raw external data"), + ] + struct.pack_into(">I", cluster, offset, QCOW2_FEATURE_NAME_TABLE) + struct.pack_into(">I", cluster, offset + 4, len(qcow2_features) * 48) + offset += 8 + for feature_type, feature_bit, feature_name in qcow2_features: + struct.pack_into(">BB46s", cluster, offset, + feature_type, feature_bit, feature_name.encode("ascii")) + offset += 48 + + +def write_qcow2_content(input_file, cluster_size, refcount_bits, + data_file_name, data_file_raw, diff_file_name): + # Some basic values + l1_entries_per_table = cluster_size // 8 + l2_entries_per_table = cluster_size // 8 + refcounts_per_table = cluster_size // 8 + refcounts_per_block = cluster_size * 8 // refcount_bits + + # Open the input file for reading + fd = os.open(input_file, os.O_RDONLY) + + # Virtual disk size, number of data clusters and L1 entries + block_device_size = os.lseek(fd, 0, os.SEEK_END) + disk_size = align_up(block_device_size, 512) + total_data_clusters = math.ceil(disk_size / cluster_size) + l1_entries = math.ceil(total_data_clusters / l2_entries_per_table) + allocated_l1_tables = math.ceil(l1_entries / l1_entries_per_table) + + # Max L1 table size is 32 MB (QCOW_MAX_L1_SIZE in block/qcow2.h) + if (l1_entries * 8) > (32 * 1024 * 1024): + sys.exit("[Error] The image size is too large. Try using a larger cluster size.") + + # Two bitmaps indicating which L1 and L2 entries are set + l1_bitmap = bytearray(allocated_l1_tables * l1_entries_per_table // 8) + l2_bitmap = bytearray(l1_entries * l2_entries_per_table // 8) + allocated_l2_tables = 0 + allocated_data_clusters = 0 + + if data_file_raw: + # If data_file_raw is set then all clusters are allocated and + # we don't need to read the input file at all. + allocated_l2_tables = l1_entries + for idx in range(l1_entries): + bitmap_set(l1_bitmap, idx) + for idx in range(total_data_clusters): + bitmap_set(l2_bitmap, idx) + else: + # Allocates a cluster in the appropriate bitmaps if it's different + # from cluster_to_compare_with + def check_cluster_allocate(idx, cluster, cluster_to_compare_with): + nonlocal allocated_data_clusters + nonlocal allocated_l2_tables + # If the last cluster is smaller than cluster_size pad it with zeroes + if len(cluster) < cluster_size: + cluster += bytes(cluster_size - len(cluster)) + # If a cluster has different data from the cluster_to_compare_with then it + # must be allocated in the output file and its L2 entry must be set + if cluster != cluster_to_compare_with: + bitmap_set(l2_bitmap, idx) + allocated_data_clusters += 1 + # Allocated data clusters also need their corresponding L1 entry and L2 table + l1_idx = math.floor(idx / l2_entries_per_table) + if not bitmap_is_set(l1_bitmap, l1_idx): + bitmap_set(l1_bitmap, l1_idx) + allocated_l2_tables += 1 + + zero_cluster = bytes(cluster_size) + last_cluster = align_up(block_device_size, cluster_size) // cluster_size + if diff_file_name: + # Read all the clusters that differ from the diff_file_name + diff_fd = os.open(diff_file_name, os.O_RDONLY) + diff_block_device_size = os.lseek(diff_fd, 0, os.SEEK_END) + last_diff_cluster = align_up(diff_block_device_size, cluster_size) // cluster_size + # In case input_file is bigger than diff_file_name, first check + # if clusters from diff_file_name differ, and then check if the + # rest contain data + for idx in range(0, last_diff_cluster): + cluster = os.pread(fd, cluster_size, cluster_size * idx) + original_cluster = os.pread(diff_fd, cluster_size, cluster_size * idx) + + # If a cluster has different data from the original_cluster + # then it must be allocated + check_cluster_allocate(idx, cluster, original_cluster) + for idx in range(last_diff_cluster, last_cluster): + cluster = os.pread(fd, cluster_size, cluster_size * idx) + + # If a cluster has different data from the original_cluster + # then it must be allocated + check_cluster_allocate(idx, cluster, zero_cluster) + else: + # Read all the clusters that contain data + for idx in range(0, last_cluster): + cluster = os.pread(fd, cluster_size, cluster_size * idx) + # If a cluster has non-zero data then it must be allocated + check_cluster_allocate(idx, cluster, zero_cluster) + + # Total amount of allocated clusters excluding the refcount blocks and table + total_allocated_clusters = 1 + allocated_l1_tables + allocated_l2_tables + if data_file_name is None: + total_allocated_clusters += allocated_data_clusters + + # Clusters allocated for the refcount blocks and table + allocated_refcount_blocks = math.ceil(total_allocated_clusters / refcounts_per_block) + allocated_refcount_tables = math.ceil(allocated_refcount_blocks / refcounts_per_table) + + # Now we have a problem because allocated_refcount_blocks and allocated_refcount_tables... + # (a) increase total_allocated_clusters, and + # (b) need to be recalculated when total_allocated_clusters is increased + # So we need to repeat the calculation as long as the numbers change + while True: + new_total_allocated_clusters = total_allocated_clusters + allocated_refcount_tables + allocated_refcount_blocks + new_allocated_refcount_blocks = math.ceil(new_total_allocated_clusters / refcounts_per_block) + if new_allocated_refcount_blocks > allocated_refcount_blocks: + allocated_refcount_blocks = new_allocated_refcount_blocks + allocated_refcount_tables = math.ceil(allocated_refcount_blocks / refcounts_per_table) + else: + break + + # Now that we have the final numbers we can update total_allocated_clusters + total_allocated_clusters += allocated_refcount_tables + allocated_refcount_blocks + + # At this point we have the exact number of clusters that the output + # image is going to use so we can calculate all the offsets. + current_cluster_idx = 1 + + refcount_table_offset = current_cluster_idx * cluster_size + current_cluster_idx += allocated_refcount_tables + + refcount_block_offset = current_cluster_idx * cluster_size + current_cluster_idx += allocated_refcount_blocks + + l1_table_offset = current_cluster_idx * cluster_size + current_cluster_idx += allocated_l1_tables + + l2_table_offset = current_cluster_idx * cluster_size + current_cluster_idx += allocated_l2_tables + + data_clusters_offset = current_cluster_idx * cluster_size + + # Calculate some values used in the qcow2 header + if allocated_l1_tables == 0: + l1_table_offset = 0 + + hdr_cluster_bits = int(math.log2(cluster_size)) + hdr_refcount_bits = int(math.log2(refcount_bits)) + hdr_length = QCOW2_V3_HEADER_LENGTH + hdr_incompat_features = 0 + if data_file_name is not None: + hdr_incompat_features |= 1 << QCOW2_INCOMPAT_DATA_FILE_BIT + hdr_autoclear_features = 0 + if data_file_raw: + hdr_autoclear_features |= 1 << QCOW2_AUTOCLEAR_DATA_FILE_RAW_BIT + + ### Write qcow2 header + cluster = bytearray(cluster_size) + struct.pack_into(">4sIQIIQIIQQIIQQQQII", cluster, 0, + b"QFI\xfb", # QCOW magic string + 3, # version + 0, # backing file offset + 0, # backing file sizes + hdr_cluster_bits, + disk_size, + 0, # encryption method + l1_entries, + l1_table_offset, + refcount_table_offset, + allocated_refcount_tables, + 0, # number of snapshots + 0, # snapshot table offset + hdr_incompat_features, + 0, # compatible features + hdr_autoclear_features, + hdr_refcount_bits, + hdr_length, + ) + + write_features(cluster, hdr_length, data_file_name) + + sys.stdout.buffer.write(cluster) + + ### Write refcount table + cur_offset = refcount_block_offset + remaining_refcount_table_entries = allocated_refcount_blocks # Each entry is a pointer to a refcount block + while remaining_refcount_table_entries > 0: + cluster = bytearray(cluster_size) + to_write = min(remaining_refcount_table_entries, refcounts_per_table) + remaining_refcount_table_entries -= to_write + for idx in range(to_write): + struct.pack_into(">Q", cluster, idx * 8, cur_offset) + cur_offset += cluster_size + sys.stdout.buffer.write(cluster) + + ### Write refcount blocks + remaining_refcount_block_entries = total_allocated_clusters # One entry for each allocated cluster + for tbl in range(allocated_refcount_blocks): + cluster = bytearray(cluster_size) + to_write = min(remaining_refcount_block_entries, refcounts_per_block) + remaining_refcount_block_entries -= to_write + # All refcount entries contain the number 1. The only difference + # is their bit width, defined when the image is created. + for idx in range(to_write): + if refcount_bits == 64: + struct.pack_into(">Q", cluster, idx * 8, 1) + elif refcount_bits == 32: + struct.pack_into(">L", cluster, idx * 4, 1) + elif refcount_bits == 16: + struct.pack_into(">H", cluster, idx * 2, 1) + elif refcount_bits == 8: + cluster[idx] = 1 + elif refcount_bits == 4: + cluster[idx // 2] |= 1 << ((idx % 2) * 4) + elif refcount_bits == 2: + cluster[idx // 4] |= 1 << ((idx % 4) * 2) + elif refcount_bits == 1: + cluster[idx // 8] |= 1 << (idx % 8) + sys.stdout.buffer.write(cluster) + + ### Write L1 table + cur_offset = l2_table_offset + for tbl in range(allocated_l1_tables): + cluster = bytearray(cluster_size) + for idx in range(l1_entries_per_table): + l1_idx = tbl * l1_entries_per_table + idx + if bitmap_is_set(l1_bitmap, l1_idx): + struct.pack_into(">Q", cluster, idx * 8, cur_offset | QCOW_OFLAG_COPIED) + cur_offset += cluster_size + sys.stdout.buffer.write(cluster) + + ### Write L2 tables + cur_offset = data_clusters_offset + for tbl in range(l1_entries): + # Skip the empty L2 tables. We can identify them because + # there is no L1 entry pointing at them. + if bitmap_is_set(l1_bitmap, tbl): + cluster = bytearray(cluster_size) + for idx in range(l2_entries_per_table): + l2_idx = tbl * l2_entries_per_table + idx + if bitmap_is_set(l2_bitmap, l2_idx): + if data_file_name is None: + struct.pack_into(">Q", cluster, idx * 8, cur_offset | QCOW_OFLAG_COPIED) + cur_offset += cluster_size + else: + struct.pack_into(">Q", cluster, idx * 8, (l2_idx * cluster_size) | QCOW_OFLAG_COPIED) + sys.stdout.buffer.write(cluster) + + ### Write data clusters + if data_file_name is None: + for idx in bitmap_iterator(l2_bitmap, total_data_clusters): + cluster = os.pread(fd, cluster_size, cluster_size * idx) + # If the last cluster is smaller than cluster_size pad it with zeroes + if len(cluster) < cluster_size: + cluster += bytes(cluster_size - len(cluster)) + sys.stdout.buffer.write(cluster) + + if not data_file_raw: + os.close(fd) + + +def main(): + # Command-line arguments + parser = argparse.ArgumentParser( + description="This program converts a QEMU disk image to qcow2 " + "and writes it to the standard output" + ) + parser.add_argument("input_file", help="name of the input file") + parser.add_argument( + "--diff", + dest="diff_file_name", + metavar="diff_file_name", + help=("name of the original file to compare input_file against. " + "If specified, will only export clusters that are different " + "between the files"), + default=None, + ) + parser.add_argument( + "-c", + dest="cluster_size", + metavar="cluster_size", + help=f"qcow2 cluster size (default: {QCOW2_DEFAULT_CLUSTER_SIZE})", + default=QCOW2_DEFAULT_CLUSTER_SIZE, + type=int, + choices=[1 << x for x in range(9, 22)], + ) + parser.add_argument( + "-r", + dest="refcount_bits", + metavar="refcount_bits", + help=f"width of the reference count entries (default: {QCOW2_DEFAULT_REFCOUNT_BITS})", + default=QCOW2_DEFAULT_REFCOUNT_BITS, + type=int, + choices=[1 << x for x in range(7)], + ) + parser.add_argument( + "-d", + dest="data_file", + help="create an image with input_file as an external data file", + action="store_true", + ) + parser.add_argument( + "-R", + dest="data_file_raw", + help="enable data_file_raw on the generated image (implies -d)", + action="store_true", + ) + args = parser.parse_args() + + if args.data_file_raw: + args.data_file = True + + if not os.path.exists(args.input_file): + sys.exit(f"[Error] {args.input_file} does not exist.") + + if args.diff_file_name and not os.path.exists(args.diff_file_name): + sys.exit(f"[Error] {args.diff_file_name} does not exist.") + + # A 512 byte header is too small for the data file name extension + if args.data_file and args.cluster_size == 512: + sys.exit("[Error] External data files require a larger cluster size") + + if sys.stdout.isatty(): + sys.exit("[Error] Refusing to write to a tty. Try redirecting stdout.") + + if args.data_file: + data_file_name = args.input_file + else: + data_file_name = None + + write_qcow2_content( + args.input_file, + args.cluster_size, + args.refcount_bits, + data_file_name, + args.data_file_raw, + args.diff_file_name + ) + + +if __name__ == "__main__": + main() + diff --git a/python3/libexec/usb_reset.py b/python3/libexec/usb_reset.py index 573936ae1c..941259d618 100755 --- a/python3/libexec/usb_reset.py +++ b/python3/libexec/usb_reset.py @@ -19,41 +19,40 @@ # ./usb_reset.py attach 2-2 -d 12 -p 4130 # ./usb_reset.py attach 2-2 -d 12 -p 4130 -r # 1. reset device -# if without -r, do step 2~4 +# if without -r, do step 2~3 # 2. if it's the first USB device to pass-through -# a) bind mount /dev /sys in chroot directory (/var/xen/qemu/root-) -# b) create new cgroup devices:/qemu-, -# c) blacklist all and add default device whitelist, -# d) join current qemu process to this cgroup -# 3. save device uid/gid to /var/run/nonpersistent/usb/ -# 4. set device file uid/gid to (qemu_base + dom-id) -# 5. add current device to whitelist +# a) bind mount /sys in chroot directory (/var/xen/qemu/root-) +# b) clone (create the device with same major/minor number and mode) +# in chroot directory with same path +# c) bind mount /proc/ to chroot directory (/var/xen/qemu/root-/proc/self) +# 3. set device file uid/gid to (qemu_base + dom-id) # # detach # ./usb_reset.py detach device -d dom-id # ./usb_reset.py detach 2-2 -d 12 -# 1. restore device file uid/gid from /var/run/nonpersistent/usb/ -# 2. remove current device from whitelist +# 1. Remove the cloned device file in chroot directory +# 2. Umount /proc/self from chroot directory if it is mounted # # cleanup # ./usb_reset.py cleanup -d dom-id # ./usb_reset.py cleanup -d 12 -# 1.remove the cgroup if one has been created. -# 2.umount /dev, /sys from chroot directory if they are mounted. +# 1.umount /sys from chroot directory if they are mounted. +# 2.umount /proc/self from chroot directory if they are mounted. +# 3.remove /dev/bus directory in chroot directory if it exists import argparse import ctypes import ctypes.util -import errno import fcntl import grp -import xcp.logger as log # pytype: disable=import-error import logging import os import pwd import re -from stat import S_ISCHR, S_ISBLK +import shutil +import sys +import xcp.logger as log # pytype: disable=import-error def parse_arg(): parser = argparse.ArgumentParser( @@ -85,56 +84,6 @@ def get_root_dir(domid): return "/var/xen/qemu/root-{}".format(domid) -def get_cg_dir(domid): - return "/sys/fs/cgroup/devices/qemu-{}".format(domid) - - -def get_ids_path(device): - usb_dir = "/var/run/nonpersistent/usb" - try: - os.makedirs(usb_dir) - except OSError as e: - if e.errno != errno.EEXIST: - raise - - return os.path.join(usb_dir, device) - - -def save_device_ids(device): - path = dev_path(device) - - try: - stat = os.stat(path) - ids_info = "{} {}".format(stat.st_uid, stat.st_gid) - except OSError as e: - log.error("Failed to stat {}: {}".format(path, str(e))) - exit(1) - - try: - with open(get_ids_path(device), "w") as f: - f.write(ids_info) - except IOError as e: - log.error("Failed to save device ids {}: {}".format(path, str(e))) - exit(1) - - -def load_device_ids(device): - ids_path = get_ids_path(device) - try: - with open(ids_path) as f: - uid, gid = list(map(int, f.readline().split())) - except (IOError, ValueError) as e: - log.error("Failed to load device ids: {}".format(str(e))) - - try: - os.remove(ids_path) - except OSError as e: - # ignore and continue - log.warning("Failed to remove device ids: {}".format(str(e))) - - return uid, gid # pyright: ignore[reportPossiblyUnboundVariable] # pragma: no cover - - # throw IOError, ValueError def read_int(path): with open(path) as f: @@ -147,117 +96,14 @@ def dev_path(device): pat = re.compile(r"\d+-\d+(\.\d+)*$") if pat.match(device) is None: log.error("Unexpected device node: {}".format(device)) - exit(1) + sys.exit(1) try: bus = read_int("/sys/bus/usb/devices/{}/busnum".format(device)) dev = read_int("/sys/bus/usb/devices/{}/devnum".format(device)) return "/dev/bus/usb/{0:03d}/{1:03d}".format(bus, dev) except (IOError, ValueError) as e: log.error("Failed to get device path {}: {}".format(device, str(e))) - exit(1) - - -def get_ctl(path, mode): # type:(str, str) -> str - """get the string to control device access for cgroup - :param path: the device file path - :param mode: either "r" or "rw" - :return: the string to control device access - """ - try: - st = os.stat(path) - except OSError as e: - log.error("Failed to get stat of {}: {}".format(path, str(e))) - raise - - t = "" - if S_ISBLK(st.st_mode): - t = "b" - elif S_ISCHR(st.st_mode): - t = "c" - if t and mode in ("r", "rw"): - return "{} {}:{} {}".format(t, os.major(st.st_rdev), os.minor( - st.st_rdev), mode) - raise RuntimeError("Failed to get control string of {}".format(path)) - - -def _device_ctl(path, domid, allow): - cg_dir = get_cg_dir(domid) - file_name = "/devices.allow" if allow else "/devices.deny" - try: - with open(cg_dir + file_name, "w") as f: - f.write(get_ctl(path, "rw")) - except (IOError, OSError, RuntimeError) as e: - log.error("Failed to {} {}: {}".format( - "allow" if allow else "deny", path, str(e))) - exit(1) - - -def allow_device(path, domid): - _device_ctl(path, domid, True) - - -def deny_device(path, domid): - _device_ctl(path, domid, False) - - -def setup_cgroup(domid, pid): # type:(str, str) -> None - """ - Associate the given process id (pid) with the given Linux kernel control group - and limit it's device access to only /dev/null. - - :param domid (str): The control group ID string (passed on from the command line) - :param pid (str): The process ID string (passed on from the command line) - - If the control group directory does not exist yet, the control group is created. - - - The pid goes into the file "tasks" to associate the process with the cgroup. - - Deny device access by default by writing "a" to devices.deny. - - Grant read-write access to /dev/null, writing it's device IDs to devices.allow. - - If any error occur during the setup process, the error is logged and - the program exits with a status code of 1. - """ - cg_dir = get_cg_dir(domid) - - try: - os.mkdir(cg_dir, 0o755) - except OSError as e: - if e.errno != errno.EEXIST: - log.error("Failed to create cgroup: {}".format(cg_dir)) - exit(1) - - try: - # unbuffered write to ensure each one is flushed immediately - # to the kernel's control group filesystem: - # - # The order of writes is likely not important, but the writes - # may have to be a single write() system call for the entire string. - # - # Using the unbuffered Raw IO mode, we know the write was done - # in exactly this way by the write function call itself, not later. - # - # With small writes like this , splitting them because of overflowing the - # buffer is not expected to happen. To stay safe and keep using unbuffered I/O - # We have to migrate to binary mode in python3,as python3 supports unbuffered - # raw I/O in binary mode. - # - with open(cg_dir + "/tasks", "wb", 0) as tasks, \ - open(cg_dir + "/devices.deny", "wb", 0) as deny, \ - open(cg_dir + "/devices.allow", "wb", 0) as allow: - - # deny all - deny.write(b"a") - - # To write bytes, we've to encode the strings to bytes below: - - # grant rw access to /dev/null by default - allow.write(get_ctl("/dev/null", "rw").encode()) - - tasks.write(str(pid).encode()) - - except (IOError, OSError, RuntimeError) as e: - log.error("Failed to setup cgroup: {}".format(str(e))) - exit(1) + sys.exit(1) def mount(source, target, fs, flags=0): @@ -266,7 +112,7 @@ def mount(source, target, fs, flags=0): log.error("Failed to mount {} ({}) to {} with flags {}: {}". format(source, fs, target, flags, os.strerror(ctypes.get_errno()))) - exit(1) + sys.exit(1) def umount(target): @@ -277,6 +123,42 @@ def umount(target): format(target, os.strerror(ctypes.get_errno()))) +def clone_device(path, root_dir, domid): + """ + Clone the device file into the chroot directory. + + :param path: The source device file under system /dev to clone. + :param root_dir: The root directory of the chroot environment. + :param domid: The domain ID of the VM, used to set the device file's uid/gid. + """ + target_path = os.path.join(root_dir, path.lstrip(os.path.sep)) + if os.path.exists(target_path): + log.info("Device file {} already exists in chroot".format(target_path)) + return + + os.makedirs(os.path.dirname(target_path), exist_ok=True, mode=0o755) + + try: + st = os.stat(path) + except OSError as e: + log.error("Failed to get stat of {}: {}".format(path, str(e))) + sys.exit(1) + + mode = st.st_mode + major = os.major(st.st_rdev) + minor = os.minor(st.st_rdev) + clone_device_id = os.makedev(major, minor) + os.mknod(target_path, mode, clone_device_id) + + # set device file uid/gid + try: + os.chown(target_path, pwd.getpwnam("qemu_base").pw_uid + domid, + grp.getgrnam("qemu_base").gr_gid + domid) + except OSError as e: + log.error("Failed to chown device file {}: {}".format(path, str(e))) + sys.exit(1) + + def attach(device, domid, pid, reset_only): path = dev_path(device) @@ -293,76 +175,53 @@ def attach(device, domid, pid, reset_only): if reset_only: return - save_device_ids(device) - - # set device file uid/gid - try: - os.chown(path, pwd.getpwnam("qemu_base").pw_uid + domid, - grp.getgrnam("qemu_base").gr_gid + domid) - except OSError as e: - log.error("Failed to chown device file {}: {}".format(path, str(e))) - exit(1) - root_dir = get_root_dir(domid) dev_dir = root_dir + "/dev" if not os.path.isdir(root_dir) or not os.path.isdir(dev_dir): log.error("Error: The chroot or dev directory doesn't exist") - exit(1) + sys.exit(1) - if not os.path.isdir(dev_dir + "/bus"): - # first USB device to pass-through - MS_BIND = 4096 # mount flags, from fs.h - mount("/dev", dev_dir, "", MS_BIND) - setup_cgroup(domid, pid) + clone_device(path, root_dir, domid) sys_dir = root_dir + "/sys" + proc_dir = root_dir + "/proc" # sys_dir could already be mounted because of PCI pass-through - if not os.path.isdir(sys_dir): - try: - os.mkdir(sys_dir, 0o755) - except OSError: - log.error("Failed to create sys dir in chroot") - exit(1) + os.makedirs(sys_dir, exist_ok=True, mode=0o755) if not os.path.isdir(sys_dir + "/devices"): mount("/sys", sys_dir, "sysfs") - # add device to cgroup allow list - allow_device(path, domid) + self_dir = os.path.join(proc_dir, "self") + os.makedirs(self_dir , exist_ok=True, mode=0o755) + fd_dir = os.path.join(self_dir, "fd") + if not os.path.isdir(fd_dir): + MS_BIND = 4096 # mount flags, from fs.h + mount(f"/proc/{pid}/", self_dir, "", MS_BIND) def detach(device, domid): path = dev_path(device) - uid, gid = load_device_ids(device) - - # restore uid, gid of the device file. - try: - os.chown(path, uid, gid) - except OSError as e: - log.error("Failed to chown device file {}: {}".format(path, str(e))) - exit(1) - - # remove device from cgroup allow list - deny_device(path, domid) + root_dir = get_root_dir(domid) + target_path = os.path.join(root_dir, path.lstrip(os.path.sep)) + os.remove(target_path) def cleanup(domid): - # remove the cgroup if one has been created. - if os.path.isdir(get_cg_dir(domid)): - try: - os.rmdir(get_cg_dir(domid)) - except OSError as e: - # log and continue - log.error("Failed to remove cgroup qemu-{}: {}" - .format(domid, str(e))) - # umount /dev, /sys from chroot directory if they are mounted. root_dir = get_root_dir(domid) dev_dir = root_dir + "/dev" sys_dir = root_dir + "/sys" - if os.path.isdir(dev_dir + "/bus"): - umount(dev_dir) + bus_dir = dev_dir + "/bus" + proc_dir = root_dir + "/proc" + self_dir = proc_dir + "/self" + if os.path.isdir(bus_dir): + log.info("Removing bus directory: {} for cleanup".format(bus_dir)) + shutil.rmtree(bus_dir) if os.path.isdir(sys_dir + "/devices"): umount(sys_dir) + if os.path.exists(sys_dir) and os.path.ismount(self_dir): + umount(self_dir) + log.info("Removing proc directory: {} for cleanup".format(proc_dir)) + shutil.rmtree(proc_dir) if __name__ == "__main__": @@ -378,4 +237,4 @@ def cleanup(domid): cleanup(arg.domid) else: log.error("Unexpected command: {}".format(arg.command)) - exit(1) + sys.exit(1) diff --git a/python3/libexec/usb_scan.py b/python3/libexec/usb_scan.py index 03d89f7bae..15888a25df 100755 --- a/python3/libexec/usb_scan.py +++ b/python3/libexec/usb_scan.py @@ -421,6 +421,10 @@ def parse_line(self, line): :param line: (str) single line of policy file :return: None """ + # 0. skip empty lines + if line.strip() == '': + return + # 1. remove comments # ^([^#]*)(#.*)?$ i = line.find("#") diff --git a/python3/perfmon/perfmon b/python3/perfmon/perfmon index 9f26f998fd..19d6564cc0 100644 --- a/python3/perfmon/perfmon +++ b/python3/perfmon/perfmon @@ -26,19 +26,6 @@ def send_perfmon_cmd(cmd): return str(rc == len(cmd_bytes)) - -def stop(session, args): - rc = os.system("/etc/init.d/perfmon stop &>/dev/null") - return str(rc == 0) - -def start(session, args): - rc = os.system("/etc/init.d/perfmon start &>/dev/null") - return str(rc == 0) - -def restart(session, args): - rc = os.system("/etc/init.d/perfmon restart &>/dev/null") - return str(rc == 0) - def refresh(session, args): return send_perfmon_cmd("refresh") @@ -46,4 +33,4 @@ def debug_mem(session,args): return send_perfmon_cmd("debug_mem") if __name__ == "__main__": - XenAPIPlugin.dispatch({"stop": stop, "start": start, "restart": restart, "refresh": refresh, "debug_mem": debug_mem}) + XenAPIPlugin.dispatch({"refresh": refresh, "debug_mem": debug_mem}) diff --git a/python3/tests/import_helper.py b/python3/tests/import_helper.py index 2fdbd922b9..6e1c594655 100644 --- a/python3/tests/import_helper.py +++ b/python3/tests/import_helper.py @@ -5,7 +5,7 @@ from types import ModuleType from typing import Generator -from mock import Mock +from unittest.mock import MagicMock @contextmanager @@ -28,7 +28,7 @@ def mocked_modules(*module_names: str) -> Generator[None, None, None]: ``` """ for module_name in module_names: - sys.modules[module_name] = Mock() + sys.modules[module_name] = MagicMock() yield for module_name in module_names: sys.modules.pop(module_name) diff --git a/python3/tests/test_perfmon.py b/python3/tests/test_perfmon.py index c133a1171a..98d99a1428 100644 --- a/python3/tests/test_perfmon.py +++ b/python3/tests/test_perfmon.py @@ -427,6 +427,14 @@ def test_process_rrd_updates(self, mock_xapisession): # get_percent_sr_usage([500, 6000]) self.assertAlmostEqual(monitor.variables[0].value, 0.08333333333333333) + def test_alarm_trigger_level_physical_utilisation(self, _mock_xapisession): + uuid = 'e1ae3f5d-4c8b-4575-bbb8-2af7e8a2c31e' + monitor = perfmon.SRMonitor(uuid) + result = monitor.get_default_variable_config( + variable_name = "physical_utilisation", + config_tag = "alarm_trigger_level", + ) + self.assertEqual(result, '0.8') class TestRRDUpdates(unittest.TestCase): '''Test Class RRDUpdates and RRDContentHandler''' diff --git a/python3/tests/test_usb_reset.py b/python3/tests/test_usb_reset.py new file mode 100644 index 0000000000..43dae790cb --- /dev/null +++ b/python3/tests/test_usb_reset.py @@ -0,0 +1,109 @@ +import unittest +from unittest import mock +from unittest.mock import MagicMock +import sys + +# some mocked arguemtn is not used in the tests, but as side-effects +# disabled pylint warning for unused arguments +# pylint: disable=unused-argument + +from python3.tests.import_helper import import_file_as_module +# mock modules to avoid dependencies +sys.modules["xcp"] = MagicMock() +sys.modules["xcp.logger"] = MagicMock() +usb_reset = import_file_as_module("python3/libexec/usb_reset.py") + + +class TestUsbReset(unittest.TestCase): + @mock.patch("usb_reset.open", new_callable=mock.mock_open, read_data="5\n") + def test_read_int(self, mock_open): + self.assertEqual(usb_reset.read_int("/fake/path"), 5) + mock_open.assert_called_with("/fake/path") + + @mock.patch("usb_reset.read_int", side_effect=[1, 2]) + @mock.patch("usb_reset.log") + def test_dev_path_valid(self, mock_log, mock_read_int): + device = "1-2.3" + path = usb_reset.dev_path(device) + self.assertEqual(path, "/dev/bus/usb/001/002") + mock_log.error.assert_not_called() + + @mock.patch("usb_reset.log") + def test_dev_path_invalid(self, mock_log): + with self.assertRaises(SystemExit): + usb_reset.dev_path("invalid-device") + mock_log.error.assert_called() + + @mock.patch("usb_reset.ctypes.CDLL") + @mock.patch("usb_reset.ctypes.util.find_library", return_value="libc.so.6") + @mock.patch("usb_reset.log") + def test_mount_success(self, mock_log, mock_find_lib, mock_cdll): + mock_cdll.return_value.mount.return_value = 0 + usb_reset.mount("src", "tgt", "fs") + mock_cdll.return_value.mount.assert_called() + + @mock.patch("usb_reset.ctypes.CDLL") + @mock.patch("usb_reset.ctypes.util.find_library", return_value="libc.so.6") + @mock.patch("usb_reset.log") + def test_mount_fail(self, mock_log, mock_find_lib, mock_cdll): + mock_cdll.return_value.mount.return_value = -1 + with self.assertRaises(SystemExit): + usb_reset.mount("src", "tgt", "fs") + mock_log.error.assert_called() + + @mock.patch("usb_reset.ctypes.CDLL") + @mock.patch("usb_reset.ctypes.util.find_library", return_value="libc.so.6") + @mock.patch("usb_reset.log") + def test_umount(self, mock_log, mock_find_lib, mock_cdll): + mock_cdll.return_value.umount.return_value = -1 + usb_reset.umount("tgt") + mock_log.error.assert_called() + + @mock.patch("usb_reset.os") + @mock.patch("usb_reset.pwd.getpwnam") + @mock.patch("usb_reset.grp.getgrnam") + @mock.patch("usb_reset.log") + def test_clone_device(self, mock_log, mock_grp, mock_pwd, mock_os): + mock_os.path.exists.return_value = False + mock_os.path.sep = "/" + mock_os.stat.return_value.st_mode = 0o600 + mock_os.stat.return_value.st_rdev = 0 + mock_os.major.return_value = 1 + mock_os.minor.return_value = 2 + mock_os.makedev.return_value = 1234 + mock_pwd.return_value.pw_uid = 1000 + mock_grp.return_value.gr_gid = 1000 + usb_reset.clone_device("/dev/bus/usb/001/002", "/root", 1) + mock_os.mknod.assert_called() + mock_os.chown.assert_called() + + @mock.patch("usb_reset.dev_path", return_value="/dev/bus/usb/001/002") + @mock.patch("usb_reset.open", new_callable=mock.mock_open) + @mock.patch("usb_reset.fcntl.ioctl") + @mock.patch("usb_reset.log") + def test_attach_reset_only(self, mock_log, mock_ioctl, mock_open, mock_dev_path): + usb_reset.attach("1-2", 1, 123, True) + mock_open.assert_called() + mock_ioctl.assert_called() + + @mock.patch("usb_reset.dev_path", return_value="/dev/bus/usb/001/002") + @mock.patch("usb_reset.os.remove") + @mock.patch("usb_reset.get_root_dir", return_value="/root") + def test_detach(self, mock_get_root_dir, mock_remove, mock_dev_path): + usb_reset.detach("1-2", 1) + mock_remove.assert_called() + + @mock.patch("usb_reset.shutil.rmtree") + @mock.patch("usb_reset.os.path.isdir", return_value=True) + @mock.patch("usb_reset.os.path.exists", return_value=True) + @mock.patch("usb_reset.os.path.ismount", return_value=True) + @mock.patch("usb_reset.umount") + @mock.patch("usb_reset.log") + #pylint: disable=too-many-arguments + def test_cleanup(self, mock_log, mock_umount, mock_ismount, + mock_exists, mock_isdir, mock_rmtree): + usb_reset.cleanup(1) + mock_rmtree.assert_called() + +if __name__ == "__main__": + unittest.main() diff --git a/python3/tests/test_usb_scan.py b/python3/tests/test_usb_scan.py index 8b886194c7..9ed8be1faa 100644 --- a/python3/tests/test_usb_scan.py +++ b/python3/tests/test_usb_scan.py @@ -9,14 +9,14 @@ import unittest from collections.abc import Mapping from typing import cast +from unittest.mock import MagicMock -import mock from python3.tests.import_helper import import_file_as_module # mock modules to avoid dependencies -sys.modules["xcp"] = mock.Mock() -sys.modules["xcp.logger"] = mock.Mock() -sys.modules["pyudev"] = mock.Mock() +sys.modules["xcp"] = MagicMock() +sys.modules["xcp.logger"] = MagicMock() +sys.modules["pyudev"] = MagicMock() usb_scan = import_file_as_module("python3/libexec/usb_scan.py") @@ -90,7 +90,7 @@ def mock_setup(mod, devices, interfaces, path): mod.log.error = verify_log mod.log.debug = verify_log mod.Policy._PATH = path - mod.pyudev.Context = mock.Mock( + mod.pyudev.Context = MagicMock( return_value=MocContext(devices, interfaces)) @@ -372,3 +372,11 @@ def test_usb_config_error_missing_colon(self): ALLOW # Otherwise allow everything else """ self.verify_usb_config_error_common(content, "to unpack") + + def test_usb_config_empty_line(self): + content = """# empty line +ALLOW:vid=056a pid=0314 class=03 # Wacom Intuos tablet + +ALLOW # Otherwise allow everything else +""" + self.verify_usb_config_error_common(content, "") diff --git a/quality-gate.sh b/quality-gate.sh index 605d5142a3..c7965c34f0 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=279 + N=253 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=497 + N=459 X="ocaml/tests" X+="|ocaml/quicktest" X+="|ocaml/message-switch/core_test" @@ -44,7 +44,7 @@ mli-files () { } structural-equality () { - N=9 + N=7 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 ' == '" @@ -110,7 +110,7 @@ unixgetenv () { } hashtblfind () { - N=35 + N=33 # Looks for all .ml files except the ones using Core.Hashtbl.find, # which already returns Option HASHTBLFIND=$(git grep -P -r --count 'Hashtbl.find(?!_opt)' -- '**/*.ml' ':!ocaml/xapi-storage-script/main.ml' | cut -d ':' -f 2 | paste -sd+ - | bc) @@ -130,7 +130,9 @@ unnecessary-length () { UNNECESSARY_LENGTH=$(local_grep "List.length.*=+\s*0") UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "0\s*=+\s*List.length"))) UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "List.length.*\s>\s*0"))) + UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "List.length.*\s<>\s*0"))) UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "0\s*<\s*List.length"))) + UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "0\s*<>\s*List.length"))) UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "List.length.*\s<\s*1"))) UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "1\s*>\s*List.length"))) if [ "$UNNECESSARY_LENGTH" -eq "$N" ]; then diff --git a/scripts/Makefile b/scripts/Makefile index 5751d8628c..43b3ea3cda 100644 --- a/scripts/Makefile +++ b/scripts/Makefile @@ -68,6 +68,7 @@ install: $(IDATA) wsproxy.service $(DESTDIR)/usr/lib/systemd/system/wsproxy.service $(IDATA) wsproxy.socket $(DESTDIR)/usr/lib/systemd/system/wsproxy.socket $(IDATA) varstored-guard.service $(DESTDIR)/usr/lib/systemd/system/varstored-guard.service + $(IDATA) update-xapi-firewalld.service $(DESTDIR)/usr/lib/systemd/system/update-xapi-firewalld.service $(IDATA) network-init.service $(DESTDIR)/usr/lib/systemd/system/network-init.service $(IDATA) control-domain-params-init.service $(DESTDIR)/usr/lib/systemd/system/control-domain-params-init.service $(IDATA) xapi-nbd.service $(DESTDIR)/usr/lib/systemd/system/xapi-nbd.service @@ -137,6 +138,8 @@ install: mkdir -p $(DESTDIR)/etc/cron.d $(IDATA) xapi-tracing-log-trim.cron $(DESTDIR)/etc/cron.d/xapi-tracing-log-trim.cron mkdir -p $(DESTDIR)/opt/xensource/gpg + $(IPROG) xapi-ssh-monitor $(DESTDIR)$(OPTDIR)/bin + $(IDATA) xapi-ssh-monitor.service $(DESTDIR)/usr/lib/systemd/system/xapi-ssh-monitor.service # host-backup-restore $(IPROG) host-backup-restore/host-backup $(DESTDIR)$(LIBEXECDIR) $(IPROG) host-backup-restore/host-restore $(DESTDIR)$(LIBEXECDIR) diff --git a/scripts/host-bugreport-upload b/scripts/host-bugreport-upload index 766b6964f2..545b7d561d 100755 --- a/scripts/host-bugreport-upload +++ b/scripts/host-bugreport-upload @@ -4,8 +4,6 @@ # # Upload a bugreport to the support website -DEFAULT_BASE_URL="ftp://support.xensource.com/uploads/" - # If the user supplies a bare filename without a URI scheme, # we ignore it -- if they _really_ want to upload named files # to our support server, they can specify the URI scheme. @@ -19,7 +17,7 @@ if [ -z "$FILENAME" ]; then . @INVENTORY@ FILENAME=${INSTALLATION_UUID}-${now} fi -[ ! -z "${BASE_URL}" ] || BASE_URL="${DEFAULT_BASE_URL}" +[ -n "${BASE_URL}" ] || exit 1 URL="${BASE_URL}${FILENAME}" diff --git a/scripts/network-init b/scripts/network-init index b6fa796998..8ee49eacbf 100755 --- a/scripts/network-init +++ b/scripts/network-init @@ -100,9 +100,9 @@ prepare_networking() { rename_network_label() { # In common criteria certification deployment, user must ensure: - # - The 1st NIC (eth0) is for Management Network - # - The 2nd NIC (eth1) is for Storage Network - # - others (ethX, X>=2) is for Guest Network + # - The 1st NIC is for Management Network + # - The 2nd NIC is for Storage Network + # - others (X>=2) is for Guest Network # This function is to rename these network labels to appropriate. if [ "${CC_PREPARATIONS}" != "true" ]; then @@ -110,9 +110,18 @@ rename_network_label() { return fi - for device in $(ls /sys/class/net | grep -E '^eth[0-9]+$') + for device_path in /sys/class/net/* do - device_id=$(echo ${device} | sed 's/^eth//') + device=$(basename "${device_path}") + network_uuid=$(${XE} pif-list device="${device}" params=network-uuid --minimal) + if [ -z "${network_uuid}" ]; then + continue + fi + bridge=$(${XE} network-list uuid="${network_uuid}" params=bridge --minimal) + if [ -z "${bridge}" ]; then + continue + fi + device_id="${bridge#xenbr}" if [ ${device_id} -eq 0 ]; then name_label="Management Network" elif [ ${device_id} -eq 1 ]; then @@ -127,8 +136,7 @@ rename_network_label() { continue fi - network_uuid=$(${XE} pif-list device=${device} params=network-uuid --minimal) - ${XE} network-param-set uuid=${network_uuid} name-label="${name_label}" + ${XE} network-param-set uuid="${network_uuid}" name-label="${name_label}" echo "Renamed network label of ${network_uuid} to ${name_label}, device: ${device}" done } diff --git a/scripts/runtests b/scripts/runtests deleted file mode 100755 index cfdc95cf86..0000000000 --- a/scripts/runtests +++ /dev/null @@ -1,57 +0,0 @@ -#!/bin/bash - -# It appears that this file is NOT installed by OMakefile. If installing it in -# the future, make sure that variable BASE_PATH is set correctly. - -if [ -z $1 ] -then - echo "Need to specify the current network interface (e.g. eth0) as a parameter - to this script" - exit 1 -fi - -IF=$1 - -export PATH=$PATH:@OPTDIR@/bin - -# generic stuff, necessary for xenrt too - -#install necessary packages -yum -y install nc -yum -y install rsync -yum -y install wget - -# mount the iso directory -mount bespin:/scratch/images/autoinstall /var/opt/xen/iso_import - -# make a lv for import/export tests, mount it on /mnt -VG=`vgs --noheadings -o size,name,size --separator=, | cut -d, -f2` -lvcreate -n importexport -L 10G $VG -mke2fs /dev/$VG/importexport -mount /dev/$VG/importexport /mnt - -#tmp dir for logging output -mkdir -p /tmp/rt -cd /tmp/rt -wget http://snoosnoo.uk.xensource.com/~jludlam/test.css -wget http://snoosnoo.uk.xensource.com/~jludlam/test_log.js - -# post this line is non-xenrt only. xenrt should provide the vms -# rather than having to import them. - -# mount the volume with the images on -mkdir -p /tmp/vms -mount bespin:/scratch2/jludlam /tmp/vms - -# import them - -cd /tmp/vms/ -./debian.sh $IF -./debian-pv.sh $IF -./windowsxp.sh $IF - -cp /tmp/vms/vncsnapshot /usr/bin/ -cd /tmp/rt - -test_host -a -v debian,debian-pv,windowsxp -i $IF - diff --git a/scripts/update-xapi-firewalld.service b/scripts/update-xapi-firewalld.service new file mode 100644 index 0000000000..1ef53e7a92 --- /dev/null +++ b/scripts/update-xapi-firewalld.service @@ -0,0 +1,16 @@ +[Unit] +Description=Update firewalld service for xapi +PartOf=firewalld.service +After=firewalld.service xapi.service xapi-init-complete.target + +[Service] +Type=oneshot +ExecStart=/bin/sh -c 'xe host-update-firewalld-service-status' +RemainAfterExit=yes +Restart=on-failure +RestartSec=5 +StartLimitBurst=3 +StartLimitInterval=30s + +[Install] +WantedBy=multi-user.target diff --git a/scripts/usb-policy.conf b/scripts/usb-policy.conf index 777cd96e24..e14a11d68a 100644 --- a/scripts/usb-policy.conf +++ b/scripts/usb-policy.conf @@ -1,11 +1,16 @@ # When you change this file, run 'xe pusb-scan' to confirm # the file can be parsed correctly. +# You can also run '/opt/xensource/libexec/usb_scan.py -d' to see +# debug output from the script parsing this configuration file. # # Syntax is an ordered list of case insensitive rules where # is line comment # and each rule is (ALLOW | DENY) : ( match )* # and each match is (class|subclass|prot|vid|pid|rel) = hex-number # Maximum hex value for class/subclass/prot is FF, and for vid/pid/rel is FFFF # +# Rules are ordered so that the first matching rule will override +# any other rules for the device below it +# # USB Hubs (class 09) are always denied, independently of the rules in this file DENY: vid=17e9 # All DisplayLink USB displays DENY: class=02 # Communications and CDC-Control diff --git a/scripts/xapi-ssh-monitor b/scripts/xapi-ssh-monitor new file mode 100644 index 0000000000..d3c35658b4 --- /dev/null +++ b/scripts/xapi-ssh-monitor @@ -0,0 +1,297 @@ +#!/usr/bin/env python3 + +import time +import subprocess +import logging +import os.path +import signal +import sys +import re +import XenAPI +import threading +from enum import Enum, auto +from typing import Tuple, List, Optional, Dict, Any +import traceback + +# Configure logging +log_format = '%(asctime)s - %(levelname)s - %(message)s' +log_level = logging.INFO + +logging.basicConfig( + level=log_level, + format=log_format, + handlers=[ + logging.StreamHandler(), + logging.FileHandler('/var/log/daemon.log') + ] +) + +logger = logging.getLogger(__name__) + +# Constants +class SshState(Enum): + DOWN = auto() + ACTIVE = auto() + UNKNOWN = auto() + +INSTALLATION_UUID_REGEX = re.compile("^INSTALLATION_UUID") + +def match_host_id(s): + return INSTALLATION_UUID_REGEX.search(s, 0) + +class XapiMonitor: + XAPI_HEALTH_CHECK = '/opt/xensource/libexec/xapi-health-check' + + def __init__(self): + self.logger = logging.getLogger(__name__) + self.running = True + self.session = None + self.localhost_uuid = self.get_localhost_uuid() + # Create event for graceful exit + self.exit_event = threading.Event() + signal.signal(signal.SIGTERM, self._handle_signal) + signal.signal(signal.SIGINT, self._handle_signal) + signal.signal(signal.SIGHUP, self._handle_signal) + + def _handle_signal(self, signum, frame): + """Handle termination signals""" + signal_names = { + signal.SIGTERM: "SIGTERM", + signal.SIGINT: "SIGINT", + signal.SIGHUP: "SIGHUP" + } + signal_name = signal_names.get(signum, f"Signal {signum}") + self.logger.info(f"Received {signal_name}, preparing to exit...") + self.running = False + # Set event to interrupt any waiting + self.exit_event.set() + + def _create_session(self) -> Optional[Any]: + """Create a session with local XAPI""" + try: + session = XenAPI.xapi_local() + session.login_with_password("", "") + return session + except Exception as e: + self.logger.error(f"Create XAPI session failed: {e}") + return None + + def _logout_session(self) -> None: + """Logout from XAPI session""" + try: + if self.session: + self.session.logout() + self.logger.debug("XAPI session logged out") + except Exception as e: + self.logger.warning(f"Error during session logout: {e}") + + @staticmethod + def get_localhost_uuid() -> str: + """Get the UUID of the local host from inventory file""" + filename = '/etc/xensource-inventory' + try: + with open(filename, 'r') as f: + for line in filter(match_host_id, f.readlines()): + return line.split("'")[1] + except Exception as e: + error_msg = f"Unable to open inventory file [{filename}]: {e}" + logging.getLogger(__name__).error(error_msg) + raise RuntimeError(error_msg) + + # If we get here, we didn't find the UUID + error_msg = f"Could not find INSTALLATION_UUID in {filename}" + logging.getLogger(__name__).error(error_msg) + raise RuntimeError(error_msg) + + def _run_command(self, command: List[str], timeout: int = 10) -> Tuple[int, str, str]: + """Execute command and return results + + Args: + command: Command to execute as list of strings + timeout: Command execution timeout in seconds (default: 10) + + Returns: + Tuple of (return_code, stdout, stderr) + """ + self.logger.debug(f"Running command: {' '.join(command)}") + try: + process = subprocess.Popen( + command, + stdout=subprocess.PIPE, + stderr=subprocess.PIPE, + universal_newlines=True + ) + try: + stdout, stderr = process.communicate(timeout=timeout) + self.logger.debug(f"Command returned: {process.returncode}") + return process.returncode, stdout, stderr + except subprocess.TimeoutExpired: + process.kill() + process.communicate() + self.logger.error(f"Command execution timeout after {timeout}s: {' '.join(command)}") + return -1, "", "Timeout" + except Exception as e: + self.logger.error(f"Error executing command: {e}") + return -1, "", str(e) + + def _check_xapi_health(self) -> bool: + """Check XAPI health status with extended timeout""" + self.logger.debug("Performing XAPI health check") + returncode, stdout, stderr = self._run_command([self.XAPI_HEALTH_CHECK], timeout=120) + + if returncode != 0: + self.logger.warning(f"XAPI health check failed: {stderr}") + + return returncode == 0 + + def _get_ssh_state(self) -> SshState: + """Get SSH service status""" + returncode, stdout, stderr = self._run_command(['systemctl', 'is-active', 'sshd']) + status = stdout.strip() + + if status == 'active': + return SshState.ACTIVE + if status in ('inactive', 'failed', 'unknown'): + return SshState.DOWN + + self.logger.warning(f"Unexpected SSH status: {status}, stderr: {stderr}") + return SshState.UNKNOWN + + def _control_ssh_service(self, enable: bool) -> bool: + """Control SSH service + + Returns: + bool: True if operation was successful, False otherwise + """ + action = "starting" if enable else "stopping" + try: + firewall_cmd = '/usr/bin/firewall-cmd' + use_firewalld = os.path.exists(firewall_cmd) + if enable: + if use_firewalld: + ret0, _, stderr0 = self._run_command([firewall_cmd, '--add-service', 'ssh']) + else: + ret0, stderr0 = 0, "n/a" + ret1, _, stderr1 = self._run_command(['systemctl', 'enable', 'sshd']) + ret2, _, stderr2 = self._run_command(['systemctl', 'start', 'sshd']) + success = (ret0 == 0 and ret1 == 0 and ret2 == 0) + else: + ret2, _, stderr2 = self._run_command(['systemctl', 'stop', 'sshd']) + ret1, _, stderr1 = self._run_command(['systemctl', 'disable', 'sshd']) + if use_firewalld: + ret0, _, stderr0 = self._run_command([firewall_cmd, '--remove-service', 'ssh']) + else: + ret0, stderr0 = 0, "n/a" + success = (ret0 == 0 and ret1 == 0 and ret2 == 0) + + if success: + self.logger.info(f"SSH service {action} successful") + else: + err_msg = f"""SSH service {action} failed: enable/disable firewalld service stderr: {stderr0}, + enable/disable sshd stderr: {stderr1}, start/stop sshd stderr: {stderr2} """ + self.logger.error(err_msg) + + return success + except Exception as e: + self.logger.error(f"SSH service {action} failed with exception: {e}") + self.logger.debug(traceback.format_exc()) + return False + + def _disable_ssh_via_api(self) -> bool: + """Disable SSH via XAPI, max retries 3 times""" + if not self.session: + self.session = self._create_session() + if not self.session: + return False + + retry_count = 0 + max_retries = 3 + retry_interval = 5 + + while retry_count < max_retries and self.running: + try: + host = self.session.xenapi.host.get_by_uuid(self.localhost_uuid) + self.session.xenapi.host.disable_ssh(host) + self.logger.info("Successfully disabled SSH via XAPI") + return True + except Exception as e: + retry_count += 1 + self.logger.warning(f"Disable SSH via API failed ({retry_count}/{max_retries}): {e}") + if retry_count < max_retries and self.running: + # Use interruptible sleep + if self.exit_event.wait(retry_interval): + return False + self._logout_session() + self.session = self._create_session() + + if not self.running: + return False + + self.logger.error(f"Disable SSH via API failed, max retries reached ({max_retries})") + return False + + def run(self): + """Main monitoring loop""" + self.logger.info("Starting XAPI and SSH service monitoring...") + + self.session = self._create_session() + if not self.session: + self.logger.warning("Initial session creation failed, will retry later") + + while self.running: + try: + # Check XAPI health - always perform the check + xapi_healthy = self._check_xapi_health() + + # Get current SSH state + current_ssh_state = self._get_ssh_state() + self.logger.debug(f"Current SSH state: {current_ssh_state}") + + if xapi_healthy: + if current_ssh_state == SshState.ACTIVE: + self.logger.info("XAPI healthy: Stopping SSH service") + if not self._disable_ssh_via_api(): + self.logger.warning("Disable SSH via API failed, keeping SSH service running") + else: + if current_ssh_state != SshState.ACTIVE: + self.logger.info("XAPI unhealthy: Starting SSH service") + self._control_ssh_service(True) + + except Exception as e: + self.logger.error(f"Runtime error: {e}") + self.logger.debug(traceback.format_exc()) + + self._logout_session() + + self.session = None + + # Use interruptible sleep with a fixed interval when there is an error + if self.exit_event.wait(5): + break + + continue + + # Use interruptible sleep for main loop + if self.exit_event.wait(60): + break + + self._logout_session() + + self.logger.info("Monitoring service stopped") + +def main(): + logger.info(f"SSH Control Service starting (PID: {os.getpid()})") + + try: + monitor = XapiMonitor() + monitor.run() + except Exception as e: + logger.critical(f"Fatal error in main process: {e}") + logger.critical(traceback.format_exc()) + sys.exit(1) + + logger.info("SSH Control Service exited normally") + sys.exit(0) + +if __name__ == '__main__': + main() diff --git a/scripts/xapi-ssh-monitor.service b/scripts/xapi-ssh-monitor.service new file mode 100644 index 0000000000..f38685e708 --- /dev/null +++ b/scripts/xapi-ssh-monitor.service @@ -0,0 +1,14 @@ +[Unit] +Description=XAPI SSH monitor service +After=network.target +After=xapi.service +OnFailure=sshd.service + +[Service] +Type=simple +RemainAfterExit=true +ExecStart=/opt/xensource/bin/xapi-ssh-monitor +ExecStop=/bin/true + +[Install] +WantedBy=multi-user.target diff --git a/scripts/xapi.conf b/scripts/xapi.conf index 46f859a8d4..8736fed6c0 100644 --- a/scripts/xapi.conf +++ b/scripts/xapi.conf @@ -159,7 +159,8 @@ sparse_dd = /usr/libexec/xapi/sparse_dd # Directory containing supplemental pack data # packs-dir = @ETCXENDIR@/installed-repos -# Directory containing SM plugins +# Directory containing SM plugins. This path changes in XenServer 9 with a +# configuration coming from /etc/xapi.conf.d/, which takes precedence # sm-dir = @OPTDIR@/sm # Whitelist of SM plugins @@ -328,7 +329,7 @@ sm-plugins=ext nfs iscsi lvmoiscsi dummy file hba rawhba udev iso lvm lvmohba lv # ha_monitor_interval = 20 # Unconditionally replan every once in a while just in case the overcommit -# protection is buggy and we don't notice +# protection is buggy and we don't notice # ha_monitor_plan_interval = 1800 # ha_monitor_startup_timeout = 1800 @@ -370,7 +371,7 @@ sm-plugins=ext nfs iscsi lvmoiscsi dummy file hba rawhba udev iso lvm lvmohba lv # The default time, in µs, in which tapdisk3 will keep polling the # vbd ring buffer in expectation for extra requests from the guest -# default-vbd3-polling-duration = 1000 +# default-vbd3-polling-duration = 8000 # The default % of idle dom0 cpu above which tapdisk3 will keep polling # the vbd ring buffer @@ -385,7 +386,7 @@ sm-plugins=ext nfs iscsi lvmoiscsi dummy file hba rawhba udev iso lvm lvmohba lv # evacuation-batch-size = 10 # number of VMs migrated in parallel in Host.evacuate -# How often tracing will export spans to endpoints +# How often tracing will export spans to endpoints # export-interval = 30. # The file to check if host reboot required diff --git a/scripts/xcp-networkd.service b/scripts/xcp-networkd.service index c80b5b630b..2422c740ab 100644 --- a/scripts/xcp-networkd.service +++ b/scripts/xcp-networkd.service @@ -1,8 +1,16 @@ [Unit] Description=XCP networking daemon Documentation=man:xcp-networkd(1) -After=forkexecd.service message-switch.service syslog.target -Wants=forkexecd.service message-switch.service syslog.target +After=systemd-udev-settle.service +After=systemd-udev-trigger.service +After=forkexecd.service +After=message-switch.service +After=syslog.target +Wants=systemd-udev-settle.service +Wants=systemd-udev-trigger.service +Wants=forkexecd.service +Wants=message-switch.service +Wants=syslog.target PartOf=toolstack.target [Service] diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 19f0cf0e4a..88980776b9 100755 --- a/scripts/xe-backup-metadata +++ b/scripts/xe-backup-metadata @@ -24,7 +24,7 @@ if [ "${master_uuid}" != "${INSTALLATION_UUID}" ]; then exit 1 fi -history_kept=25 +history_kept=12 metadata_version=1 debug=/bin/true @@ -129,7 +129,7 @@ if [ -z "${vdi_uuid}" ]; then echo -n "Creating new backup VDI: " label="Pool Metadata Backup" # the label must match what xapi_vdi.ml is using for backup VDIs - vdi_uuid=$(${XE} vdi-create virtual-size=500MiB sr-uuid="${sr_uuid}" type=user name-label="${label}") + vdi_uuid=$(${XE} vdi-create virtual-size=1GiB sr-uuid="${sr_uuid}" type=user name-label="${label}") init_fs=1 if [ $? -ne 0 ]; then echo failed diff --git a/scripts/xe-syslog-reconfigure b/scripts/xe-syslog-reconfigure index de84881d68..fa5ad0b796 100644 --- a/scripts/xe-syslog-reconfigure +++ b/scripts/xe-syslog-reconfigure @@ -15,11 +15,9 @@ do done +echo "# /etc/rsyslog.d/remote.conf is managed by xe-syslog-reconfigure (do not edit)" > /etc/rsyslog.d/remote.conf if [ $remote -eq 1 ]; then - echo "# /etc/rsyslog.d/remote.conf is auto-generated by xe-syslog-reconfigure" > /etc/rsyslog.d/remote.conf echo "*.* @$host" >> /etc/rsyslog.d/remote.conf -else - rm -f /etc/rsyslog.d/remote.conf fi systemctl restart rsyslog diff --git a/unixpwd/c/unixpwd.c b/unixpwd/c/unixpwd.c index 6ff872184d..fbbc6ca38e 100644 --- a/unixpwd/c/unixpwd.c +++ b/unixpwd/c/unixpwd.c @@ -12,6 +12,8 @@ * GNU Lesser General Public License for more details. */ +#define _GNU_SOURCE + #include #include #include diff --git a/unixpwd/src/unixpwd.mli b/unixpwd/src/unixpwd.mli index c191870388..f613bf01d5 100644 --- a/unixpwd/src/unixpwd.mli +++ b/unixpwd/src/unixpwd.mli @@ -30,7 +30,7 @@ val get : string -> string * /etc/shadow database if an entry exists, otherwise it tries to * obtain the password from the /etc/passwd database. It raises [Error] * if that fails. - * *) + *) val setpwd : string -> string -> unit