diff --git a/.github/workflows/1.249-lcm.yml b/.github/workflows/1.249-lcm.yml index 8057b255a92..8ba69e28ec2 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/generate-and-build-sdks.yml b/.github/workflows/generate-and-build-sdks.yml index ca1a67a4c78..4083db393c9 100644 --- a/.github/workflows/generate-and-build-sdks.yml +++ b/.github/workflows/generate-and-build-sdks.yml @@ -200,80 +200,6 @@ 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: diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index d766f4f1e4a..9c892846e1e 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -83,12 +83,6 @@ 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: @@ -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/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 00000000000..34b62707ea4 --- /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/README.markdown b/README.markdown index 1b9243c6ded..9f795d85506 100644 --- a/README.markdown +++ b/README.markdown @@ -11,7 +11,7 @@ Xen API is written mostly in [OCaml](http://caml.inria.fr/ocaml/) 4.07. Xapi is the main component produced by the Linux Foundation's -[Xapi Project](http://xenproject.org/developers/teams/xapi.html). +[Xapi Project](https://xenproject.org/projects/xapi/). Build and Install ----------------- @@ -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/toolstack/features/events/index.md b/doc/content/toolstack/features/events/index.md index 3d76d4db927..98bdf17e6ae 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/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 8b7971bed79..4a8a68ced52 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 00000000000..7cdb2d540a3 --- /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 00000000000..4b6f61131c5 --- /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 00000000000..8ed03406acc --- /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 00000000000..891913850d3 --- /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 00000000000..b6002382db2 --- /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 00000000000..5fe0f398c17 --- /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/dune-project b/dune-project index 5ad3b3a0ff3..56de01f0fd3 100644 --- a/dune-project +++ b/dune-project @@ -1,771 +1,854 @@ (lang dune 3.15) -(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)) + +(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 - ) -) - -(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.") -) +(maintainers "Xapi project maintainers") -(package - (name xapi-storage-script) -) +(homepage "https://xapi-project.github.io/") (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) -) - -(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 - ) -) - -(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) - ) -) - -(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 -[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 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))) + (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)) + +(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)) + +(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 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))) diff --git a/ocaml/database/block_device_io.mli b/ocaml/database/block_device_io.mli new file mode 100644 index 00000000000..cabf42bbb8e --- /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 00000000000..260c8b701ef --- /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 e75539a5592..a4ebb21ab47 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 00000000000..cabf42bbb8e --- /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 dc176488f3b..b3e771e774c 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 diff --git a/ocaml/database/db_action_helper.ml b/ocaml/database/db_action_helper.ml index a553846e3d7..87ff4884933 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 00000000000..81fb7eb480d --- /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 92954540c33..b92b021dadd 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 eba091889ec..c6ec25d6130 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 00000000000..ed1de2cd9ad --- /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 7bbf062bd02..e9745749ada 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 @@ -69,17 +74,12 @@ let ensure_utf8_xml string = 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)) @@ -87,10 +87,18 @@ let write_field_locked t tblname objref fldname newval = ) 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 + let newval = + match newval with + | Schema.Value.String s -> + (* the other caller of write_field_locked only uses sets and maps, + so we only need to check for String here + *) + if not (Xapi_stdext_encodings.Encodings.UTF8_XML.is_valid s) then + raise Invalid_value ; + Schema.Value.String (Share.merge s) + | _ -> + newval + in with_lock (fun () -> write_field_locked t tblname objref fldname newval) let touch_row t tblname objref = @@ -103,7 +111,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 +124,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,26 +210,65 @@ 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 + read_field_where' Schema.CachedValue.string_of t { table= tbl ; return= Db_names.ref @@ -242,7 +285,7 @@ let db_get_by_uuid t 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 +300,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 +334,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 +381,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 @@ -497,3 +543,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 b9b26cfc0ee..8dd161b0f8e 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 ed2a3296940..aa472419bfc 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 00000000000..cabf42bbb8e --- /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 be73b91958f..63c91d14bb4 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 @@ -518,9 +550,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 @@ -602,7 +636,7 @@ let set_field tblname objref fldname newval db = |> 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 ) @@ -613,7 +647,7 @@ let set_field tblname objref fldname newval db = let g = Manifest.generation (Database.manifest db) in db |> ((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 diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 2ffe79c411b..f06af9a31c6 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 diff --git a/ocaml/database/db_connections.ml b/ocaml/database/db_connections.ml index 9b390967fce..18152a18c4e 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 00000000000..81ec405a581 --- /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 00000000000..53b686e1f4c --- /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 25a171c8384..915162ae8db 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 00000000000..392974c470e --- /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 00000000000..63834965084 --- /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 00000000000..1584d7b3497 --- /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 00000000000..d51d569907d --- /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 9343ed87e8d..af1d4572909 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 00000000000..a1c981a9e7e --- /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 00000000000..a735cf122dc --- /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 e893050f58c..648ca94dc26 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 00000000000..b1bb79d751c --- /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 c1819e5aa22..100fea3701c 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 00000000000..93ab8655868 --- /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 1499fa3fc13..6cb7af729c5 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 754fd2fa340..51a1177cabd 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 7adbcd6bbed..9219779966b 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 2e03f069497..434677d3990 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 00000000000..baba04f45d9 --- /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 00000000000..3555e696096 --- /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_upgrade.mli b/ocaml/database/db_upgrade.mli new file mode 100644 index 00000000000..90eb5bf6912 --- /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 1795cdef3bd..b9224f5ce5a 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 00000000000..24a969c95cb --- /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 1b67e2146d9..7422d6dc900 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -1,134 +1,133 @@ (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 + 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 + 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 + 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 + 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 00000000000..4a5dd6c90ed --- /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 d7faff1cd62..09fde7dceef 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 00000000000..eca6c22d025 --- /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 8eb55ee2afe..67aa5c70d80 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 00000000000..95004fdb61f --- /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 429646dcce7..8c2c95928d7 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 6577bc7cfc3..06a2dc391d4 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 00000000000..8a248d49953 --- /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/database/static_vdis_list.mli b/ocaml/database/static_vdis_list.mli new file mode 100644 index 00000000000..4e59f5b75c1 --- /dev/null +++ b/ocaml/database/static_vdis_list.mli @@ -0,0 +1,23 @@ +(* + * 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 vdi = { + uuid: string + ; reason: string + ; delete_next_boot: bool + ; currently_attached: bool + ; path: string option +} + +val list : unit -> vdi list diff --git a/ocaml/database/string_marshall_helper.mli b/ocaml/database/string_marshall_helper.mli new file mode 100644 index 00000000000..2fc57ff97b7 --- /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 00000000000..3362c9659f0 --- /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 fa2519b5f61..57b92cce060 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 00000000000..fa4cb6ebac4 --- /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 00000000000..cabf42bbb8e --- /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 00000000000..cabf42bbb8e --- /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 00000000000..4ec7f9016d7 --- /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/forkexecd/.gitignore b/ocaml/forkexecd/.gitignore index d9b5b8ca4be..2c89ac5c34f 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/helper/Makefile b/ocaml/forkexecd/helper/Makefile index 2bfc3b07e35..6c14a3aeb6c 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 434afba6126..0afd285e094 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/gencert/dune b/ocaml/gencert/dune index cbd5cd73ae2..608b274963f 100644 --- a/ocaml/gencert/dune +++ b/ocaml/gencert/dune @@ -6,7 +6,7 @@ (libraries angstrom astring - cstruct + digestif forkexec mirage-crypto mirage-crypto-pk @@ -52,7 +52,7 @@ (modules test_lib test_pem) (libraries alcotest - cstruct + digestif fmt gencertlib mirage-crypto @@ -64,6 +64,7 @@ rresult x509 xapi-consts + xapi-datamodel xapi-stdext-unix ) (deps diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index cd964276e65..b25f4db2633 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 3d840d34c2a..68ff2125dea 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 2e073725e02..d8ce652f8a5 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 379eb35f2e3..e2a71225d90 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 a2bfaf4d4fb..4372877b995 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: [ diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 27bb8a7bf98..b22d91f9715 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -897,6 +897,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 +1708,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 +1921,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 +2053,12 @@ 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.host_driver_no_hardware ["driver variant"] ~doc:"No hardware present for this host driver variant" () ; diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 99f4ebcf316..f0bce099389 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -1297,14 +1297,63 @@ 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.20.0-next" + ; 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.20.0-next" + ; 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.20.0-next" + ; 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.20.0-next" + ; param_default= Some (VInt Constants.default_console_idle_timeout) + } ] 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.20.0-next" + , "Added --ssh_enabled --ssh_enabled_timeout --ssh_expiry \ + --console_idle_timeout 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 +2417,29 @@ 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 latest_synced_updates_applied_state = Enum ( "latest_synced_updates_applied_state" @@ -2527,6 +2599,8 @@ let t = ; emergency_clear_mandatory_guidance ; enable_ssh ; disable_ssh + ; set_ssh_enabled_timeout + ; set_console_idle_timeout ] ~contents: ([ @@ -2964,6 +3038,24 @@ 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)" ] ) () diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index b8a5a528a54..fc9acec7bd1 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -78,7 +78,7 @@ let prototyped_of_field = function | "Cluster_host", "live" -> Some "24.3.0" | "Cluster", "expected_hosts" -> - Some "25.16.0-next" + Some "25.17.0" | "Cluster", "live_hosts" -> Some "24.3.0" | "Cluster", "quorum" -> @@ -97,6 +97,14 @@ let prototyped_of_field = function Some "22.26.0" | "SM", "host_pending_features" -> Some "24.37.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 +221,10 @@ let prototyped_of_message = function Some "22.26.0" | "VTPM", "create" -> Some "22.26.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" -> @@ -233,8 +245,14 @@ let prototyped_of_message = function Some "24.17.0" | "VM", "restart_device_models" -> Some "23.30.0" + | "VM", "call_host_plugin" -> + Some "25.21.0-next" | "VM", "set_groups" -> Some "24.19.1" + | "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 cce63a58e16..97b42e12876 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -1249,7 +1249,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 +1294,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 +1579,33 @@ 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 () + (** A pool class *) let t = create_obj ~in_db:true @@ -1667,6 +1702,8 @@ let t = ; get_guest_secureboot_readiness ; enable_ssh ; disable_ssh + ; set_ssh_enabled_timeout + ; set_console_idle_timeout ] ~contents: ([ diff --git a/ocaml/idl/datamodel_schema.ml b/ocaml/idl/datamodel_schema.ml index 10f20662496..6c295ef00f4 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 e270899b50f..522ab4e530a 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 44ca1466d78..e72721b4ce0 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -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: @@ -2545,6 +2558,7 @@ let t = ; set_groups ; query_services ; call_plugin + ; call_host_plugin ; set_has_vendor_device ; import ; set_actions_after_crash diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 44d8bf9298e..863ae6b2b50 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_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index e467624ab13..f4633fd1ba8 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/schematest.ml b/ocaml/idl/schematest.ml index 06feb367452..c8abcb1f999 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 = "4cd835e2557dd7b5cbda6c681730c447" 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 c668b0c1fb3..2dab4a95443 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/log/test/dune b/ocaml/libs/log/test/dune index ddfbf07bcc9..299a6155eac 100644 --- a/ocaml/libs/log/test/dune +++ b/ocaml/libs/log/test/dune @@ -3,4 +3,5 @@ (libraries log xapi-stdext-threads threads.posix xapi-backtrace)) (cram + (package xapi-log) (deps log_test.exe)) diff --git a/ocaml/libs/log/test/log_test.t b/ocaml/libs/log/test/log_test.t index 2d7b5fa1414..b51ea26fca0 100644 --- a/ocaml/libs/log/test/log_test.t +++ b/ocaml/libs/log/test/log_test.t @@ -1,8 +1,8 @@ $ ./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] 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 14 [|error||0 |main|backtrace] [| warn||0 |main|log_test.ml] Got exception: Invalid_argument("index out of bounds") diff --git a/ocaml/libs/sexpr/dune b/ocaml/libs/sexpr/dune index 77653c2abcc..6490da85beb 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 488142898c2..3637ac6abf5 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 e7ab5c68a1a..7bf1c61812b 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 109ee577169..00000000000 --- 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/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index c1cdc33692e..d320fd6061b 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -792,10 +792,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 diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index 262acb52f27..8323346a443 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -190,12 +190,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 +209,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 +222,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 +234,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 +269,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 +289,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 +315,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 5844d389e1c..1162202b611 100644 --- a/ocaml/libs/tracing/tracing_export.ml +++ b/ocaml/libs/tracing/tracing_export.ml @@ -278,8 +278,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 @@ -293,8 +293,8 @@ module Destination = struct 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 @@ -306,6 +306,8 @@ module Destination = struct (* 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 +321,8 @@ module Destination = struct signaled := true ) ; flush_spans () - done + done ; + Delay.signal wait_exit ) () @@ -339,6 +342,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 3f8ca750026..f322bd2404c 100644 --- a/ocaml/libs/tracing/tracing_export.mli +++ b/ocaml/libs/tracing/tracing_export.mli @@ -85,9 +85,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/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml index b4c827705c9..bb516ea6a28 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -468,11 +468,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-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml index c8d85d8b6c5..251b35473a8 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/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index 32a9f5119ab..893a7e4d9bc 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 047935b475c..3db652bd2a3 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 28fd7f9af89..27b2f632d08 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/message-switch/core/dune b/ocaml/message-switch/core/dune index d61746efe44..c9b5b3e2cff 100644 --- a/ocaml/message-switch/core/dune +++ b/ocaml/message-switch/core/dune @@ -9,6 +9,7 @@ sexplib sexplib0 threads.posix + tracing uri xapi-log xapi-stdext-threads diff --git a/ocaml/message-switch/core/make.ml b/ocaml/message-switch/core/make.ml index 43b7e301a9b..df1d003f5f5 100644 --- a/ocaml/message-switch/core/make.ml +++ b/ocaml/message-switch/core/make.ml @@ -229,7 +229,7 @@ functor in return (Ok t) - let rpc ~t ~queue ?timeout ~body:x () = + let rpc ?_span_parent ~t ~queue ?timeout ~body:x () = let ivar = M.Ivar.create () in let timer = Option.map diff --git a/ocaml/message-switch/core/s.ml b/ocaml/message-switch/core/s.ml index 423304d1b24..fefe4d7a1f6 100644 --- a/ocaml/message-switch/core/s.ml +++ b/ocaml/message-switch/core/s.ml @@ -144,7 +144,8 @@ module type CLIENT = sig (** [disconnect] closes the connection *) val rpc : - t:t + ?_span_parent:Tracing.Span.t + -> t:t -> queue:string -> ?timeout:int -> body:string diff --git a/ocaml/message-switch/unix/dune b/ocaml/message-switch/unix/dune index 92bddfd66fb..1858aa271b3 100644 --- a/ocaml/message-switch/unix/dune +++ b/ocaml/message-switch/unix/dune @@ -11,6 +11,7 @@ rpclib.core rpclib.json threads.posix + tracing 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 f7aa0802c0f..29b95f7ef12 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/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 1c8c8cd1a27..846c517c82e 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -162,7 +162,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 -> diff --git a/ocaml/sdk-gen/c/autogen/dune b/ocaml/sdk-gen/c/autogen/dune index 78b81f38e4c..ff89723f136 100644 --- a/ocaml/sdk-gen/c/autogen/dune +++ b/ocaml/sdk-gen/c/autogen/dune @@ -1,26 +1,20 @@ (rule - (targets COPYING) - (deps - ../../LICENSE - ) - (action (copy %{deps} %{targets})) -) + (targets COPYING) + (deps ../../LICENSE) + (action + (copy %{deps} %{targets}))) (rule - (targets README) - (deps - ../README.dist - ) - (action (copy %{deps} %{targets})) -) + (targets README) + (deps ../README.dist) + (action + (copy %{deps} %{targets}))) (alias - (name generate) - (deps - COPYING - README - (source_tree .) - ) -) + (name generate) + (deps + COPYING + README + (source_tree .))) (data_only_dirs src include) diff --git a/ocaml/sdk-gen/c/dune b/ocaml/sdk-gen/c/dune index adbea6905fa..ef7e42abbd5 100644 --- a/ocaml/sdk-gen/c/dune +++ b/ocaml/sdk-gen/c/dune @@ -1,34 +1,26 @@ (executable - (modes exe) - (name gen_c_binding) - (libraries - astring - CommonFunctions - - mustache - xapi-datamodel - ) -) + (modes exe) + (name gen_c_binding) + (libraries astring CommonFunctions mustache xapi-datamodel)) (rule - (alias generate) - (package xapi-sdk) - (targets (dir autogen-out)) - (deps - (:x gen_c_binding.exe) - (source_tree templates) - (source_tree autogen) - ) - (action (concurrent - (bash "cp -r autogen/ autogen-out/") - (run %{x}) - )) -) + (alias generate) + (package xapi-sdk) + (targets + (dir autogen-out)) + (deps + (:x gen_c_binding.exe) + (source_tree templates) + (source_tree autogen)) + (action + (progn + (bash "cp -r autogen/ autogen-out/") + (run %{x})))) (data_only_dirs templates) (install - (package xapi-sdk) - (section share_root) - (dirs (autogen-out as c)) -) + (package xapi-sdk) + (section share_root) + (dirs + (autogen-out as c))) diff --git a/ocaml/sdk-gen/common/dune b/ocaml/sdk-gen/common/dune index ea0011e71ce..1475ba4da8d 100644 --- a/ocaml/sdk-gen/common/dune +++ b/ocaml/sdk-gen/common/dune @@ -1,14 +1,6 @@ (library - (name CommonFunctions) - (modes best) - (wrapped false) - (libraries - astring - xapi-datamodel - mustache - xapi-stdext-std - xapi-stdext-unix - ) - (modules_without_implementation license) -) - + (name CommonFunctions) + (modes best) + (wrapped false) + (libraries astring xapi-datamodel mustache xapi-stdext-std xapi-stdext-unix) + (modules_without_implementation license)) diff --git a/ocaml/sdk-gen/csharp/autogen/dune b/ocaml/sdk-gen/csharp/autogen/dune index 2a9744e4ae6..bd393d9a6e6 100644 --- a/ocaml/sdk-gen/csharp/autogen/dune +++ b/ocaml/sdk-gen/csharp/autogen/dune @@ -1,11 +1,8 @@ (rule - (alias generate) - (targets LICENSE) - (deps - ../../LICENSE - ) - (action (copy %{deps} %{targets})) -) + (alias generate) + (targets LICENSE) + (deps ../../LICENSE) + (action + (copy %{deps} %{targets}))) (data_only_dirs src) - diff --git a/ocaml/sdk-gen/csharp/dune b/ocaml/sdk-gen/csharp/dune index 07e2fd42950..25f35763c4b 100644 --- a/ocaml/sdk-gen/csharp/dune +++ b/ocaml/sdk-gen/csharp/dune @@ -1,60 +1,41 @@ (executable - (modes exe) - (name gen_csharp_binding) - (modules Gen_csharp_binding) - (libraries - astring - CommonFunctions - - mustache - xapi-consts - xapi-datamodel - ) -) + (modes exe) + (name gen_csharp_binding) + (modules Gen_csharp_binding) + (libraries astring CommonFunctions mustache xapi-consts xapi-datamodel)) (executable - (modes exe) - (name friendly_error_names) - (modules Friendly_error_names) - (libraries - CommonFunctions - - mustache - xapi-datamodel - xmllight2 - str - ) -) + (modes exe) + (name friendly_error_names) + (modules Friendly_error_names) + (libraries CommonFunctions mustache xapi-datamodel xmllight2 str)) (rule - (alias generate) - (targets (dir autogen-out)) - (deps - (:x gen_csharp_binding.exe) - (source_tree templates) - (:sh ../windows-line-endings.sh) - (source_tree autogen) - (:x2 friendly_error_names.exe) - FriendlyErrorNames.resx - (:y XE_SR_ERRORCODES.xml) - (source_tree templates) - ) - (action - (progn - (concurrent - (bash "cp -r autogen/ autogen-out/") - (run %{x}) - (run %{x2} -s %{y}) - ) - (bash "rm autogen-out/.gitignore") - (bash "%{sh} autogen-out/") - )) -) + (alias generate) + (targets + (dir autogen-out)) + (deps + (:x gen_csharp_binding.exe) + (source_tree templates) + (:sh ../windows-line-endings.sh) + (source_tree autogen) + (:x2 friendly_error_names.exe) + FriendlyErrorNames.resx + (:y XE_SR_ERRORCODES.xml) + (source_tree templates)) + (action + (progn + (progn + (bash "cp -r autogen/ autogen-out/") + (run %{x}) + (run %{x2} -s %{y})) + (bash "rm autogen-out/.gitignore") + (bash "%{sh} autogen-out/")))) (data_only_dirs templates) (install - (package xapi-sdk) - (section share_root) - (dirs (autogen-out as csharp)) -) + (package xapi-sdk) + (section share_root) + (dirs + (autogen-out as csharp))) diff --git a/ocaml/sdk-gen/dune b/ocaml/sdk-gen/dune index 76bdaaab2ca..6c4a09913d5 100644 --- a/ocaml/sdk-gen/dune +++ b/ocaml/sdk-gen/dune @@ -1,18 +1,16 @@ (data_only_dirs component-test) (alias - (name sdkgen) - (package xapi-sdk) - (deps - c/gen_c_binding.exe - csharp/gen_csharp_binding.exe - java/main.exe - powershell/gen_powershell_binding.exe - go/gen_go_binding.exe - (alias_rec c/generate) - (alias_rec csharp/generate) - (alias_rec java/generate) - (alias_rec powershell/generate) - (alias_rec go/generate) - ) -) + (name sdkgen) + (package xapi-sdk) + (deps + c/gen_c_binding.exe + csharp/gen_csharp_binding.exe + java/main.exe + powershell/gen_powershell_binding.exe + go/gen_go_binding.exe + (alias_rec c/generate) + (alias_rec csharp/generate) + (alias_rec java/generate) + (alias_rec powershell/generate) + (alias_rec go/generate))) diff --git a/ocaml/sdk-gen/go/autogen/dune b/ocaml/sdk-gen/go/autogen/dune index 98bbd45a418..05b35e921a1 100644 --- a/ocaml/sdk-gen/go/autogen/dune +++ b/ocaml/sdk-gen/go/autogen/dune @@ -1,26 +1,20 @@ (rule - (targets LICENSE) - (deps - ../../LICENSE - ) - (action (copy %{deps} %{targets})) -) + (targets LICENSE) + (deps ../../LICENSE) + (action + (copy %{deps} %{targets}))) (rule - (targets README) - (deps - ../README.md - ) - (action (copy %{deps} %{targets})) -) + (targets README) + (deps ../README.md) + (action + (copy %{deps} %{targets}))) (alias - (name generate) - (deps - LICENSE - README - (source_tree .) - ) -) + (name generate) + (deps + LICENSE + README + (source_tree .))) (data_only_dirs src) diff --git a/ocaml/sdk-gen/go/dune b/ocaml/sdk-gen/go/dune index a126ee856bd..64717b85c6d 100644 --- a/ocaml/sdk-gen/go/dune +++ b/ocaml/sdk-gen/go/dune @@ -1,60 +1,52 @@ (executable - (modes exe) - (name gen_go_binding) - (modules gen_go_binding) - (libraries - CommonFunctions - mustache - xapi-datamodel - xapi-stdext-unix - gen_go_helper - ) -) + (modes exe) + (name gen_go_binding) + (modules gen_go_binding) + (libraries + CommonFunctions + mustache + xapi-datamodel + xapi-stdext-unix + gen_go_helper)) (library - (name gen_go_helper) - (modules gen_go_helper) - (modes best) - (libraries - CommonFunctions - astring - (re_export mustache) - (re_export xapi-consts) - (re_export xapi-datamodel) - xapi-stdext-std - ) -) + (name gen_go_helper) + (modules gen_go_helper) + (modes best) + (libraries + CommonFunctions + astring + (re_export mustache) + (re_export xapi-consts) + (re_export xapi-datamodel) + xapi-stdext-std)) (rule - (alias generate) - (targets (dir autogen-out)) - (deps - (:x gen_go_binding.exe) - (source_tree templates) - (source_tree autogen) - ) - (action - (concurrent - (bash "cp -r autogen/ autogen-out/") - (run %{x} --destdir autogen-out) - ) - ) -) + (alias generate) + (targets + (dir autogen-out)) + (deps + (:x gen_go_binding.exe) + (source_tree templates) + (source_tree autogen)) + (action + (progn + (bash "cp -r autogen/ autogen-out/") + (run %{x} --destdir autogen-out)))) (test - (name test_gen_go) - (package xapi-sdk) - (modules test_gen_go) - (libraries CommonFunctions alcotest fmt xapi-test-utils gen_go_helper) - (deps - (source_tree test_data) - (source_tree templates) - ) -) + (name test_gen_go) + (package xapi-sdk) + (modules test_gen_go) + (libraries CommonFunctions alcotest fmt xapi-test-utils gen_go_helper) + (deps + (source_tree test_data) + (source_tree templates))) (data_only_dirs test_data templates) + (install - (package xapi-sdk) - (section share_root) - (dirs (autogen-out as go)) -) + (package xapi-sdk) + (section share_root) + (dirs + (autogen-out as go))) diff --git a/ocaml/sdk-gen/java/autogen/dune b/ocaml/sdk-gen/java/autogen/dune index da324f0b9d0..e14eba6a578 100644 --- a/ocaml/sdk-gen/java/autogen/dune +++ b/ocaml/sdk-gen/java/autogen/dune @@ -1,9 +1,6 @@ (alias - (name generate) - (deps - (source_tree .) - ) -) + (name generate) + (deps + (source_tree .))) (data_only_dirs xen-api) - diff --git a/ocaml/sdk-gen/java/autogen/xen-api/pom.xml b/ocaml/sdk-gen/java/autogen/xen-api/pom.xml index c3a6cabdfda..5dc18e7ec61 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 07167296b84..31fd56640a6 100644 --- a/ocaml/sdk-gen/java/dune +++ b/ocaml/sdk-gen/java/dune @@ -1,44 +1,38 @@ (executable - (modes exe) - (name main) - (libraries - astring - CommonFunctions - - mustache - str - xapi-datamodel - xapi-stdext-unix - ) -) + (modes exe) + (name main) + (libraries + astring + CommonFunctions + mustache + str + xapi-datamodel + xapi-stdext-unix)) (rule - (targets LICENSE) - (deps - ../LICENSE - ) - (action (copy %{deps} %{targets})) -) + (targets LICENSE) + (deps ../LICENSE) + (action + (copy %{deps} %{targets}))) (rule - (alias generate) - (targets (dir autogen-out)) - (deps - LICENSE - (:x main.exe) - (source_tree templates) - (source_tree autogen) - ) - (action (concurrent - (bash "cp -r autogen/ autogen-out/") - (run %{x}) - )) -) + (alias generate) + (targets + (dir autogen-out)) + (deps + LICENSE + (:x main.exe) + (source_tree templates) + (source_tree autogen)) + (action + (progn + (bash "cp -r autogen/ autogen-out/") + (run %{x})))) (data_only_dirs templates) (install - (package xapi-sdk) - (section share_root) - (dirs (autogen-out as java)) -) + (package xapi-sdk) + (section share_root) + (dirs + (autogen-out as java))) diff --git a/ocaml/sdk-gen/powershell/autogen/dune b/ocaml/sdk-gen/powershell/autogen/dune index c4c2a5f8633..4cfb2b8c487 100644 --- a/ocaml/sdk-gen/powershell/autogen/dune +++ b/ocaml/sdk-gen/powershell/autogen/dune @@ -1,22 +1,20 @@ (rule - (targets LICENSE) - (deps - ../../LICENSE - ) - (action (copy %{deps} %{targets})) -) + (targets LICENSE) + (deps ../../LICENSE) + (action + (copy %{deps} %{targets}))) (alias - (name generate) - (deps - LICENSE - (source_tree .) - ) -) + (name generate) + (deps + LICENSE + (source_tree .))) (data_only_dirs src) + (install - (package xapi-sdk) - (section doc) - (files (glob_files_rec (autogen/* with_prefix powershell))) -) + (package xapi-sdk) + (section doc) + (files + (glob_files_rec + (autogen/* with_prefix powershell)))) diff --git a/ocaml/sdk-gen/powershell/dune b/ocaml/sdk-gen/powershell/dune index 7eb4d3e56d6..6fdee3e0fcf 100644 --- a/ocaml/sdk-gen/powershell/dune +++ b/ocaml/sdk-gen/powershell/dune @@ -1,38 +1,29 @@ (executable - (modes exe) - (name gen_powershell_binding) - (libraries - astring - CommonFunctions - - mustache - xapi-datamodel - ) -) + (modes exe) + (name gen_powershell_binding) + (libraries astring CommonFunctions mustache xapi-datamodel)) (rule - (alias generate) - (targets (dir autogen-out)) - (deps - (:x gen_powershell_binding.exe) - (source_tree templates) - (:sh ../windows-line-endings.sh) - (source_tree autogen) - ) - (action - (progn - (concurrent - (bash "cp -r autogen/ autogen-out/") - (run %{x}) - ) - (bash "rm autogen-out/.gitignore") - (bash "%{sh} autogen-out/") - )) -) + (alias generate) + (targets + (dir autogen-out)) + (deps + (:x gen_powershell_binding.exe) + (source_tree templates) + (:sh ../windows-line-endings.sh) + (source_tree autogen)) + (action + (progn + (progn + (bash "cp -r autogen/ autogen-out/") + (run %{x})) + (bash "rm autogen-out/.gitignore") + (bash "%{sh} autogen-out/")))) (data_only_dirs templates) + (install - (package xapi-sdk) - (section share_root) - (dirs (autogen-out as powershell)) -) + (package xapi-sdk) + (section share_root) + (dirs + (autogen-out as powershell))) diff --git a/ocaml/tests/bench/bechamel_simple_cli.ml b/ocaml/tests/bench/bechamel_simple_cli.ml index e40399cf04d..bcbd574f7f0 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 e81a8991cb4..bcba2ed6cf3 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 00000000000..bd34693a92f --- /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 50582eff4cc..b4f61173420 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 eebe6e6aef2..8db30cfc220 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 f13118e48db..53e817211a6 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 new file mode 100644 index 00000000000..5b13084370a --- /dev/null +++ b/ocaml/tests/bench/bench_vdi_allowed_operations.ml @@ -0,0 +1,58 @@ +open Bechamel + +module D = Debug.Make (struct let name = __MODULE__ end) + +(* tested configuration limits *) +let max_hosts = 64 + +let max_vms = (*2400*) 240 + +let max_vbds = (* 255 *) 25 + +let () = + (* a minimal harness init *) + Suite_init.harness_init () ; + (* don't spam the logs in [allocate] *) + Debug.set_level Syslog.Info + +let allocate () = + let open Test_common in + let __context = make_test_database () in + let (_sm_ref : API.ref_SM) = make_sm ~__context () in + let sr_ref = make_sr ~__context () in + let (_ : API.ref_PBD array) = + Array.init max_hosts (fun _ -> make_pbd ~__context ~sR:sr_ref ()) + in + let vms = + Array.init max_vms @@ fun _ -> + let vm_ref = make_vm ~__context () in + Array.init (max_vbds / 2) @@ fun _ -> + let vdi_ref = make_vdi ~__context ~sR:sr_ref () in + let vbd_ref = + make_vbd ~__context ~vDI:vdi_ref ~vM:vm_ref ~currently_attached:true + ~mode:`RO () + in + let vdi_ref' = make_vdi ~__context ~sR:sr_ref () in + let vbd_ref' = + make_vbd ~__context ~vDI:vdi_ref' ~vM:vm_ref ~currently_attached:true + ~mode:`RW () + in + (vdi_ref, vbd_ref, vdi_ref', vbd_ref') + in + D.info "Created test database" ; + (__context, vms) + +let test_vdi_update_allowed_operations (__context, vm_disks) = + let _, _, vdi_ref, vbd_ref = vm_disks.(0).(0) in + Db.VBD.set_currently_attached ~__context ~self:vbd_ref ~value:true ; + Xapi_vdi.update_allowed_operations ~__context ~self:vdi_ref ; + Db.VBD.set_currently_attached ~__context ~self:vbd_ref ~value:false ; + Xapi_vdi.update_allowed_operations ~__context ~self:vdi_ref + +let benchmarks = + [ + 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 0c088389dfe..fe0af458c14 100644 --- a/ocaml/tests/bench/dune +++ b/ocaml/tests/bench/dune @@ -1,4 +1,31 @@ (executables - (names bench_tracing bench_uuid bench_throttle2 bench_cached_reads) - (libraries tracing bechamel bechamel-notty notty.unix tracing_export threads.posix fmt notty uuid xapi_aux tests_common log xapi_internal) -) + (names + bench_tracing + bench_uuid + bench_throttle2 + bench_cached_reads + 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_database + xapi_datamodel + xapi_internal + xapi-stdext-threads)) diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index 3ff9bea2380..9e4703f117c 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -170,13 +170,16 @@ 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) () = 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 in Db.Host.set_cpu_info ~__context ~self:host ~value:default_cpu_info ; host @@ -215,7 +218,8 @@ 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 ; ref let make_pif ~__context ~network ~host ?(device = "eth0") diff --git a/ocaml/tests/dune b/ocaml/tests/dune index c4b590c6cb8..7a3620fb6c3 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -15,7 +15,7 @@ angstrom astring cstruct - + digestif fmt http_lib httpsvr diff --git a/ocaml/tests/test_certificates.ml b/ocaml/tests/test_certificates.ml index 96017d3156a..dcd018e0993 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_extauth_plugin_ADwinbind.ml b/ocaml/tests/test_extauth_plugin_ADwinbind.ml index 5fe5bfc91cd..6b3e58e3b34 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_host.ml b/ocaml/tests/test_host.ml index edca58ac032..03f526d08d0 100644 --- a/ocaml/tests/test_host.ml +++ b/ocaml/tests/test_host.ml @@ -24,6 +24,8 @@ 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 ) (* Creates an unlicensed pool with the maximum number of hosts *) diff --git a/ocaml/tests/test_repository_helpers.ml b/ocaml/tests/test_repository_helpers.ml index c05e7c8a63e..d6c8421afdb 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_storage_migrate_state.ml b/ocaml/tests/test_storage_migrate_state.ml index 498d9995548..ea059ae07e2 100644 --- a/ocaml/tests/test_storage_migrate_state.ml +++ b/ocaml/tests/test_storage_migrate_state.ml @@ -41,6 +41,9 @@ let sample_send_state = ) ; failed= false ; watchdog= None + ; live_vm= Storage_interface.Vm.of_string "0" + ; mirror_key= None + ; vdi= Storage_interface.Vdi.of_string "" } let sample_receive_state = @@ -54,6 +57,8 @@ let sample_receive_state = ; parent_vdi= Vdi.of_string "parent_vdi" ; remote_vdi= Vdi.of_string "remote_vdi" ; mirror_vm= Vm.of_string "mirror_vm" + ; url= "" + ; verify_dest= false } let sample_copy_state = diff --git a/ocaml/xapi-aux/networking_info.ml b/ocaml/xapi-aux/networking_info.ml index 52de3fb12f6..928ad45322b 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 ced93d30dd5..4c8418443ab 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-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 389b880a268..2f6d2350345 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -958,8 +958,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= [] } ) @@ -1841,6 +1842,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"] @@ -2865,7 +2881,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] diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 431cc76fa80..fb75f559099 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -3490,31 +3490,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) @@ -5368,13 +5381,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 = @@ -6907,12 +6928,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 diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index da839d1e3f4..cb88ace5540 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,42 @@ 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) + ) + () ] } @@ -3286,6 +3355,26 @@ 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) + ) + () ] } diff --git a/ocaml/xapi-client/tasks.ml b/ocaml/xapi-client/tasks.ml index c62f681d602..a9da21890ec 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 8989b01716f..a396c569aef 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 906e22bf259..d5927c91bfb 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -757,6 +757,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 +1323,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,6 +1428,12 @@ 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 host_driver_no_hardware = add_error "HOST_DRIVER_NO_HARDWARE" let tls_verification_not_enabled_in_pool = diff --git a/ocaml/xapi-consts/constants.ml b/ocaml/xapi-consts/constants.ml index 3072a459c00..185f9669a7c 100644 --- a/ocaml/xapi-consts/constants.ml +++ b/ocaml/xapi-consts/constants.ml @@ -422,3 +422,9 @@ 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 diff --git a/ocaml/xapi-idl/cluster/cli-help.t b/ocaml/xapi-idl/cluster/cli-help.t new file mode 100644 index 00000000000..5b9362aa648 --- /dev/null +++ b/ocaml/xapi-idl/cluster/cli-help.t @@ -0,0 +1,115 @@ + $ ./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_interval [OPTION]… dbg float + + Observer.set_host_id [OPTION]… dbg string + + 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/dune b/ocaml/xapi-idl/cluster/dune index 50777aeb2b3..f1ec6e321de 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 00000000000..c38ea73040c --- /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 cf27e69dcf3..db360ff8030 100644 --- a/ocaml/xapi-idl/example/dune +++ b/ocaml/xapi-idl/example/dune @@ -9,8 +9,6 @@ ) (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 00000000000..afe309b014f --- /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 de10e06dae6..269a6690eeb 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 00000000000..0e990ca9490 --- /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 cdb888692d1..b5de6b38b8a 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 00000000000..6f36f4bf5bd --- /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 abded2e1c17..6957b6c7a78 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/debug_info.ml b/ocaml/xapi-idl/lib/debug_info.ml index 5483d6bc451..edf3c4979a8 100644 --- a/ocaml/xapi-idl/lib/debug_info.ml +++ b/ocaml/xapi-idl/lib/debug_info.ml @@ -76,7 +76,7 @@ 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 ?(with_thread = false) ?(module_name = "") ~name ~dbg f = let di = of_string dbg in let f_with_trace () = let name = diff --git a/ocaml/xapi-idl/lib/debug_info.mli b/ocaml/xapi-idl/lib/debug_info.mli index fa2f6ff5d6a..9db63471035 100644 --- a/ocaml/xapi-idl/lib/debug_info.mli +++ b/ocaml/xapi-idl/lib/debug_info.mli @@ -24,7 +24,7 @@ val to_log_string : t -> string val with_dbg : ?with_thread:bool - -> module_name:string + -> ?module_name:string -> name:string -> dbg:string -> (t -> 'a) diff --git a/ocaml/xapi-idl/lib/xcp_client.ml b/ocaml/xapi-idl/lib/xcp_client.ml index 3ea0006b59c..435a63e3126 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) () ) ) diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index 817825c44fe..8250842689b 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/memory/cli-help.t b/ocaml/xapi-idl/memory/cli-help.t new file mode 100644 index 00000000000..ff85cda4f0d --- /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 f0f70e0a69e..7df6724a299 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 00000000000..b8878a9040d --- /dev/null +++ b/ocaml/xapi-idl/network/cli-help.t @@ -0,0 +1,156 @@ + $ ./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_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 a9a4869945d..d1016ae8821 100644 --- a/ocaml/xapi-idl/network/dune +++ b/ocaml/xapi-idl/network/dune @@ -21,7 +21,7 @@ (modules network_cli) (libraries cmdliner - + rpclib.cmdliner rpclib.core rpclib.markdown @@ -29,8 +29,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/rrd/cli-help.t b/ocaml/xapi-idl/rrd/cli-help.t new file mode 100644 index 00000000000..a503e0b75bb --- /dev/null +++ b/ocaml/xapi-idl/rrd/cli-help.t @@ -0,0 +1,193 @@ + $ ./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 + + update_vm_memory_target [OPTION]… domid 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. + + 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 f7b2a8e7b70..e0e8693c13f 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/storage/storage_interface.ml b/ocaml/xapi-idl/storage/storage_interface.ml index b98047bd610..14ca03e6cb8 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] @@ -291,12 +304,42 @@ module Mirror = struct } [@@deriving rpcty] - type mirror_receive_result = Vhd_mirror of mirror_receive_result_vhd_t + type mirror_receive_result_smapiv3_t = { + mirror_vdi: vdi_info + ; mirror_datapath: dp + ; nbd_export: string + } + [@@deriving rpcty] + + (* The variant of the mirror receive result depends on the SMAPI version being used, + rather than the VDI image type. We call the new variant SMAPIv3_mirror to reflect + this, but keep the old one Vhd_mirror for backwards compatability reasons. *) + type mirror_receive_result = + | Vhd_mirror of mirror_receive_result_vhd_t + | SMAPIv3_mirror of mirror_receive_result_smapiv3_t [@@deriving rpcty] type similars = content_id list [@@deriving rpcty] + + type copy_operation_v1 = string [@@deriving rpcty, show {with_path= false}] + + type mirror_operation_v1 = string [@@deriving rpcty, show {with_path= false}] + + (* SMAPIv3 mirror operation *) + type operation = + | CopyV1 of copy_operation_v1 + | MirrorV1 of mirror_operation_v1 + [@@deriving rpcty, show {with_path= false}] + + (* status of SMAPIv3 mirror *) + type status = {failed: bool; complete: bool; progress: float option} + [@@deriving rpcty] end +type operation = Mirror.operation + +type status = Mirror.status + type async_result_t = Vdi_info of vdi_info | Mirror_id of Mirror.id [@@deriving rpcty] @@ -373,7 +416,7 @@ module Errors = struct (* mirror_copy_failure: raised when copying of the base image fails (SMAPIv1 only) *) | Migration_mirror_copy_failure of string (* mirror_failure: raised when there is any issues that causes the mirror to crash - during SXM (SMAPIv3 only, v1 uses more specific errors as above) *) + during SXM (SMAPIv1 and SMAPIv3 *) | Migration_mirror_failure of string | Internal_error of string | Unknown_error @@ -1013,6 +1056,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 = @@ -1080,7 +1146,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 @@ -1094,8 +1160,11 @@ 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 @@ -1109,28 +1178,91 @@ 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_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 + @-> id_p + @-> similar_p + @-> vm_p + @-> url_p + @-> verify_dest_p + @-> returning result err + ) + (** 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 + @-> url_p + @-> verify_dest_p + @-> returning unit_p err + ) + (** [receive_cancel dbg id] is called in the case of migration failure to - do the clean up.*) + do the clean up. + @deprecated This function is deprecated, and is only here to keep backward + compatibility with old xapis that call Remote.DATA.MIRROR.receive_cancel + during SXM. Use the receive_cancel2 function instead. + *) let receive_cancel = declare "DATA.MIRROR.receive_cancel" [] (dbg_p @-> id_p @-> returning unit_p err) + + (** [receive_cancel2 dbg mirror_id url verify_dest] cleans up the side effects + 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 @@ -1215,11 +1347,50 @@ module type MIRROR = sig -> 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 + -> url:string + -> verify_dest:bool + -> Mirror.mirror_receive_result + val receive_finalize : context -> dbg:debug_info -> id:Mirror.id -> unit val receive_finalize2 : context -> dbg:debug_info -> id:Mirror.id -> unit + val receive_finalize3 : + context + -> dbg:debug_info + -> mirror_id:Mirror.id + -> sr:sr + -> url:string + -> verify_dest:bool + -> unit + val receive_cancel : context -> dbg:debug_info -> id:Mirror.id -> unit + + val receive_cancel2 : + context + -> dbg:debug_info + -> mirror_id:Mirror.id + -> 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 @@ -1478,6 +1649,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 @@ -1652,6 +1841,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 @@ -1679,15 +1874,35 @@ module Server (Impl : Server_impl) () = struct 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_start3 () ~dbg ~sr ~vdi_info ~mirror_id + ~similar ~vm ~url ~verify_dest + ) ; S.DATA.MIRROR.receive_cancel (fun dbg id -> Impl.DATA.MIRROR.receive_cancel () ~dbg ~id ) ; + S.DATA.MIRROR.receive_cancel2 (fun dbg mirror_id url verify_dest -> + Impl.DATA.MIRROR.receive_cancel2 () ~dbg ~mirror_id ~url ~verify_dest + ) ; S.DATA.MIRROR.receive_finalize (fun dbg id -> Impl.DATA.MIRROR.receive_finalize () ~dbg ~id ) ; 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 27197b06c7c..290c09d6230 100644 --- a/ocaml/xapi-idl/storage/storage_skeleton.ml +++ b/ocaml/xapi-idl/storage/storage_skeleton.ml @@ -154,6 +154,10 @@ let get_by_name ctx ~dbg ~name = u "get_by_name" module DATA = struct let copy ctx ~dbg ~sr ~vdi ~vm ~url ~dest = u "DATA.copy" + let mirror ctx ~dbg ~sr ~vdi ~vm ~dest = u "DATA.mirror" + + let stat ctx ~dbg ~sr ~vdi ~vm ~key = u "DATA.stat" + let import_activate ctx ~dbg ~dp ~sr ~vdi ~vm = u "DATA.MIRROR.import_activate" @@ -172,11 +176,31 @@ module DATA = struct let receive_start2 ctx ~dbg ~sr ~vdi_info ~id ~similar ~vm = u "DATA.MIRROR.receive_start2" + let receive_start3 ctx ~dbg ~sr ~vdi_info ~mirror_id ~similar ~vm ~url + ~verify_dest = + u "DATA.MIRROR.receive_start3" + let receive_finalize ctx ~dbg ~id = u "DATA.MIRROR.receive_finalize" let receive_finalize2 ctx ~dbg ~id = u "DATA.MIRROR.receive_finalize2" + let receive_finalize3 ctx ~dbg ~mirror_id ~sr ~url ~verify_dest = + u "DATA.MIRROR.receive_finalize3" + let receive_cancel ctx ~dbg ~id = u "DATA.MIRROR.receive_cancel" + + let receive_cancel2 ctx ~dbg ~mirror_id ~url ~verify_dest = + u "DATA.MIRROR.receive_cancel2" + + let pre_deactivate_hook ctx ~dbg ~dp ~sr ~vdi = + u "DATA.MIRROR.pre_deactivate_hook" + + let has_mirror_failed ctx ~dbg ~mirror_id ~sr = + u "DATA.MIRROR.has_mirror_failed" + + let list ctx ~dbg = u "DATA.MIRROR.list" + + let stat ctx ~dbg ~id = u "DATA.MIRROR.stat" end end diff --git a/ocaml/xapi-idl/v6/cli-help.t b/ocaml/xapi-idl/v6/cli-help.t new file mode 100644 index 00000000000..ed7d3b47ba5 --- /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 79751c08794..3fb2579af06 100644 --- a/ocaml/xapi-idl/v6/dune +++ b/ocaml/xapi-idl/v6/dune @@ -19,7 +19,7 @@ (modules v6_cli) (libraries cmdliner - + rpclib.cmdliner rpclib.core rpclib.markdown @@ -28,8 +28,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/xen/xenops_interface.ml b/ocaml/xapi-idl/xen/xenops_interface.ml index 68ef01b29c9..a883152207a 100644 --- a/ocaml/xapi-idl/xen/xenops_interface.ml +++ b/ocaml/xapi-idl/xen/xenops_interface.ml @@ -496,9 +496,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 +721,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 +735,7 @@ module XenopsAPI (R : RPC) = struct @-> xenops_url @-> compress @-> verify_dest + @-> localhost_migration @-> returning task_id_p err ) diff --git a/ocaml/xapi-storage-cli/main.ml b/ocaml/xapi-storage-cli/main.ml index 536ea02608e..f581d6b6b48 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 @@ -315,6 +315,8 @@ let mirror_vm = Vm.of_string "SXM_mirror" let copy_vm = Vm.of_string "SXM_copy" +let live_vm = Vm.of_string "live_vm" + let mirror_start common_opts sr vdi dp url dest verify_dest = on_vdi' (fun sr vdi -> @@ -323,7 +325,8 @@ let mirror_start common_opts sr vdi dp url dest verify_dest = let url = get_opt url "Need a URL" in let dest = get_opt dest "Need a destination SR" in let task = - Storage_migrate.start ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url + Storage_migrate.start ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~live_vm + ~url ~dest:(Storage_interface.Sr.of_string dest) ~verify_dest in diff --git a/ocaml/xapi-storage-script/dune b/ocaml/xapi-storage-script/dune index e1391aed2ca..435c7a8ecf6 100644 --- a/ocaml/xapi-storage-script/dune +++ b/ocaml/xapi-storage-script/dune @@ -76,20 +76,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 eb63f132e98..1b15a17f46e 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 @@ -1456,6 +1457,9 @@ 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 () -> let response = { (vdi_of_volume response) with @@ -1753,6 +1757,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 +1795,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 +1917,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 +1962,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,15 +1983,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") ; 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 00000000000..9ac59bed953 --- /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-types/dune b/ocaml/xapi-types/dune index ab33ae1f354..3a49a7dca2e 100644 --- a/ocaml/xapi-types/dune +++ b/ocaml/xapi-types/dune @@ -23,6 +23,8 @@ 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 83c82b0bc8d..46ea2d310df 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 52469387acc..7453ab49a7c 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/cancel_tasks.ml b/ocaml/xapi/cancel_tasks.ml index 3ec7594f378..b15e0aac057 100644 --- a/ocaml/xapi/cancel_tasks.ml +++ b/ocaml/xapi/cancel_tasks.ml @@ -84,14 +84,14 @@ let update_all_allowed_operations ~__context = in let vbd_records = List.map - (fun vbd -> (vbd, Db.VBD.get_record_internal ~__context ~self:vbd)) + (fun vbd -> Db.VBD.get_record_internal ~__context ~self:vbd) all_vbds in List.iter (safe_wrapper "allowed_ops - VDIs" (fun self -> let relevant_vbds = List.filter - (fun (_, vbd_record) -> vbd_record.Db_actions.vBD_VDI = self) + (fun vbd_record -> vbd_record.Db_actions.vBD_VDI = self) vbd_records in Xapi_vdi.update_allowed_operations_internal ~__context ~self diff --git a/ocaml/xapi/cert_refresh.ml b/ocaml/xapi/cert_refresh.ml index 12ab75dc230..213d0abc224 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 4d9702bb439..f69497ce118 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -32,7 +32,7 @@ open D 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 064c7e47e31..6776220df45 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 a9691adf298..2ab3492ffa8 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/console.ml b/ocaml/xapi/console.ml index 03cb4bf9559..b812cf65c76 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/db.ml b/ocaml/xapi/db.ml index 4b4b6c2deea..f343086a2d2 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_util.ml b/ocaml/xapi/db_gc_util.ml index 202b51cc5eb..bcacc7d86c0 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 = diff --git a/ocaml/xapi/dbsync_slave.ml b/ocaml/xapi/dbsync_slave.ml index 366990e2692..51ef2665d15 100644 --- a/ocaml/xapi/dbsync_slave.ml +++ b/ocaml/xapi/dbsync_slave.ml @@ -60,6 +60,10 @@ 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 in () @@ -376,5 +380,10 @@ 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 + ) ; remove_pending_guidances ~__context diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 85f4bf030af..88213955afc 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -138,6 +138,7 @@ clock cohttp cohttp_posix + digestif domain-name ezxenstore.core fmt diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index 753bb8fdf7b..810b30bd80b 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 81dcb22bc44..3c00b544f73 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 ; diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index b3458478e3e..a279de5c5c7 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -686,11 +686,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) = @@ -1347,13 +1366,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 +1403,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 +1420,90 @@ 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 ResolveConfig = struct + let path = "/etc/resolv.conf" + + type t = Add | Remove + + let handle op domain = + let open Xapi_stdext_unix.Unixext in + let config = Printf.sprintf "search %s" domain in + read_lines ~path |> List.filter (fun x -> x <> config) |> fun x -> + (match op with Add -> config :: x | Remove -> x) |> fun x -> + x @ [""] |> String.concat "\n" |> write_string_to_file path + + let join ~domain = handle Add domain + + let leave ~domain = handle Remove domain +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 @@ -1721,6 +1827,8 @@ 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 ; + ResolveConfig.join ~domain:service_name ; + DNSSync.trigger_sync ~start:0. ; Winbind.set_machine_account_encryption_type netbios_name ; debug "Succeed to join domain %s" service_name with @@ -1728,6 +1836,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct error "Join domain: %s error: %s" service_name stdout ; clear_winbind_config () ; ConfigHosts.leave ~domain:service_name ~name:netbios_name ; + ResolveConfig.leave ~domain:service_name ; (* The configure is kept for debug purpose with max level *) raise (Auth_service_error (stdout |> tag_from_err_msg, stdout)) | Xapi_systemctl.Systemctl_fail _ -> @@ -1735,6 +1844,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct error "Start daemon error: %s" msg ; config_winbind_daemon ~domain:None ~workgroup:None ~netbios_name:None ; ConfigHosts.leave ~domain:service_name ~name:netbios_name ; + ResolveConfig.leave ~domain:service_name ; raise (Auth_service_error (E_GENERIC, msg)) | e -> let msg = @@ -1746,6 +1856,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct error "Enable extauth error: %s" msg ; clear_winbind_config () ; ConfigHosts.leave ~domain:service_name ~name:netbios_name ; + ResolveConfig.leave ~domain:service_name ; raise (Auth_service_error (E_GENERIC, msg)) (* unit on_disable() @@ -1760,9 +1871,13 @@ 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 + ResolveConfig.leave ~domain:service_name ; + 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 +1907,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/helpers.ml b/ocaml/xapi/helpers.ml index 2ef16112053..75199a62fa9 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -157,7 +157,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 @@ -606,14 +606,6 @@ let call_emergency_mode_functions hostname f = (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. - let is_domain_zero_with_record ~__context vm_ref vm_rec = let host_ref = vm_rec.API.vM_resident_on in vm_rec.API.vM_is_control_domain @@ -1349,13 +1341,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 diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index dc77569e646..d1773e4f0c6 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -1185,6 +1185,18 @@ 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 end module VM = struct @@ -2018,6 +2030,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 ; @@ -4035,6 +4075,22 @@ 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 end module Host_crashdump = struct diff --git a/ocaml/xapi/pool_db_backup.ml b/ocaml/xapi/pool_db_backup.ml index 2a0ab1eae21..f82e3340c12 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/repository.ml b/ocaml/xapi/repository.ml index 1ec1486a3e2..ea87a715e17 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 ; diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 62df609c53a..91a3c1b4670 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/storage_access.ml b/ocaml/xapi/storage_access.ml index 6f2b540dac4..cda399e9d60 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 ae3344d788b..1ff03c3d7ed 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -40,149 +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 - let receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm = - let on_fail : (unit -> unit) list ref = ref [] in - let vdis = Local.SR.scan dbg sr in - (* We drop cbt_metadata VDIs that do not have any actual data *) - let vdis = List.filter (fun vdi -> vdi.ty <> "cbt_metadata") vdis in - let leaf_dp = Local.DP.create dbg Uuidx.(to_string (make ())) in - try - let vdi_info = {vdi_info with sm_config= [("base_mirror", id)]} in - let leaf = Local.VDI.create dbg sr vdi_info in - info "Created leaf VDI for mirror receive: %s" (string_of_vdi_info leaf) ; - on_fail := (fun () -> Local.VDI.destroy dbg sr leaf.vdi) :: !on_fail ; - (* dummy VDI is created so that the leaf VDI becomes a differencing disk, - useful for calling VDI.compose later on *) - let dummy = Local.VDI.snapshot dbg sr leaf in - on_fail := (fun () -> Local.VDI.destroy dbg sr dummy.vdi) :: !on_fail ; - debug "%s Created dummy snapshot for mirror receive: %s" __FUNCTION__ - (string_of_vdi_info dummy) ; - let _ : backend = Local.VDI.attach3 dbg leaf_dp sr leaf.vdi vm true in - Local.VDI.activate3 dbg leaf_dp sr leaf.vdi vm ; - let nearest = - List.fold_left - (fun acc content_id -> - match acc with - | Some _ -> - acc - | None -> ( - try - Some - (List.find - (fun vdi -> - vdi.content_id = content_id - && vdi.virtual_size <= vdi_info.virtual_size - ) - vdis - ) - with Not_found -> None - ) - ) - None similar - in - debug "Nearest VDI: content_id=%s vdi=%s" - (Option.fold ~none:"None" ~some:(fun x -> x.content_id) nearest) - (Option.fold ~none:"None" - ~some:(fun x -> Storage_interface.Vdi.string_of x.vdi) - nearest - ) ; - let parent = - match nearest with - | Some vdi -> - debug "Cloning VDI" ; - let vdi = add_to_sm_config vdi "base_mirror" id in - let vdi_clone = Local.VDI.clone dbg sr vdi in - debug "Clone: %s" (Storage_interface.Vdi.string_of vdi_clone.vdi) ; - ( if vdi_clone.virtual_size <> vdi_info.virtual_size then - let new_size = - Local.VDI.resize dbg sr vdi_clone.vdi vdi_info.virtual_size - in - debug "Resize local clone VDI to %Ld: result %Ld" - vdi_info.virtual_size new_size - ) ; - vdi_clone - | None -> - debug "Creating a blank remote VDI" ; - Local.VDI.create dbg sr vdi_info - in - debug "Parent disk content_id=%s" parent.content_id ; - State.add id - State.( - Recv_op - Receive_state. - { - sr - ; dummy_vdi= dummy.vdi - ; leaf_vdi= leaf.vdi - ; leaf_dp - ; parent_vdi= parent.vdi - ; remote_vdi= vdi_info.vdi - ; mirror_vm= vm - } - ) ; - let nearest_content_id = Option.map (fun x -> x.content_id) nearest in - Mirror.Vhd_mirror - { - Mirror.mirror_vdi= leaf - ; mirror_datapath= leaf_dp - ; copy_diffs_from= nearest_content_id - ; copy_diffs_to= parent.vdi - ; dummy_vdi= dummy.vdi - } - with e -> - List.iter - (fun op -> - try op () - with e -> - debug "Caught exception in on_fail: %s" (Printexc.to_string e) - ) - !on_fail ; - raise e - - let receive_start ~dbg ~sr ~vdi_info ~id ~similar = - receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm:(Vm.of_string "0") - - let receive_start2 ~dbg ~sr ~vdi_info ~id ~similar ~vm = - receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm - - let receive_finalize ~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 ~dbg ~id = - let recv_state = State.find_active_receive_mirror id in - let open State.Receive_state in - Option.iter - (fun r -> - SXM.info - "%s Mirror done. Compose on the dest sr %s parent %s and leaf %s" - __FUNCTION__ (Sr.string_of r.sr) - (Vdi.string_of r.parent_vdi) - (Vdi.string_of r.leaf_vdi) ; - Local.DP.destroy2 dbg r.leaf_dp r.sr r.leaf_vdi r.mirror_vm false ; - Local.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. *) - log_and_ignore_exn (fun () -> Local.VDI.destroy dbg r.sr r.dummy_vdi) ; - Local.VDI.remove_from_sm_config dbg r.sr r.leaf_vdi "base_mirror" - ) - recv_state ; - State.remove_receive_mirror id + (** [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_finalize3 ~dbg ~mirror_id ~sr ~url ~verify_dest = + let (module Migrate_Backend) = choose_backend dbg sr in + Migrate_Backend.receive_finalize3 () ~dbg ~mirror_id ~sr ~url ~verify_dest - let receive_cancel ~dbg ~id = - let receive_state = State.find_active_receive_mirror id in - let open State.Receive_state in - Option.iter - (fun r -> - log_and_ignore_exn (fun () -> Local.DP.destroy dbg r.leaf_dp false) ; - List.iter - (fun v -> log_and_ignore_exn (fun () -> Local.VDI.destroy dbg r.sr v)) - [r.dummy_vdi; r.leaf_vdi; r.parent_vdi] - ) - receive_state ; - State.remove_receive_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 @@ -226,11 +92,10 @@ module MigrateLocal = struct | None -> debug "Snapshot VDI already cleaned up" ) ; - - let (module Remote) = - get_remote_backend remote_info.url remote_info.verify_dest - in - try Remote.DATA.MIRROR.receive_cancel dbg id with _ -> () + try + MigrateRemote.receive_cancel2 ~dbg ~mirror_id:id ~sr + ~url:remote_info.url ~verify_dest:remote_info.verify_dest + with _ -> () ) | None -> () @@ -250,18 +115,17 @@ module MigrateLocal = struct let prepare ~dbg ~sr ~vdi ~dest ~local_vdi ~mirror_id ~mirror_vm ~url ~verify_dest = try - let (module Remote) = get_remote_backend url verify_dest in + let (module Migrate_Backend) = choose_backend dbg sr in let similars = similar_vdis ~dbg ~sr ~vdi in - - Remote.DATA.MIRROR.receive_start2 dbg dest local_vdi mirror_id similars - mirror_vm + 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__ (Printexc.to_string e) ; raise (Storage_error (Migration_preparation_failure (Printexc.to_string e))) - let start ~task_id ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest + let start ~task_id ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~live_vm ~url ~dest ~verify_dest = SXM.info "%s sr:%s vdi:%s dp: %s mirror_vm: %s copy_vm: %s url:%s dest:%s \ @@ -278,7 +142,7 @@ module MigrateLocal = struct let (module Remote) = get_remote_backend url verify_dest in (* Find the local VDI *) - let local_vdi = find_local_vdi ~dbg ~sr ~vdi in + let local_vdi, _ = find_vdi ~dbg ~sr ~vdi (module Local) in let mirror_id = State.mirror_id_of (sr, local_vdi.vdi) in debug "%s: Adding to active local mirrors before sending: id=%s" __FUNCTION__ mirror_id ; @@ -292,6 +156,9 @@ module MigrateLocal = struct ; tapdev= None ; failed= false ; watchdog= None + ; live_vm + ; vdi + ; mirror_key= None } in @@ -305,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) -> @@ -315,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_cancel ~dbg ~id:mirror_id ; + 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 ; @@ -328,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 @@ -433,66 +297,21 @@ module MigrateLocal = struct ) copy_ops ; List.iter - (fun (id, _recv_state) -> - debug "Receive in progress: %s" id ; - log_and_ignore_exn (fun () -> Local.DATA.MIRROR.receive_cancel dbg id) + (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 ~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 @@ -505,14 +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 () -> - Remote.DATA.MIRROR.receive_finalize2 "Mirror-cleanup" 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 = @@ -545,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 ; @@ -608,13 +427,14 @@ let copy ~dbg ~sr ~vdi ~vm ~url ~dest ~verify_dest = ~sr ~vdi ~vm ~url ~dest ~verify_dest ) -let start ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest ~verify_dest = +let start ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~live_vm ~url ~dest ~verify_dest + = with_dbg ~name:__FUNCTION__ ~dbg @@ fun dbg -> with_task_and_thread ~dbg (fun task -> MigrateLocal.start ~task_id:(Storage_task.id_of_handle task) - ~dbg:dbg.Debug_info.log ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest - ~verify_dest + ~dbg:dbg.Debug_info.log ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~live_vm ~url + ~dest ~verify_dest ) (* XXX: PR-1255: copy the xenopsd 'raise Exception' pattern *) @@ -622,20 +442,12 @@ 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 -let receive_start = MigrateRemote.receive_start - -let receive_start2 = MigrateRemote.receive_start2 - -let receive_finalize = MigrateRemote.receive_finalize - -let receive_finalize2 = MigrateRemote.receive_finalize2 - -let receive_cancel = MigrateRemote.receive_cancel - (* The remote end of this call, SR.update_snapshot_info_dest, is implemented in * the SMAPIv1 section of storage_migrate.ml. It needs to access the setters * for snapshot_of, snapshot_time and is_a_snapshot, which we don't want to add diff --git a/ocaml/xapi/storage_migrate_helper.ml b/ocaml/xapi/storage_migrate_helper.ml index 66c23d9a04e..f4c5d46c39c 100644 --- a/ocaml/xapi/storage_migrate_helper.ml +++ b/ocaml/xapi/storage_migrate_helper.ml @@ -36,6 +36,8 @@ module State = struct ; parent_vdi: Vdi.t ; remote_vdi: Vdi.t ; mirror_vm: Vm.t + ; url: string [@default ""] + ; verify_dest: bool [@default false] } [@@deriving rpcty] @@ -92,6 +94,11 @@ module State = struct ; tapdev: tapdev option ; mutable failed: bool ; mutable watchdog: handle option + ; vdi: Vdi.t [@default Vdi.of_string ""] (* source vdi *) + ; live_vm: Vm.t + [@default Vm.of_string "0"] + (* vm to which the source vdi is attached *) + ; mirror_key: Mirror.operation option [@default None] } [@@deriving rpcty] @@ -346,14 +353,13 @@ let get_remote_backend url verify_dest = end)) in (module Remote : SMAPIv2) -let find_local_vdi ~dbg ~sr ~vdi = - (* Find the local VDI *) - let vdis, _ = Local.SR.scan2 dbg sr in +let find_vdi ~dbg ~sr ~vdi (module SMAPIv2 : SMAPIv2) = + let vdis, _ = SMAPIv2.SR.scan2 dbg sr in match List.find_opt (fun x -> x.vdi = vdi) vdis with | None -> - failwith "Local VDI not found" + failwith_fmt "VDI %s not found" (Storage_interface.Vdi.string_of vdi) | Some v -> - v + (v, vdis) (** [similar_vdis dbg sr vdi] returns a list of content_ids of vdis which are similar to the input [vdi] in [sr] *) diff --git a/ocaml/xapi/storage_migrate_helper.mli b/ocaml/xapi/storage_migrate_helper.mli index 972faf57ce6..0f3a6ee8e11 100644 --- a/ocaml/xapi/storage_migrate_helper.mli +++ b/ocaml/xapi/storage_migrate_helper.mli @@ -28,6 +28,8 @@ module State : sig ; parent_vdi: Storage_interface.vdi ; remote_vdi: Storage_interface.vdi ; mirror_vm: Storage_interface.vm + ; url: string + ; verify_dest: bool } val t_sr : (Storage_interface.sr, t) Rpc.Types.field @@ -89,6 +91,9 @@ module State : sig ; tapdev: tapdev option ; mutable failed: bool ; mutable watchdog: handle option + ; vdi: Vdi.t [@default Vdi.of_string ""] + ; live_vm: Vm.t [@default Vm.of_string "0"] + ; mirror_key: Mirror.operation option [@default None] } val t_url : (string, t) Rpc.Types.field @@ -261,6 +266,7 @@ module Local : SMAPIv2 val get_remote_backend : string -> bool -> (module SMAPIv2) -val find_local_vdi : dbg:string -> sr:sr -> vdi:vdi -> vdi_info +val find_vdi : + dbg:string -> sr:sr -> vdi:vdi -> (module SMAPIv2) -> vdi_info * vdi_info list val similar_vdis : dbg:string -> sr:sr -> vdi:vdi -> uuid list diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 6614177e3e3..1ea91e94078 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -19,6 +19,7 @@ module D = Debug.Make (struct let name = "mux" end) open D open Storage_interface open Storage_mux_reg +open Storage_utils let s_of_sr = Storage_interface.Sr.string_of @@ -26,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 @@ -330,11 +333,32 @@ module Mux = struct Storage_migrate.update_snapshot_info_src ~dbg:(Debug_info.to_string di) ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs + let set_is_a_snapshot _context ~dbg ~sr ~vdi ~is_a_snapshot = + Server_helpers.exec_with_new_task "VDI.set_is_a_snapshot" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi, _ = find_vdi ~__context sr vdi in + Db.VDI.set_is_a_snapshot ~__context ~self:vdi ~value:is_a_snapshot + ) + + let set_snapshot_time _context ~dbg ~sr ~vdi ~snapshot_time = + let module Date = Clock.Date in + Server_helpers.exec_with_new_task "VDI.set_snapshot_time" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi, _ = find_vdi ~__context sr vdi in + let snapshot_time = Date.of_iso8601 snapshot_time in + Db.VDI.set_snapshot_time ~__context ~self:vdi ~value:snapshot_time + ) + + let set_snapshot_of _context ~dbg ~sr ~vdi ~snapshot_of = + Server_helpers.exec_with_new_task "VDI.set_snapshot_of" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi, _ = find_vdi ~__context sr vdi in + let snapshot_of, _ = find_vdi ~__context sr snapshot_of in + Db.VDI.set_snapshot_of ~__context ~self:vdi ~value:snapshot_of + ) + let update_snapshot_info_dest () ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs = - with_dbg ~name:"SR.update_snapshot_info_dest" ~dbg @@ fun di -> - let module C = StorageAPI (Idl.Exn.GenClient (struct - let rpc = of_sr sr - end)) in + with_dbg ~name:"SR.update_snapshot_info_dest" ~dbg @@ fun _di -> info "SR.update_snapshot_info_dest dbg:%s sr:%s vdi:%s ~src_vdi:%s \ snapshot_pairs:%s" @@ -348,8 +372,44 @@ module Mux = struct |> String.concat "; " |> Printf.sprintf "[%s]" ) ; - C.SR.update_snapshot_info_dest (Debug_info.to_string di) sr vdi src_vdi - snapshot_pairs + Server_helpers.exec_with_new_task "SR.update_snapshot_info_dest" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let local_vdis, _ = scan2 () ~dbg ~sr in + let find_sm_vdi ~vdi ~vdi_info_list = + try List.find (fun x -> x.vdi = vdi) vdi_info_list + with Not_found -> + raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi))) + in + let assert_content_ids_match ~vdi_info1 ~vdi_info2 = + if vdi_info1.content_id <> vdi_info2.content_id then + raise + (Storage_error + (Content_ids_do_not_match + (s_of_vdi vdi_info1.vdi, s_of_vdi vdi_info2.vdi) + ) + ) + in + (* For each (local snapshot vdi, source snapshot vdi) pair: + * - Check that the content_ids are the same + * - Copy snapshot_time from the source VDI to the local VDI + * - Set the local VDI's snapshot_of to vdi + * - Set is_a_snapshot = true for the local snapshot *) + List.iter + (fun (local_snapshot, src_snapshot_info) -> + let local_snapshot_info = + find_sm_vdi ~vdi:local_snapshot ~vdi_info_list:local_vdis + in + assert_content_ids_match ~vdi_info1:local_snapshot_info + ~vdi_info2:src_snapshot_info ; + set_snapshot_time __context ~dbg ~sr ~vdi:local_snapshot + ~snapshot_time:src_snapshot_info.snapshot_time ; + set_snapshot_of __context ~dbg ~sr ~vdi:local_snapshot + ~snapshot_of:vdi ; + set_is_a_snapshot __context ~dbg ~sr ~vdi:local_snapshot + ~is_a_snapshot:true + ) + snapshot_pairs + ) end module VDI = struct @@ -587,7 +647,13 @@ module Mux = struct 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 + 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 let detach () ~dbg ~dp ~sr ~vdi ~vm = with_dbg ~name:"VDI.detach" ~dbg @@ fun di -> @@ -739,6 +805,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) @@ -768,16 +852,19 @@ module Mux = struct u "DATA.MIRROR.send_start" (* 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 -> + with_dbg ~name:"DATA.MIRROR.receive_start" ~dbg @@ fun _di -> info "%s dbg: %s sr: %s vdi_info: %s mirror_id: %s similar: %s" __FUNCTION__ dbg (s_of_sr sr) (string_of_vdi_info vdi_info) id (String.concat ";" similar) ; - Storage_migrate.receive_start ~dbg:di.log ~sr ~vdi_info ~id ~similar + (* This goes straight to storage_smapiv1_migrate for backwards compatability + reasons, new code should not call receive_start any more *) + Storage_smapiv1_migrate.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id + ~similar let receive_start2 () ~dbg ~sr ~vdi_info ~id ~similar ~vm = - with_dbg ~name:"DATA.MIRROR.receive_start2" ~dbg @@ fun di -> + 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) @@ -785,23 +872,52 @@ module Mux = struct (String.concat ";" similar) (s_of_vm vm) ; info "%s dbg:%s" __FUNCTION__ dbg ; - Storage_migrate.receive_start2 ~dbg:di.log ~sr ~vdi_info ~id ~similar - ~vm + (* 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__ 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_migrate.receive_finalize ~dbg:di.log ~id + Storage_smapiv1_migrate.MIRROR.receive_finalize () ~dbg:di.log ~id 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_migrate.receive_finalize2 ~dbg:di.log ~id + Storage_smapiv1_migrate.MIRROR.receive_finalize2 () ~dbg:di.log ~id + + let receive_finalize3 () ~dbg:_ ~mirror_id:_ ~sr:_ ~url:_ ~verify_dest:_ = + u __FUNCTION__ let receive_cancel () ~dbg ~id = with_dbg ~name:"DATA.MIRROR.receive_cancel" ~dbg @@ fun di -> info "%s dbg: %s mirror_id: %s" __FUNCTION__ dbg id ; - Storage_migrate.receive_cancel ~dbg:di.log ~id + Storage_smapiv1_migrate.MIRROR.receive_cancel () ~dbg:di.log ~id + + let receive_cancel2 () ~dbg:_ ~mirror_id:_ ~url:_ ~verify_dest:_ = + u __FUNCTION__ + + let pre_deactivate_hook _ctx ~dbg:_ ~dp:_ ~sr:_ ~vdi:_ = + u "DATA.MIRROR.pre_deactivate_hook" + + let has_mirror_failed _ctx ~dbg:_ ~mirror_id:_ ~sr:_ = + u "DATA.MIRROR.has_mirror_failed" + + 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 1616d1a65f9..0995edc35c4 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -18,8 +18,7 @@ open D module Date = Clock.Date module XenAPI = Client.Client open Storage_interface - -exception No_VDI +open Storage_utils let s_of_vdi = Vdi.string_of @@ -30,26 +29,6 @@ let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute let with_dbg ~name ~dbg f = Debug_info.with_dbg ~module_name:"SMAPIv1" ~name ~dbg f -(* Find a VDI given a storage-layer SR and VDI *) -let find_vdi ~__context sr vdi = - let sr = s_of_sr sr in - let vdi = s_of_vdi vdi in - let open Xapi_database.Db_filter_types in - let sr = Db.SR.get_by_uuid ~__context ~uuid:sr in - match - Db.VDI.get_records_where ~__context - ~expr: - (And - ( Eq (Field "location", Literal vdi) - , Eq (Field "SR", Literal (Ref.string_of sr)) - ) - ) - with - | x :: _ -> - x - | _ -> - raise No_VDI - (* Find a VDI reference given a name *) let find_content ~__context ?sr name = (* PR-1255: the backend should do this for us *) @@ -132,32 +111,6 @@ module SMAPIv1 : Server_impl = struct let vdi_rec = Db.VDI.get_record ~__context ~self in vdi_info_of_vdi_rec __context vdi_rec - (* For SMAPIv1, is_a_snapshot, snapshot_time and snapshot_of are stored in - * xapi's database. For SMAPIv2 they should be implemented by the storage - * backend. *) - let set_is_a_snapshot _context ~dbg ~sr ~vdi ~is_a_snapshot = - Server_helpers.exec_with_new_task "VDI.set_is_a_snapshot" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vdi, _ = find_vdi ~__context sr vdi in - Db.VDI.set_is_a_snapshot ~__context ~self:vdi ~value:is_a_snapshot - ) - - let set_snapshot_time _context ~dbg ~sr ~vdi ~snapshot_time = - Server_helpers.exec_with_new_task "VDI.set_snapshot_time" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vdi, _ = find_vdi ~__context sr vdi in - let snapshot_time = Date.of_iso8601 snapshot_time in - Db.VDI.set_snapshot_time ~__context ~self:vdi ~value:snapshot_time - ) - - let set_snapshot_of _context ~dbg ~sr ~vdi ~snapshot_of = - Server_helpers.exec_with_new_task "VDI.set_snapshot_of" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vdi, _ = find_vdi ~__context sr vdi in - let snapshot_of, _ = find_vdi ~__context sr snapshot_of in - Db.VDI.set_snapshot_of ~__context ~self:vdi ~value:snapshot_of - ) - module Query = struct let query _context ~dbg:_ = { @@ -433,46 +386,9 @@ module SMAPIv1 : Server_impl = struct ~dest_vdi:_ ~snapshot_pairs:_ = assert false - let update_snapshot_info_dest _context ~dbg ~sr ~vdi ~src_vdi:_ - ~snapshot_pairs = - Server_helpers.exec_with_new_task "SR.update_snapshot_info_dest" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let local_vdis = scan __context ~dbg ~sr in - let find_sm_vdi ~vdi ~vdi_info_list = - try List.find (fun x -> x.vdi = vdi) vdi_info_list - with Not_found -> - raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi))) - in - let assert_content_ids_match ~vdi_info1 ~vdi_info2 = - if vdi_info1.content_id <> vdi_info2.content_id then - raise - (Storage_error - (Content_ids_do_not_match - (s_of_vdi vdi_info1.vdi, s_of_vdi vdi_info2.vdi) - ) - ) - in - (* For each (local snapshot vdi, source snapshot vdi) pair: - * - Check that the content_ids are the same - * - Copy snapshot_time from the source VDI to the local VDI - * - Set the local VDI's snapshot_of to vdi - * - Set is_a_snapshot = true for the local snapshot *) - List.iter - (fun (local_snapshot, src_snapshot_info) -> - let local_snapshot_info = - find_sm_vdi ~vdi:local_snapshot ~vdi_info_list:local_vdis - in - assert_content_ids_match ~vdi_info1:local_snapshot_info - ~vdi_info2:src_snapshot_info ; - set_snapshot_time __context ~dbg ~sr ~vdi:local_snapshot - ~snapshot_time:src_snapshot_info.snapshot_time ; - set_snapshot_of __context ~dbg ~sr ~vdi:local_snapshot - ~snapshot_of:vdi ; - set_is_a_snapshot __context ~dbg ~sr ~vdi:local_snapshot - ~is_a_snapshot:true - ) - snapshot_pairs - ) + let update_snapshot_info_dest _context ~dbg:_ ~sr:_ ~vdi:_ ~src_vdi:_ + ~snapshot_pairs:_ = + assert false end module VDI = struct @@ -562,6 +478,7 @@ module SMAPIv1 : Server_impl = struct ; backend_type= "vbd3" } ; BlockDevice {path= params} + ; Nbd {uri= attach_info_v1.Smint.params_nbd} ] ) } @@ -1212,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 @@ -1231,11 +1152,30 @@ module SMAPIv1 : Server_impl = struct ~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:_ ~id:_ = assert false + let receive_finalize3 _context ~dbg:_ ~mirror_id:_ ~sr:_ ~url:_ + ~verify_dest:_ = + assert false + let receive_cancel _context ~dbg:_ ~id:_ = assert false + + 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.mli b/ocaml/xapi/storage_smapiv1.mli index 69a0a22aa9f..f991e6f82c3 100644 --- a/ocaml/xapi/storage_smapiv1.mli +++ b/ocaml/xapi/storage_smapiv1.mli @@ -20,7 +20,4 @@ val vdi_read_write : (Sr.t * Vdi.t, bool) Hashtbl.t val vdi_info_of_vdi_rec : Context.t -> API.vDI_t -> Storage_interface.vdi_info -val find_vdi : __context:Context.t -> Sr.t -> Vdi.t -> [`VDI] Ref.t * API.vDI_t -(** Find a VDI given a storage-layer SR and VDI *) - module SMAPIv1 : Server_impl diff --git a/ocaml/xapi/storage_smapiv1_migrate.ml b/ocaml/xapi/storage_smapiv1_migrate.ml index b38231dad5b..fe291d44d66 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 @@ -162,26 +168,11 @@ module Copy = struct (Printf.sprintf "Remote SR %s not found" (Storage_interface.Sr.string_of dest) ) ; - let vdis = Remote.SR.scan dbg dest in - let remote_vdi = - try List.find (fun x -> x.vdi = dest_vdi) vdis - with Not_found -> - failwith - (Printf.sprintf "Remote VDI %s not found" - (Storage_interface.Vdi.string_of dest_vdi) - ) - in + + let remote_vdi, _ = find_vdi ~dbg ~sr:dest ~vdi:dest_vdi (module Remote) in let dest_content_id = remote_vdi.content_id in (* Find the local VDI *) - let vdis = Local.SR.scan dbg sr in - let local_vdi = - try List.find (fun x -> x.vdi = vdi) vdis - with Not_found -> - failwith - (Printf.sprintf "Local VDI %s not found" - (Storage_interface.Vdi.string_of vdi) - ) - in + let local_vdi, vdis = find_vdi ~dbg ~sr ~vdi (module Local) in D.debug "copy local content_id=%s" local_vdi.content_id ; D.debug "copy remote content_id=%s" dest_content_id ; if local_vdi.virtual_size > remote_vdi.virtual_size then ( @@ -212,7 +203,8 @@ module Copy = struct 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') + (Printf.sprintf "%s/nbdproxy/import/%s/%s/%s/%s" + (Http.Url.get_uri url') (Storage_interface.Vm.string_of vm) (Storage_interface.Sr.string_of dest) (Storage_interface.Vdi.string_of dest_vdi) @@ -293,6 +285,10 @@ module Copy = struct (* PR-1255: XXX: this is useful because we don't have content_ids by default *) D.debug "setting local content_id <- %s" local_vdi.content_id ; Local.VDI.set_content_id dbg sr local_vdi.vdi local_vdi.content_id ; + (* Re-find the VDI to get the updated content_id info *) + let remote_vdi, _ = + find_vdi ~dbg ~sr:dest ~vdi:dest_vdi (module Remote) + in Some (Vdi_info remote_vdi) with e -> D.error "Caught %s: performing cleanup actions" (Printexc.to_string e) ; @@ -312,11 +308,7 @@ module Copy = struct let (module Remote) = get_remote_backend url verify_dest in (* Find the local VDI *) try - let vdis = Local.SR.scan dbg sr in - let local_vdi = - try List.find (fun x -> x.vdi = vdi) vdis - with Not_found -> failwith (Printf.sprintf "Local VDI not found") - in + let local_vdi, _ = find_vdi ~dbg ~sr ~vdi (module Local) in try let similar_vdis = Local.VDI.similar_content dbg sr vdi in let similars = List.map (fun vdi -> vdi.content_id) similar_vdis in @@ -401,8 +393,14 @@ module Copy = struct raise (Storage_error (Internal_error (Printexc.to_string e))) end -let mirror_pass_fds ~dbg ~dp ~sr ~vdi ~mirror_vm ~mirror_id ~url ~dest_sr - ~verify_dest ~(remote_mirror : Mirror.mirror_receive_result_vhd_t) = +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 @@ -485,6 +483,9 @@ let mirror_pass_fds ~dbg ~dp ~sr ~vdi ~mirror_vm ~mirror_id ~url ~dest_sr ; tapdev= Some tapdev ; failed= false ; watchdog= None + ; vdi + ; live_vm + ; mirror_key= None } in State.add mirror_id (State.Send_op alm) ; @@ -493,6 +494,9 @@ let mirror_pass_fds ~dbg ~dp ~sr ~vdi ~mirror_vm ~mirror_id ~url ~dest_sr 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 @@ -563,16 +567,37 @@ 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 = + ~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 *) + raise + (Storage_error + (Migration_mirror_failure + "Incorrect remote mirror format for SMAPIv1" + ) + ) | Mirror.Vhd_mirror mirror_res -> let tapdev = - mirror_pass_fds ~dbg ~dp ~sr ~vdi ~mirror_vm ~mirror_id ~url ~dest_sr - ~verify_dest ~remote_mirror:mirror_res + mirror_pass_fds ~dbg ~dp ~sr ~vdi ~mirror_vm ~live_vm ~mirror_id ~url + ~dest_sr ~verify_dest ~remote_mirror:mirror_res in let snapshot = mirror_snapshot ~dbg ~sr ~dp ~mirror_id ~local_vdi in @@ -592,25 +617,26 @@ module MIRROR : SMAPIv2_MIRROR = struct (Storage_interface.Vdi.string_of mirror_res.Mirror.mirror_vdi.vdi) ; mirror_cleanup ~dbg ~sr ~snapshot - let receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm = + let receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm + (module SMAPI : SMAPIv2) = let on_fail : (unit -> unit) list ref = ref [] in - let vdis = Local.SR.scan dbg sr in + let vdis = SMAPI.SR.scan dbg sr in (* We drop cbt_metadata VDIs that do not have any actual data *) let vdis = List.filter (fun vdi -> vdi.ty <> "cbt_metadata") vdis in - let leaf_dp = Local.DP.create dbg Uuidx.(to_string (make ())) in + let leaf_dp = SMAPI.DP.create dbg Uuidx.(to_string (make ())) in try let vdi_info = {vdi_info with sm_config= [("base_mirror", id)]} in - let leaf = Local.VDI.create dbg sr vdi_info in + let leaf = SMAPI.VDI.create dbg sr vdi_info in D.info "Created leaf VDI for mirror receive: %s" (string_of_vdi_info leaf) ; - on_fail := (fun () -> Local.VDI.destroy dbg sr leaf.vdi) :: !on_fail ; + on_fail := (fun () -> SMAPI.VDI.destroy dbg sr leaf.vdi) :: !on_fail ; (* dummy VDI is created so that the leaf VDI becomes a differencing disk, useful for calling VDI.compose later on *) - let dummy = Local.VDI.snapshot dbg sr leaf in - on_fail := (fun () -> Local.VDI.destroy dbg sr dummy.vdi) :: !on_fail ; + let dummy = SMAPI.VDI.snapshot dbg sr leaf in + on_fail := (fun () -> SMAPI.VDI.destroy dbg sr dummy.vdi) :: !on_fail ; D.debug "%s Created dummy snapshot for mirror receive: %s" __FUNCTION__ (string_of_vdi_info dummy) ; - let _ : backend = Local.VDI.attach3 dbg leaf_dp sr leaf.vdi vm true in - Local.VDI.activate3 dbg leaf_dp sr leaf.vdi vm ; + let _ : backend = SMAPI.VDI.attach3 dbg leaf_dp sr leaf.vdi vm true in + SMAPI.VDI.activate3 dbg leaf_dp sr leaf.vdi vm ; let nearest = List.fold_left (fun acc content_id -> @@ -643,21 +669,26 @@ module MIRROR : SMAPIv2_MIRROR = struct | Some vdi -> D.debug "Cloning VDI" ; let vdi = add_to_sm_config vdi "base_mirror" id in - let vdi_clone = Local.VDI.clone dbg sr vdi in + let vdi_clone = SMAPI.VDI.clone dbg sr vdi in D.debug "Clone: %s" (Storage_interface.Vdi.string_of vdi_clone.vdi) ; ( if vdi_clone.virtual_size <> vdi_info.virtual_size then let new_size = - Local.VDI.resize dbg sr vdi_clone.vdi vdi_info.virtual_size + SMAPI.VDI.resize dbg sr vdi_clone.vdi vdi_info.virtual_size in - D.debug "Resize local clone VDI to %Ld: result %Ld" + D.debug "Resize clone VDI to %Ld: result %Ld" vdi_info.virtual_size new_size ) ; vdi_clone | None -> D.debug "Creating a blank remote VDI" ; - Local.VDI.create dbg sr vdi_info + SMAPI.VDI.create dbg sr vdi_info in D.debug "Parent disk content_id=%s" parent.content_id ; + (* 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_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 @@ -670,6 +701,8 @@ module MIRROR : SMAPIv2_MIRROR = struct ; parent_vdi= parent.vdi ; remote_vdi= vdi_info.vdi ; mirror_vm= vm + ; url= "" + ; verify_dest= false } ) ; let nearest_content_id = Option.map (fun x -> x.content_id) nearest in @@ -692,19 +725,39 @@ 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 ~id ~similar ~vm = - receive_start_common ~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 + receive_start_common ~dbg ~sr ~vdi_info ~id:mirror_id ~similar ~vm + (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 ~id = - let recv_state = State.find_active_receive_mirror id 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 (fun r -> @@ -713,17 +766,30 @@ module MIRROR : SMAPIv2_MIRROR = struct __FUNCTION__ (Sr.string_of r.sr) (Vdi.string_of r.parent_vdi) (Vdi.string_of r.leaf_vdi) ; - Local.DP.destroy2 dbg r.leaf_dp r.sr r.leaf_vdi r.mirror_vm false ; - Local.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 () -> Local.VDI.destroy dbg r.sr r.dummy_vdi) ; - Local.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 id + 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 @@ -737,4 +803,100 @@ module MIRROR : SMAPIv2_MIRROR = struct ) receive_state ; State.remove_receive_mirror id + + 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 = u __FUNCTION__ + + let stat _ctx = u __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_migrate.mli b/ocaml/xapi/storage_smapiv1_migrate.mli index 4c40e2ab999..a1021858e46 100644 --- a/ocaml/xapi/storage_smapiv1_migrate.mli +++ b/ocaml/xapi/storage_smapiv1_migrate.mli @@ -56,6 +56,7 @@ val mirror_pass_fds : -> sr:Storage_interface.sr -> vdi:Storage_interface.vdi -> mirror_vm:Storage_interface.vm + -> live_vm:Storage_interface.vm -> mirror_id:string -> url:string -> dest_sr:Storage_interface.sr diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 569f4f33bb0..7066a649ce2 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -1137,11 +1137,17 @@ functor end module DATA = struct + let u x = raise Storage_interface.(Storage_error (Errors.Unimplemented x)) + let copy context ~dbg ~sr ~vdi ~vm ~url ~dest = info "DATA.copy dbg:%s sr:%s vdi:%s url:%s dest:%s" dbg (s_of_sr sr) (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:_ = u "DATA.mirror" + + let stat _context ~dbg:_ ~sr:_ ~vdi:_ ~vm:_ ~key:_ = u "DATA.stat" + (* 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,9 +1192,6 @@ 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:_ = @@ -1209,6 +1212,11 @@ functor 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:_ = + (* See Storage_smapiv1_migrate.receive_start3 *) + u __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 @@ -1217,9 +1225,27 @@ functor 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__ + 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__ + + let pre_deactivate_hook _context ~dbg:_ ~dp:_ ~sr:_ ~vdi:_ = + u __FUNCTION__ + + let has_mirror_failed _context ~dbg:_ ~mirror_id:_ ~sr:_ = + u __FUNCTION__ + + let list _context ~dbg:_ = u __FUNCTION__ + + let stat _context ~dbg:_ ~id:_ = u __FUNCTION__ end end diff --git a/ocaml/xapi/storage_smapiv3_migrate.ml b/ocaml/xapi/storage_smapiv3_migrate.ml index 4cfcf1c831e..d9d34ffbe08 100644 --- a/ocaml/xapi/storage_smapiv3_migrate.ml +++ b/ocaml/xapi/storage_smapiv3_migrate.ml @@ -12,28 +12,325 @@ * 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_uri (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 = u __FUNCTION__ + 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:_ = + u "DATA.MIRROR.receive_start" + + let receive_start2 _ctx ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ ~vm:_ = + u "DATA.MIRROR.receive_start2" + + 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:_ = u "DATA.MIRROR.receive_finalize" + + let receive_finalize2 _ctx ~dbg:_ ~id:_ = u "DATA.MIRROR.receive_finalize2" + + 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_cancel _ctx ~dbg:_ ~id:_ = u __FUNCTION__ - let receive_start _ctx = u __FUNCTION__ + let list _ctx = u __FUNCTION__ - let receive_start2 _ctx = u __FUNCTION__ + let stat _ctx = u __FUNCTION__ - let receive_finalize _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_finalize2 _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_cancel _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 dd7d6b6e63d..8c2398619ff 100644 --- a/ocaml/xapi/storage_utils.ml +++ b/ocaml/xapi/storage_utils.ml @@ -14,6 +14,10 @@ open Storage_interface +let s_of_sr = Storage_interface.Sr.string_of + +let s_of_vdi = Storage_interface.Vdi.string_of + let string_of_vdi_type vdi_type = Rpc.string_of_rpc (API.rpc_of_vdi_type vdi_type) @@ -173,3 +177,24 @@ let transform_storage_exn f = (Api_errors.Server_error (Api_errors.internal_error, [Printexc.to_string e]) ) + +exception No_VDI + +let find_vdi ~__context sr vdi = + let sr = s_of_sr sr in + let vdi = s_of_vdi vdi in + let open Xapi_database.Db_filter_types in + let sr = Db.SR.get_by_uuid ~__context ~uuid:sr in + match + Db.VDI.get_records_where ~__context + ~expr: + (And + ( Eq (Field "location", Literal vdi) + , Eq (Field "SR", Literal (Ref.string_of sr)) + ) + ) + with + | x :: _ -> + x + | _ -> + raise No_VDI diff --git a/ocaml/xapi/storage_utils.mli b/ocaml/xapi/storage_utils.mli index 50e3a80e7f8..d0a98704c8b 100644 --- a/ocaml/xapi/storage_utils.mli +++ b/ocaml/xapi/storage_utils.mli @@ -64,3 +64,12 @@ val rpc : val transform_storage_exn : (unit -> 'a) -> 'a (** [transform_storage_exn f] runs [f], rethrowing any storage error as a nice XenAPI error *) + +exception No_VDI + +val find_vdi : + __context:Context.t + -> Storage_interface.sr + -> Storage_interface.vdi + -> [`VDI] Ref.t * API.vDI_t +(** Find a VDI given a storage-layer SR and VDI *) diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index f7ac9b546d3..a12e3ec0c83 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -327,6 +327,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 = @@ -1115,6 +1140,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 diff --git a/ocaml/xapi/xapi_db_upgrade.ml b/ocaml/xapi/xapi_db_upgrade.ml index f4102782916..e1f0eba63fc 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 48d0737a613..8c2b5b56d3d 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 f86ff967b43..22908a496b1 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -368,6 +368,8 @@ let sync_bios_strings = "sync_bios_strings" let sync_chipset_info = "sync_chipset_info" +let sync_ssh_status = "sync_ssh_status" + let sync_pci_devices = "sync_pci_devices" let sync_gpus = "sync_gpus" @@ -500,6 +502,16 @@ let rpu_allowed_vm_operations = ; `update_allowed_operations ] +module Vdi_operations = struct + type t = API.vdi_operations + + (* this is more efficient than just 'let compare = Stdlib.compare', + because the compiler can specialize it to [t] without calling any runtime functions *) + let compare (a : t) (b : t) = Stdlib.compare a b +end + +module Vdi_operations_set = Set.Make (Vdi_operations) + (* Until the Ely release, the vdi_operations enum had stayed unchanged * since 2009 or earlier, but then Ely and some subsequent releases * added new members to the enum. *) @@ -517,6 +529,7 @@ let pre_ely_vdi_operations = ; `generate_config ; `blocked ] + |> Vdi_operations_set.of_list (* We might consider restricting this further. *) let rpu_allowed_vdi_operations = pre_ely_vdi_operations @@ -921,6 +934,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" @@ -999,6 +1019,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 *) @@ -1201,6 +1223,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 ) @@ -1289,6 +1312,12 @@ 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" + (* Fingerprint of default patch key *) let citrix_patch_key = "NERDNTUzMDMwRUMwNDFFNDI4N0M4OEVCRUFEMzlGOTJEOEE5REUyNg==" @@ -1588,6 +1617,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) diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index e2cece5cb5c..405733baa78 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -649,8 +649,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 +676,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 @@ -978,7 +1007,8 @@ 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 = (* 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 *) @@ -1042,7 +1072,8 @@ 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 ; (* 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 ; @@ -2790,6 +2821,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" ; @@ -3110,22 +3142,137 @@ let emergency_clear_mandatory_guidance ~__context = ) ; Db.Host.set_pending_guidances ~__context ~self ~value:[] +let disable_ssh_internal ~__context ~self = + try + debug "Disabling SSH for host %s" (Helpers.get_localhost_uuid ()) ; + Xapi_systemctl.disable ~wait_until_success:false !Xapi_globs.ssh_service ; + Xapi_systemctl.stop ~wait_until_success:false !Xapi_globs.ssh_service ; + 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 schedule_disable_ssh_job ~__context ~self ~timeout = + let host_uuid = Helpers.get_localhost_uuid () in + 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 + + 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 + ) ; + + Db.Host.set_ssh_expiry ~__context ~self ~value:expiry_time + 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 ()) ; + + 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 -> + schedule_disable_ssh_job ~__context ~self ~timeout:t + ) ; + + 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 -> + schedule_disable_ssh_job ~__context ~self ~timeout:t + +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) diff --git a/ocaml/xapi/xapi_host.mli b/ocaml/xapi/xapi_host.mli index e1dc46c91ac..a3d7504b4a4 100644 --- a/ocaml/xapi/xapi_host.mli +++ b/ocaml/xapi/xapi_host.mli @@ -130,6 +130,10 @@ 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 -> [`host] Ref.t val destroy : __context:Context.t -> self:API.ref_host -> unit @@ -567,3 +571,12 @@ 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 -> unit diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 834b34beb4b..7b9ac9d7a2e 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -497,10 +497,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 +544,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_local_session.ml b/ocaml/xapi/xapi_local_session.ml index e356ae87256..709275077b0 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 ca8c1810018..8e7c4d31bc9 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_periodic_scheduler_init.ml b/ocaml/xapi/xapi_periodic_scheduler_init.ml index 1bd13d5f6d6..f394a9ad999 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,25 @@ 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 + (* handle the case where XAPI is not active when the SSH timeout expires *) + else if Fe_systemctl.is_active ~service:!Xapi_globs.ssh_service then + Xapi_host.disable_ssh ~__context ~self + in let update_all_subjects_delay = 10.0 in (* initial delay = 10 seconds *) if master then @@ -133,6 +154,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_pool.ml b/ocaml/xapi/xapi_pool.ml index b2d6da1122f..5425ef05188 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -112,6 +112,89 @@ 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 with + | vlan when vlan > 0L -> + error "Cannot join pool whose clustering is enabled on VLAN network" ; + raise + (Api_errors.Server_error + ( Api_errors + .pool_joining_pool_cannot_enable_clustering_on_vlan_network + , [Int64.to_string vlan] + ) + ) + | 0L | _ -> ( + 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 +971,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 +1047,10 @@ 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 in (* Copy other-config into newly created host record: *) no_exn @@ -1556,6 +1644,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 +1655,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 +1745,39 @@ 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 + 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 ; + 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 @@ -2013,6 +2133,23 @@ 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 ; + 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" ; @@ -4004,8 +4141,26 @@ 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 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 diff --git a/ocaml/xapi/xapi_pool.mli b/ocaml/xapi/xapi_pool.mli index 7d00d339805..b9c5b6fea3f 100644 --- a/ocaml/xapi/xapi_pool.mli +++ b/ocaml/xapi/xapi_pool.mli @@ -437,3 +437,9 @@ 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 diff --git a/ocaml/xapi/xapi_services.ml b/ocaml/xapi/xapi_services.ml index 21e3b8d0c3b..ca9e3d729ca 100644 --- a/ocaml/xapi/xapi_services.ml +++ b/ocaml/xapi/xapi_services.ml @@ -196,7 +196,7 @@ let put_handler (req : Http.Request.t) s _ = http_proxy_to_plugin req s name | [""; services; "SM"; "data"; sr; vdi] when services = _services -> let vdi, _ = - Storage_smapiv1.find_vdi ~__context + Storage_utils.find_vdi ~__context (Storage_interface.Sr.of_string sr) (Storage_interface.Vdi.of_string vdi) in @@ -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 diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index f7fcfdac7e9..ad1e1a37a0a 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -801,12 +801,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 +1569,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_vdi.ml b/ocaml/xapi/xapi_vdi.ml index cecf8296f8e..15dff1df4d8 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -86,7 +86,10 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) let* () = if Helpers.rolling_upgrade_in_progress ~__context - && not (List.mem op Xapi_globs.rpu_allowed_vdi_operations) + && not + (Xapi_globs.Vdi_operations_set.mem op + Xapi_globs.rpu_allowed_vdi_operations + ) then Error (Api_errors.not_supported_during_upgrade, []) else @@ -96,7 +99,7 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) (* 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 = - List.exists (fun (_, op) -> op = `mirror) current_ops && op = `destroy + op = `destroy && List.exists (fun (_, op) -> op = `mirror) current_ops in if List.exists (fun (_, op) -> op <> `copy) current_ops @@ -130,7 +133,7 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) pbd_records in let* () = - if pbds_attached = [] && List.mem op [`resize] then + if pbds_attached = [] && op = `resize then Error (Api_errors.sr_no_pbds, [Ref.string_of sr]) else Ok () @@ -155,16 +158,14 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) ) ) | Some records -> - List.map snd - (List.filter - (fun (_, vbd_record) -> - vbd_record.Db_actions.vBD_VDI = _ref' - && (vbd_record.Db_actions.vBD_currently_attached - || vbd_record.Db_actions.vBD_reserved - ) - ) - records + List.filter + (fun vbd_record -> + vbd_record.Db_actions.vBD_VDI = _ref' + && (vbd_record.Db_actions.vBD_currently_attached + || vbd_record.Db_actions.vBD_reserved + ) ) + records in let my_active_rw_vbd_records = List.filter (fun vbd -> vbd.Db_actions.vBD_mode = `RW) my_active_vbd_records @@ -183,14 +184,12 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) ) ) | Some records -> - List.map snd - (List.filter - (fun (_, vbd_record) -> - vbd_record.Db_actions.vBD_VDI = _ref' - && vbd_record.Db_actions.vBD_current_operations <> [] - ) - records + List.filter + (fun vbd_record -> + vbd_record.Db_actions.vBD_VDI = _ref' + && vbd_record.Db_actions.vBD_current_operations <> [] ) + 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 @@ -467,7 +466,7 @@ let update_allowed_operations_internal ~__context ~self ~sr_records ~pbd_records *) let all_ops = Xapi_globs.pre_ely_vdi_operations - |> List.filter (function + |> Xapi_globs.Vdi_operations_set.filter (function | `blocked -> false (* CA-260245 *) | `force_unlock -> @@ -477,6 +476,15 @@ let update_allowed_operations_internal ~__context ~self ~sr_records ~pbd_records ) in let all = Db.VDI.get_record_internal ~__context ~self in + let vbd_records = + match vbd_records with + | None when Pool_role.is_master () -> + all.Db_actions.vDI_VBDs + |> List.rev_map (fun self -> Db.VBD.get_record_internal ~__context ~self) + |> Option.some + | v -> + v + in let allowed = let check x = match @@ -484,18 +492,20 @@ let update_allowed_operations_internal ~__context ~self ~sr_records ~pbd_records ha_enabled all self x with | Ok () -> - [x] + true | _ -> - [] + false in - List.fold_left (fun accu op -> check op @ accu) [] all_ops + all_ops |> Xapi_globs.Vdi_operations_set.filter check in let allowed = - if Helpers.rolling_upgrade_in_progress ~__context then - Xapi_stdext_std.Listext.List.intersect allowed - Xapi_globs.rpu_allowed_vdi_operations - else - allowed + ( if Helpers.rolling_upgrade_in_progress ~__context then + Xapi_globs.Vdi_operations_set.inter allowed + Xapi_globs.rpu_allowed_vdi_operations + else + allowed + ) + |> Xapi_globs.Vdi_operations_set.elements in Db.VDI.set_allowed_operations ~__context ~self ~value:allowed diff --git a/ocaml/xapi/xapi_vdi.mli b/ocaml/xapi/xapi_vdi.mli index 45569a12fde..3d60ad31ff1 100644 --- a/ocaml/xapi/xapi_vdi.mli +++ b/ocaml/xapi/xapi_vdi.mli @@ -23,7 +23,7 @@ val check_operation_error : __context:Context.t -> ?sr_records:'a list -> ?pbd_records:(API.ref_PBD * API.pBD_t) list - -> ?vbd_records:(API.ref_VBD * Db_actions.vBD_t) list + -> ?vbd_records:Db_actions.vBD_t list -> bool -> Db_actions.vDI_t -> API.ref_VDI @@ -40,7 +40,7 @@ val update_allowed_operations_internal : -> self:[`VDI] API.Ref.t -> sr_records:'a list -> pbd_records:(API.ref_PBD * API.pBD_t) list - -> ?vbd_records:(API.ref_VBD * Db_actions.vBD_t) list + -> ?vbd_records:Db_actions.vBD_t list -> unit -> unit diff --git a/ocaml/xapi/xapi_vdi_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml index 3cc2d4a7f5f..84db627c719 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 f7d5e1eb408..aae64cef195 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 2fab562dbe4..5ab6f146339 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -192,10 +192,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 diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 78967197a8f..8a1ca5e493a 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -89,9 +89,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 +1168,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"])) diff --git a/ocaml/xapi/xapi_vm.mli b/ocaml/xapi/xapi_vm.mli index d0771c49cfa..363e68b03d1 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 diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index 9ab13f79b54..fc281c70de0 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -856,8 +856,6 @@ let force_state_reset_keep_current_operations ~__context ~self ~value: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 +897,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 60c344d4c65..e5eca21283d 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 ) @@ -1019,25 +1020,32 @@ 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 - debug "%s mirror_vm is %s copy_vm is %s" __FUNCTION__ + let live_vm = + match Db.VDI.get_VBDs ~__context ~self:vconf.vdi with + | [] -> + Storage_migrate_helper.failwith_fmt + "VDI %s does not have a corresponding VBD" + (Ref.string_of vconf.vdi) + | vbd_ref :: _ -> + (* XX Is it possible that this VDI might be used as multiple VBDs attached to different VMs? *) + let vm_ref = Db.VBD.get_VM ~__context ~self:vbd_ref in + let domid = + Db.VM.get_domid ~__context ~self:vm_ref |> Int64.to_string + in + Vm.of_string domid + in + debug "%s mirror_vm is %s copy_vm is %s live_vm is %s" __FUNCTION__ (Vm.string_of vconf.mirror_vm) - (Vm.string_of vconf.copy_vm) ; + (Vm.string_of vconf.copy_vm) + (Vm.string_of live_vm) ; (* Layering violation!! *) ignore (Storage_access.register_mirror __context id) ; Storage_migrate.start ~dbg ~sr:vconf.sr ~vdi:vconf.location ~dp:new_dp - ~mirror_vm:vconf.mirror_vm ~copy_vm:vconf.copy_vm ~url:remote.sm_url - ~dest:dest_sr ~verify_dest:is_intra_pool + ~mirror_vm:vconf.mirror_vm ~copy_vm:vconf.copy_vm ~live_vm + ~url:remote.sm_url ~dest:dest_sr ~verify_dest:is_intra_pool in let mapfn x = let total = Int64.to_float total_size in @@ -1062,7 +1070,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 ; @@ -1091,7 +1099,7 @@ let vdi_copy_fun __context dbg vdi_map remote is_intra_pool remote_vdis so_far 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 -> @@ -1586,7 +1594,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 diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index a7fc76a8417..fe7c7bed9dd 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_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 1a7350c2e9d..2f0add74368 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -2049,18 +2049,10 @@ let update_vm ~__context id = ) ; 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 ; + + (* 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 @@ -2071,8 +2063,22 @@ let update_vm ~__context id = debug "VM %s last_booted_record set to %s" (Ref.string_of self) x ) ; - if power_state = `Halted then + + (* 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 @@ -3104,6 +3110,12 @@ 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 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 dbg = Context.string_of_task __context in let open Xapi_xenops_queue in @@ -3113,6 +3125,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 -> diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index b8419b12fb8..d84e06e46fd 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -10,8 +10,8 @@ http_lib httpsvr inotify - mtime - mtime.clock.os + clock + mtime.clock rpclib.core rrd-transport rrd-transport.lib @@ -46,6 +46,7 @@ http_lib httpsvr inotify + clock rpclib.core rpclib.json rpclib.xml diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml index 6fa7d58aefe..172735708b4 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 6e11a2da31c..6a1212f178a 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -716,8 +716,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_shared.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml index 8800ed56836..816860e5815 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml @@ -20,14 +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 () +(* The mutex that protects the next_iteration_start against data corruption. *) +let next_iteration_start_m : Mutex.t = Mutex.create () (** Cache memory/target values *) let memory_targets : (int, int64) Hashtbl.t = Hashtbl.create 20 diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 448dc98f9cb..7f110d7e576 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -255,9 +255,51 @@ 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 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 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 |> List.to_seq + +let dss_mem_vms xc = + let mem_metrics_of (dom, uuid, domid) = + let vm_metrics () = let kib = Xenctrl.pages_to_kib (Int64.of_nativeint dom.Xenctrl.total_memory_pages) in @@ -317,14 +359,20 @@ let dss_mem_vms doms = ) with Not_found -> None in - List.concat - [ - main_mem_ds :: Option.to_list other_ds - ; Option.to_list mem_target_ds - ; acc - ] - ) - [] doms + let metrics = + List.concat + [main_mem_ds :: Option.to_list other_ds; Option.to_list mem_target_ds] + in + Some (List.to_seq metrics) + 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 None else vm_metrics () + in + let domains = domain_snapshot xc in + Seq.filter_map mem_metrics_of domains |> Seq.concat |> List.of_seq (**** Local cache SR stuff *) @@ -429,66 +477,18 @@ 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 ()) + ; ("mem_host", fun xc _ -> dss_mem_host xc) + ; ("mem_vms", fun xc _ -> dss_mem_vms xc) + ; ("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 @@ -505,10 +505,9 @@ let write_dom0_stats writers tagged_dss = in List.iter write_dss writers -let do_monitor_write xc writers = +let do_monitor_write domains_before xc writers = 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 + let tagged_dom0_stats = generate_all_dom0_stats xc in write_dom0_stats writers tagged_dom0_stats ; let dom0_stats = tagged_dom0_stats @@ -518,38 +517,64 @@ let do_monitor_write xc writers = ) in let plugins_stats = Rrdd_server.Plugin.read_stats () in + let domains_after = domain_snapshot xc 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 = 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 writers ; + 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 ) ) diff --git a/ocaml/xcp-rrdd/bin/rrdp-cpu/rrdp_cpu.ml b/ocaml/xcp-rrdd/bin/rrdp-cpu/rrdp_cpu.ml index e3b86db975b..30a66a29fbe 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,72 @@ 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 ( 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 () + ~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)) ~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)) ~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)) ~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)) ~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)) ~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.time1 + ++ ri.Xenctrl.time2 + ++ ri.Xenctrl.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 diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml index 0f547015304..6141090eae7 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml @@ -332,7 +332,10 @@ let refresh_phypath_to_sr_vdi () = let exec_tap_ctl_list () : ((string * string) * int) list = let tap_ctl = "/usr/sbin/tap-ctl list" in let extract_vdis pid minor _state kind phypath = - if not (kind = "vhd" || kind = "aio") then raise (Failure "Unknown type") ; + if not (kind = "vhd" || kind = "aio" || kind = "qcow2") then ( + D.warn {|"%s" is not a known type.|} kind ; + raise (Failure "Unknown type") + ) ; (* Look up SR and VDI uuids from the physical path *) if not (Hashtbl.mem phypath_to_sr_vdi phypath) then refresh_phypath_to_sr_vdi () ; diff --git a/ocaml/xcp-rrdd/bin/rrdview/dune b/ocaml/xcp-rrdd/bin/rrdview/dune new file mode 100644 index 00000000000..e2b2401ff76 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdview/dune @@ -0,0 +1,17 @@ +(executable + (modes byte exe) + (name rrdview) + ;(public_name rrdview) + (libraries + threads + 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 00000000000..80717c21e36 --- /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 00000000000..0c4ac9738e9 --- /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 00000000000..3716f4cfded --- /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 00000000000..e69de29bb2d diff --git a/ocaml/xcp-rrdd/test/rrdd/test_rrdd_monitor.ml b/ocaml/xcp-rrdd/test/rrdd/test_rrdd_monitor.ml index bb0f726b5eb..5ff9fac1bf2 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/xe-cli/bash-completion b/ocaml/xe-cli/bash-completion index 8120df874f3..4126708f91b 100644 --- a/ocaml/xe-cli/bash-completion +++ b/ocaml/xe-cli/bash-completion @@ -566,11 +566,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 +595,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 @@ -755,6 +776,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 +793,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 +805,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 diff --git a/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c b/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c index d7f3fee8f5e..4af5e60c8ec 100644 --- a/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c +++ b/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c @@ -323,40 +323,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 + Client.VDI.attach3 dbg dp sr vdi vmdomid read_write + ) + ) + +let activate ~task ~_vm ~vmdomid ~dp ~sr ~vdi = let dbg = get_dbg task in - let result = - Xenops_task.with_subtask task - (Printf.sprintf "VDI.attach3 %s" dp) - (transform_exception (fun () -> - Client.VDI.attach3 dbg dp sr vdi vmdomid read_write - ) - ) - in Xenops_task.with_subtask task (Printf.sprintf "VDI.activate3 %s" dp) - (transform_exception (fun () -> Client.VDI.activate3 dbg dp sr vdi vmdomid)) ; - result + (transform_exception (fun () -> Client.VDI.activate3 dbg dp sr vdi vmdomid)) let deactivate task dp sr vdi vmdomid = debug "Deactivating disk %s %s" (Sr.string_of sr) (Vdi.string_of vdi) ; diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index 7d3a145acdb..8fe027630fe 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -37,6 +37,8 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally let domain_shutdown_ack_timeout = ref 60. +let xenopsd_vbd_plug_unplug_legacy = ref true + type context = { transferred_fd: Unix.file_descr option (** some API calls take a file descriptor argument *) @@ -122,10 +124,14 @@ type atomic = | VM_hook_script_stable of (Vm.id * Xenops_hooks.script * string * Vm.id) | VM_hook_script of (Vm.id * Xenops_hooks.script * string) | VBD_plug of Vbd.id + | VBD_attach of Vbd.id + | VBD_activate of Vbd.id | VBD_epoch_begin of (Vbd.id * disk * bool) | VBD_epoch_end of (Vbd.id * disk) | VBD_set_qos of Vbd.id | VBD_unplug of Vbd.id * bool + | VBD_deactivate of Vbd.id * bool + | VBD_detach of Vbd.id | VBD_insert of Vbd.id * disk | VBD_set_active of Vbd.id * bool | VM_remove of Vm.id @@ -162,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] @@ -195,6 +203,10 @@ let rec name_of_atomic = function "VM_hook_script" | VBD_plug _ -> "VBD_plug" + | VBD_attach _ -> + "VBD_attach" + | VBD_activate _ -> + "VBD_activate" | VBD_epoch_begin _ -> "VBD_epoch_begin" | VBD_epoch_end _ -> @@ -203,6 +215,10 @@ let rec name_of_atomic = function "VBD_set_qos" | VBD_unplug _ -> "VBD_unplug" + | VBD_deactivate _ -> + "VBD_deactivate" + | VBD_detach _ -> + "VBD_detach" | VBD_insert _ -> "VBD_insert" | VBD_set_active _ -> @@ -272,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)) @@ -281,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 *) @@ -297,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] @@ -901,6 +921,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 @@ -1020,6 +1067,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) ) ) @@ -1204,11 +1253,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 @@ -1216,17 +1265,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 @@ -1253,7 +1303,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 = @@ -1268,7 +1320,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 @@ -1569,6 +1623,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)]) @@ -1578,8 +1637,31 @@ 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 + less than this, use serial or serial_concat *) +let serial_of name ~id at1 at2 ats = + Serial (id, Printf.sprintf "%s VM=%s" name id, at1 :: at2 :: ats) + +let vbd_plug vbd_id = + if !xenopsd_vbd_plug_unplug_legacy then + VBD_plug vbd_id + else + serial_of "VBD.attach_and_activate" ~id:(VBD_DB.vm_of vbd_id) + (VBD_attach vbd_id) (VBD_activate vbd_id) [] + +let vbd_unplug vbd_id force = + if !xenopsd_vbd_plug_unplug_legacy then + VBD_unplug (vbd_id, force) + else + serial_of "VBD.deactivate_and_detach" ~id:(VBD_DB.vm_of vbd_id) + (VBD_deactivate (vbd_id, force)) + (VBD_detach vbd_id) [] + let rec atomics_of_operation = function | VM_start (id, force) -> let vbds_rw, vbds_ro = VBD_DB.vbds id |> vbd_plug_sets in @@ -1595,7 +1677,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)] @@ -1604,7 +1686,7 @@ let rec atomics_of_operation = function [VBD_epoch_begin (vbd.Vbd.id, x, vbd.Vbd.persistent)] ) vbd.Vbd.backend - ; [VBD_plug vbd.Vbd.id] + ; [vbd_plug vbd.Vbd.id] ] ) in @@ -1629,11 +1711,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)] ) ] ] @@ -1668,7 +1750,7 @@ let rec atomics_of_operation = function ] ; parallel_concat "Devices.unplug" ~id [ - List.map (fun vbd -> VBD_unplug (vbd.Vbd.id, true)) vbds + List.map (fun vbd -> vbd_unplug vbd.Vbd.id true) vbds ; List.map (fun vif -> VIF_unplug (vif.Vif.id, true)) vifs ; List.map (fun pci -> PCI_unplug pci.Pci.id) pcis ] @@ -1692,7 +1774,7 @@ let rec atomics_of_operation = function 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] + [VBD_set_active (vbd.Vbd.id, true); vbd_plug vbd.Vbd.id] ) in [ @@ -1825,9 +1907,9 @@ let rec atomics_of_operation = function ] |> List.concat | VBD_hotplug id -> - [VBD_set_active (id, true); VBD_plug id] + [VBD_set_active (id, true); vbd_plug id] | VBD_hotunplug (id, force) -> - [VBD_unplug (id, force); VBD_set_active (id, false)] + [vbd_unplug id force; VBD_set_active (id, false)] | VIF_hotplug id -> [VIF_set_active (id, true); VIF_plug id] | VIF_hotunplug (id, force) -> @@ -1847,57 +1929,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 -> @@ -2017,7 +2054,16 @@ let rec perform_atomic ~progress_callback ?result (op : atomic) Xenops_hooks.vm ~script ~reason ~id ~extra_args | VBD_plug id -> debug "VBD.plug %s" (VBD_DB.string_of_id id) ; - B.VBD.plug t (VBD_DB.vm_of id) (VBD_DB.read_exn id) ; + B.VBD.attach t (VBD_DB.vm_of id) (VBD_DB.read_exn id) ; + B.VBD.activate t (VBD_DB.vm_of id) (VBD_DB.read_exn id) ; + VBD_DB.signal id + | VBD_attach id -> + debug "VBD.attach %s" (VBD_DB.string_of_id id) ; + B.VBD.attach t (VBD_DB.vm_of id) (VBD_DB.read_exn id) ; + VBD_DB.signal id + | VBD_activate id -> + debug "VBD.activate %s" (VBD_DB.string_of_id id) ; + B.VBD.activate t (VBD_DB.vm_of id) (VBD_DB.read_exn id) ; VBD_DB.signal id | VBD_set_active (id, b) -> debug "VBD.set_active %s %b" (VBD_DB.string_of_id id) b ; @@ -2036,8 +2082,22 @@ 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.unplug t (VBD_DB.vm_of id) (VBD_DB.read_exn id) force) + (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 () -> VBD_DB.signal id) + | VBD_deactivate (id, force) -> + debug "VBD.deactivate %s" (VBD_DB.string_of_id id) ; + finally + (fun () -> + B.VBD.deactivate t (VBD_DB.vm_of id) (VBD_DB.read_exn id) force + ) + (fun () -> VBD_DB.signal id) + | VBD_detach id -> + debug "VBD.detach %s" (VBD_DB.string_of_id id) ; + B.VBD.detach t (VBD_DB.vm_of id) (VBD_DB.read_exn id) ; + VBD_DB.signal id | VBD_insert (id, disk) -> ( (* NB this is also used to "refresh" ie signal a qemu that it should re-open a device, useful for when a physical CDROM is inserted into the @@ -2303,7 +2363,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 @@ -2312,10 +2457,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 -> @@ -2328,7 +2475,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 @@ -2445,11 +2594,15 @@ and trigger_cleanup_after_failure_atom op t = match op with | VBD_eject id | VBD_plug id + | VBD_attach id + | VBD_activate id | VBD_set_active (id, _) | VBD_epoch_begin (id, _, _) | VBD_epoch_end (id, _) | VBD_set_qos id | VBD_unplug (id, _) + | VBD_deactivate (id, _) + | VBD_detach id | VBD_insert (id, _) -> immediate_operation dbg (fst id) (VBD_check_state id) | VIF_plug id @@ -2500,7 +2653,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) ; @@ -2628,19 +2783,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 *) @@ -3203,7 +3369,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 @@ -3211,11 +3378,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 = @@ -3399,12 +3566,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 !default_numa_affinity_policy -let numa_placement = ref Xenops_interface.Host.Any +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 = @@ -3502,7 +3682,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'))) @@ -3539,11 +3721,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 @@ -3597,7 +3785,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') @@ -3614,6 +3802,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 } ) @@ -3663,7 +3852,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 diff --git a/ocaml/xenopsd/lib/xenops_server_plugin.ml b/ocaml/xenopsd/lib/xenops_server_plugin.ml index fbeb78f3640..1a52749a9f3 100644 --- a/ocaml/xenopsd/lib/xenops_server_plugin.ml +++ b/ocaml/xenopsd/lib/xenops_server_plugin.ml @@ -207,9 +207,13 @@ module type S = sig val epoch_end : Xenops_task.task_handle -> Vm.id -> disk -> unit - val plug : Xenops_task.task_handle -> Vm.id -> Vbd.t -> unit + val attach : Xenops_task.task_handle -> Vm.id -> Vbd.t -> unit - val unplug : Xenops_task.task_handle -> Vm.id -> Vbd.t -> bool -> unit + val activate : Xenops_task.task_handle -> Vm.id -> Vbd.t -> unit + + val deactivate : Xenops_task.task_handle -> Vm.id -> Vbd.t -> bool -> unit + + val detach : Xenops_task.task_handle -> Vm.id -> Vbd.t -> unit val insert : Xenops_task.task_handle -> Vm.id -> Vbd.t -> disk -> unit diff --git a/ocaml/xenopsd/lib/xenops_server_simulator.ml b/ocaml/xenopsd/lib/xenops_server_simulator.ml index c5123641978..f8c0afab8ab 100644 --- a/ocaml/xenopsd/lib/xenops_server_simulator.ml +++ b/ocaml/xenopsd/lib/xenops_server_simulator.ml @@ -673,9 +673,13 @@ module VBD = struct let epoch_end _ (_vm : Vm.id) (_disk : disk) = () - let plug _ (vm : Vm.id) (vbd : Vbd.t) = with_lock m (add_vbd vm vbd) + let attach _ (vm : Vm.id) (vbd : Vbd.t) = with_lock m (add_vbd vm vbd) - let unplug _ vm vbd _ = with_lock m (remove_vbd vm vbd) + let activate _ (_vm : Vm.id) (_vbd : Vbd.t) = () + + let deactivate _ vm vbd _ = with_lock m (remove_vbd vm vbd) + + let detach _ _vm _vbd = () let insert _ _vm _vbd _disk = () diff --git a/ocaml/xenopsd/lib/xenops_server_skeleton.ml b/ocaml/xenopsd/lib/xenops_server_skeleton.ml index dc1b826f85e..2055837c47c 100644 --- a/ocaml/xenopsd/lib/xenops_server_skeleton.ml +++ b/ocaml/xenopsd/lib/xenops_server_skeleton.ml @@ -145,9 +145,13 @@ module VBD = struct let epoch_end _ _ _ = () - let plug _ _ _ = unimplemented "VBD.plug" + let attach _ _ _ = unimplemented "VBD.attach" - let unplug _ _ _ _ = unimplemented "VBD.unplug" + let activate _ _ _ = unimplemented "VBD.activate" + + let deactivate _ _ _ _ = unimplemented "VBD.deactivate" + + let detach _ _ _ = unimplemented "VBD.detach" let insert _ _ _ _ = unimplemented "VBD.insert" diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index e0a4f5949db..9c5e83e04ce 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -59,8 +59,6 @@ let feature_flags_path = ref "/etc/xenserver/features.d" let pvinpvh_xen_cmdline = ref "pv-shim console=xen" -let numa_placement_compat = ref false - (* O(N^2) operations, until we get a xenstore cache, so use a small number here *) let vm_guest_agent_xenstore_quota = ref 128 @@ -242,8 +240,11 @@ let options = , "Command line for the inner-xen for PV-in-PVH guests" ) ; ( "numa-placement" - , Arg.Bool (fun x -> numa_placement_compat := x) - , (fun () -> string_of_bool !numa_placement_compat) + , Arg.Bool (fun _ -> ()) + , (fun () -> + string_of_bool + (!Xenops_server.default_numa_affinity_policy = Best_effort) + ) , "NUMA-aware placement of VMs (deprecated, use XAPI setting)" ) ; ( "pci-quarantine" @@ -283,6 +284,11 @@ let options = , (fun () -> string_of_int !test_open) , "TESTING only: open N file descriptors" ) + ; ( "xenopsd-vbd-plug-unplug-legacy" + , Arg.Bool (fun x -> Xenops_server.xenopsd_vbd_plug_unplug_legacy := x) + , (fun () -> string_of_bool !Xenops_server.xenopsd_vbd_plug_unplug_legacy) + , "False if we want to split the plug atomic into attach/activate" + ) ] let path () = Filename.concat !sockets_path "xenopsd" diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index 19f28e41985..c1561b862a5 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] @@ -857,7 +857,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 () -> @@ -888,7 +894,7 @@ 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 @@ -898,7 +904,7 @@ let numa_placement domid ~vcpus ~memory = 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 +956,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 @@ -1129,7 +1163,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 +1182,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 +1210,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 +1233,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 = @@ -1633,8 +1667,7 @@ 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 diff --git a/ocaml/xenopsd/xc/domain.mli b/ocaml/xenopsd/xc/domain.mli index c8f83b0994a..4fac8ccde5a 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 diff --git a/ocaml/xenopsd/xc/xenctrlext.ml b/ocaml/xenopsd/xc/xenctrlext.ml index a0e0c0ed311..4078ee7b945 100644 --- a/ocaml/xenopsd/xc/xenctrlext.ml +++ b/ocaml/xenopsd/xc/xenctrlext.ml @@ -90,6 +90,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" diff --git a/ocaml/xenopsd/xc/xenctrlext.mli b/ocaml/xenopsd/xc/xenctrlext.mli index 559842fac75..2199f42c452 100644 --- a/ocaml/xenopsd/xc/xenctrlext.mli +++ b/ocaml/xenopsd/xc/xenctrlext.mli @@ -78,6 +78,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" diff --git a/ocaml/xenopsd/xc/xenguestHelper.ml b/ocaml/xenopsd/xc/xenguestHelper.ml index b76fec51c25..06a28d92f33 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 46c262283fa..a1a37085659 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -187,6 +187,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 []] } [@@deriving rpcty] @@ -411,18 +412,16 @@ module Storage = struct let vm_of_domid = vm_of_domid (* We need to deal with driver domains here: *) - let attach_and_activate ~xc:_ ~xs task vm dp sr vdi read_write = + let attach ~xc:_ ~xs task vm dp sr vdi read_write = let vmdomid = vm_of_domid (domid_of_uuid ~xs (uuid_of_string vm)) in - let result = - attach_and_activate ~task ~_vm:vm ~vmdomid ~dp ~sr ~vdi ~read_write - in + let result = attach ~task ~_vm:vm ~vmdomid ~dp ~sr ~vdi ~read_write in let backend = Xenops_task.with_subtask task (Printf.sprintf "Policy.get_backend_vm %s %s %s" vm (Sr.string_of sr) (Vdi.string_of vdi) ) (transform_exception (fun () -> - Client.Policy.get_backend_vm "attach_and_activate" vm sr vdi + Client.Policy.get_backend_vm "attach" vm sr vdi ) ) in @@ -432,6 +431,10 @@ module Storage = struct | Some domid -> {domid; attach_info= result} + let activate ~xc:_ ~xs task vm dp sr vdi = + let vmdomid = vm_of_domid (domid_of_uuid ~xs (uuid_of_string vm)) in + activate ~task ~_vm:vm ~vmdomid ~dp ~sr ~vdi + let deactivate = deactivate let dp_destroy = dp_destroy @@ -506,10 +509,11 @@ let with_disk ~xc ~xs task disk write f = (fun () -> let frontend_domid = this_domid ~xs in let frontend_vm = get_uuid ~xc frontend_domid |> Uuidx.to_string in - let vdi = - attach_and_activate ~xc ~xs task frontend_vm dp sr vdi write + let attached_vdi = attach ~xc ~xs task frontend_vm dp sr vdi write in + activate ~xc ~xs task frontend_vm dp sr vdi ; + let device = + create_vbd_frontend ~xc ~xs task frontend_domid attached_vdi in - let device = create_vbd_frontend ~xc ~xs task frontend_domid vdi in finally (fun () -> match device with @@ -1283,7 +1287,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. @@ -1299,8 +1303,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 = @@ -1308,38 +1310,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) -> @@ -1355,7 +1325,6 @@ module VM = struct (match vm.ty with PVinPVH _ -> vm.vcpu_max | _ -> vm.vcpus) ) ] - @ affinity @ weight in let set_generation_id platformdata = @@ -2036,7 +2005,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 ; @@ -3538,11 +3507,14 @@ module VBD = struct let vdi_attach_path vbd = Printf.sprintf "/xapi/%s/private/vdis/%s" (fst vbd.id) (snd vbd.id) - let attach_and_activate task xc xs frontend_domid vbd vdi = - let vdi = - match vdi with - | None -> - (* XXX: do something better with CDROMs *) + type attachment_status = Attached of attached_vdi | PathToAttach of string + + (* For vdis that are None or local, return Attached attached_vdi, otherwise return PathToAttach path *) + let attachment_status_of_vdi xs vdi = + match vdi with + | None -> + (* XXX: do something better with CDROMs *) + Attached { domid= this_domid ~xs ; attach_info= @@ -3555,7 +3527,8 @@ module VBD = struct ] } } - | Some (Local path) -> + | Some (Local path) -> + Attached { domid= this_domid ~xs ; attach_info= @@ -3568,17 +3541,34 @@ module VBD = struct ] } } - | Some (VDI path) -> + | Some (VDI path) -> + PathToAttach path + + let attach' task xc xs frontend_domid vbd vdi = + let vdi = + match attachment_status_of_vdi xs vdi with + | Attached attached_vdi -> + attached_vdi + | PathToAttach path -> let sr, vdi = Storage.get_disk_by_name task path in let dp = Storage.id_of (string_of_int frontend_domid) vbd.id in let vm = fst vbd.id in - Storage.attach_and_activate ~xc ~xs task vm dp sr vdi - (vbd.mode = ReadWrite) + Storage.attach ~xc ~xs task vm dp sr vdi (vbd.mode = ReadWrite) in xs.Xs.write (vdi_attach_path vbd) (vdi |> rpc_of attached_vdi |> Jsonrpc.to_string) ; vdi + let activate' task xc xs frontend_domid vbd vdi = + match attachment_status_of_vdi xs vdi with + | Attached _ -> + () + | PathToAttach path -> + let sr, vdi = Storage.get_disk_by_name task path in + let dp = Storage.id_of (string_of_int frontend_domid) vbd.id in + let vm = fst vbd.id in + Storage.activate ~xc ~xs task vm dp sr vdi + let frontend_domid_of_device device = device.Device_common.frontend.Device_common.domid @@ -3657,170 +3647,234 @@ module VBD = struct let vdi_path_of_device ~xs device = Device_common.backend_path_of_device ~xs device ^ "/vdi" - let plug task vm vbd = + let attach task vm vbd = (* If the vbd isn't listed as "active" then we don't automatically plug this - one in *) - if not (get_active vm vbd) then - debug "VBD %s.%s is not active: not plugging into VM" (fst vbd.Vbd.id) - (snd vbd.Vbd.id) - else - on_frontend - (fun xc xs frontend_domid domain_type -> - if vbd.backend = None && domain_type <> Vm.Domain_HVM then - info - "VM = %s; an empty CDROM drive on PV and PVinPVH guests is \ - simulated by unplugging the whole drive" - vm - else - let vdi = - attach_and_activate task xc xs frontend_domid vbd vbd.backend - in - let params, xenstore_data, extra_keys = - params_of_backend vdi.attach_info - in - let new_keys = - List.map (fun (k, v) -> ("sm-data/" ^ k, v)) xenstore_data - @ extra_keys - in - let extra_backend_keys = - List.fold_left - (fun acc (k, v) -> (k, v) :: List.remove_assoc k acc) - vbd.extra_backend_keys new_keys - in - let kind = device_kind_of ~xs vbd in - (* Remember the VBD id with the device *) - let vbd_id = (_device_id kind, id_of vbd) in - (* Remember the VDI with the device (for later deactivation) *) - let vdi_id = - (_vdi_id, vbd.backend |> rpc_of backend |> Jsonrpc.to_string) - in - let dp_id = - (_dp_id, Storage.id_of (string_of_int frontend_domid) vbd.Vbd.id) - in - let x = - { - Device.Vbd.mode= - ( match vbd.mode with - | ReadOnly -> - Device.Vbd.ReadOnly - | ReadWrite -> - Device.Vbd.ReadWrite - ) - ; device_number= vbd.position - ; phystype= Device.Vbd.Phys - ; params - ; dev_type= - ( match vbd.ty with - | CDROM -> - Device.Vbd.CDROM - | Disk -> - Device.Vbd.Disk - | Floppy -> - Device.Vbd.Floppy + one in *) + let attached_vdi = + if not (get_active vm vbd) then ( + debug "VBD %s.%s is not active: not plugging into VM" (fst vbd.Vbd.id) + (snd vbd.Vbd.id) ; + None + ) else + on_frontend + (fun xc xs frontend_domid domain_type -> + if vbd.backend = None && domain_type <> Vm.Domain_HVM then ( + info + "VM = %s; an empty CDROM drive on PV and PVinPVH guests is \ + simulated by unplugging the whole drive" + vm ; + None + ) else + Some (attach' task xc xs frontend_domid vbd vbd.backend) + ) + vm + in + match attached_vdi with + | None -> + () + | Some vdi -> + (* Record the attached_vdi so it can be used in activate *) + let _ = + DB.update_exn vm (fun vm_t -> + Some + VmExtra. + { + persistent= + { + vm_t.VmExtra.persistent with + attached_vdis= + (vbd.Vbd.id, vdi) + :: List.remove_assoc vbd.Vbd.id + vm_t.persistent.attached_vdis + } + } + ) + in + () + + let cleanup_attached_vdis vm vbd_id = + let _ = + DB.update_exn vm (fun vm_t -> + let remaining_vdis = + List.remove_assoc vbd_id vm_t.persistent.attached_vdis + in + Some + {persistent= {vm_t.persistent with attached_vdis= remaining_vdis}} + ) + in + () + + let activate task vm vbd = + let vmextra = DB.read_exn vm in + match List.assoc_opt vbd.id vmextra.persistent.attached_vdis with + | None -> + debug "No attached_vdi info, so not activating" + | Some vdi -> + finally + (fun () -> + on_frontend + (fun xc xs frontend_domid domain_type -> + activate' task xc xs frontend_domid vbd vbd.backend ; + let params, xenstore_data, extra_keys = + params_of_backend vdi.attach_info + in + let new_keys = + List.map (fun (k, v) -> ("sm-data/" ^ k, v)) xenstore_data + @ extra_keys + in + let extra_backend_keys = + List.fold_left + (fun acc (k, v) -> (k, v) :: List.remove_assoc k acc) + vbd.extra_backend_keys new_keys + in + let kind = device_kind_of ~xs vbd in + (* Remember the VBD id with the device *) + let vbd_id = (_device_id kind, id_of vbd) in + (* Remember the VDI with the device (for later deactivation) *) + let vdi_id = + (_vdi_id, vbd.backend |> rpc_of backend |> Jsonrpc.to_string) + in + let dp_id = + ( _dp_id + , Storage.id_of (string_of_int frontend_domid) vbd.Vbd.id ) - ; unpluggable= vbd.unpluggable - ; protocol= None - ; kind - ; extra_backend_keys - ; extra_private_keys= - dp_id :: vdi_id :: vbd_id :: vbd.extra_private_keys - ; backend_domid= vdi.domid - } - in - let dev = - Xenops_task.with_subtask task - (Printf.sprintf "Vbd.add %s" (id_of vbd)) - (fun () -> - Device.Vbd.add task ~xc ~xs - ~hvm:(domain_type = Vm.Domain_HVM) - x frontend_domid - ) - in - (* We store away the disk so we can implement VBD.stat *) - Option.iter - (fun d -> - xs.Xs.write - (vdi_path_of_device ~xs dev) - (d |> rpc_of disk |> Jsonrpc.to_string) - ) - vbd.backend ; - (* NB now the frontend position has been resolved *) - let open Device_common in - let device_number = - dev.frontend.devid |> Device_number.of_xenstore_key - in - let qemu_domid = this_domid ~xs in - let qemu_frontend = - let maybe_create_vbd_frontend () = - let index = Device_number.disk device_number in - match vbd.Vbd.backend with - | None -> - Some (index, Empty) - | Some _ -> - Some (index, create_vbd_frontend ~xc ~xs task qemu_domid vdi) - in - match (device_number :> Device_number.bus_type * int * int) with - | Ide, n, _ when 0 <= n && n < 4 -> - maybe_create_vbd_frontend () - | Floppy, n, _ when 0 <= n && n < 2 -> - maybe_create_vbd_frontend () - | Ide, n, _ -> - D.warn - "qemu_frontend: Ide supports device numbers between 0 and \ - 3, but got: %i" - n ; - None - | Floppy, n, _ -> - D.warn - "qemu_frontend: Floppy supports device numbers between 0 \ - and 1, but got: %i" - n ; - None - | (Xen | Scsi), _, _ -> - None - in - (* Remember what we've just done *) - (* Dom0 doesn't have a vm_t - we don't need this currently, but when - we have storage driver domains, we will. Also this causes the - SMRT tests to fail, as they demand the loopback VBDs *) - Option.iter - (fun q -> - let _ = - DB.update_exn vm (fun vm_t -> - Some - VmExtra. - { - persistent= + in + let x = + { + Device.Vbd.mode= + ( match vbd.mode with + | ReadOnly -> + Device.Vbd.ReadOnly + | ReadWrite -> + Device.Vbd.ReadWrite + ) + ; device_number= vbd.position + ; phystype= Device.Vbd.Phys + ; params + ; dev_type= + ( match vbd.ty with + | CDROM -> + Device.Vbd.CDROM + | Disk -> + Device.Vbd.Disk + | Floppy -> + Device.Vbd.Floppy + ) + ; unpluggable= vbd.unpluggable + ; protocol= None + ; kind + ; extra_backend_keys + ; extra_private_keys= + dp_id :: vdi_id :: vbd_id :: vbd.extra_private_keys + ; backend_domid= vdi.domid + } + in + let dev = + with_tracing ~task ~name:"VBD_activate_add" @@ fun () -> + Xenops_task.with_subtask task + (Printf.sprintf "Vbd.add %s" (id_of vbd)) + (fun () -> + Device.Vbd.add task ~xc ~xs + ~hvm:(domain_type = Vm.Domain_HVM) + x frontend_domid + ) + in + (* We store away the disk so we can implement VBD.stat *) + ( with_tracing ~task ~name:"VBD_activate_xs_write" @@ fun () -> + Option.iter + (fun d -> + xs.Xs.write + (vdi_path_of_device ~xs dev) + (d |> rpc_of disk |> Jsonrpc.to_string) + ) + vbd.backend + ) ; + with_tracing ~task ~name:"VBD_activate_qemu" @@ fun () -> + (* NB now the frontend position has been resolved *) + let open Device_common in + let device_number = + dev.frontend.devid |> Device_number.of_xenstore_key + in + let qemu_domid = this_domid ~xs in + let qemu_frontend = + let maybe_create_vbd_frontend () = + let index = Device_number.disk device_number in + match vbd.Vbd.backend with + | None -> + Some (index, Empty) + | Some _ -> + Some + ( index + , create_vbd_frontend ~xc ~xs task qemu_domid vdi + ) + in + match + (device_number :> Device_number.bus_type * int * int) + with + | Ide, n, _ when 0 <= n && n < 4 -> + maybe_create_vbd_frontend () + | Floppy, n, _ when 0 <= n && n < 2 -> + maybe_create_vbd_frontend () + | Ide, n, _ -> + D.warn + "qemu_frontend: Ide supports device numbers between 0 \ + and 3, but got: %i" + n ; + None + | Floppy, n, _ -> + D.warn + "qemu_frontend: Floppy supports device numbers between \ + 0 and 1, but got: %i" + n ; + None + | (Xen | Scsi), _, _ -> + None + in + (* Remember what we've just done *) + (* Dom0 doesn't have a vm_t - we don't need this currently, but when + we have storage driver domains, we will. Also this causes the + SMRT tests to fail, as they demand the loopback VBDs *) + Option.iter + (fun q -> + let _ = + DB.update_exn vm (fun vm_t -> + Some + VmExtra. { - vm_t.VmExtra.persistent with - qemu_vbds= - (vbd.Vbd.id, q) :: vm_t.persistent.qemu_vbds + persistent= + { + vm_t.VmExtra.persistent with + qemu_vbds= + (vbd.Vbd.id, q) + :: vm_t.persistent.qemu_vbds + } } - } + ) + in + () ) - in - () + qemu_frontend ) - qemu_frontend - ) - vm + vm + ) + (fun () -> cleanup_attached_vdis vm vbd.id) - let unplug task vm vbd force = + let deactivate 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 + 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 + 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. *) + 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. *) + need to free any storage resources. *) let dev = try Some (device_by_id xc xs vm (device_kind_of ~xs vbd) (id_of vbd)) @@ -3858,7 +3912,8 @@ module VBD = struct vm (id_of vbd) ; (* this happens on normal shutdown too *) (* Case (1): success; Case (2): success; Case (3): an exception is - thrown *) + thrown *) + with_tracing ~task ~name:"VBD_device_shutdown" @@ fun () -> Xenops_task.with_subtask task (Printf.sprintf "Vbd.clean_shutdown %s" (id_of vbd)) (fun () -> @@ -3868,17 +3923,20 @@ module VBD = struct ) dev ; (* We now have a shutdown device but an active DP: we should destroy - the DP if the backend is of type VDI *) + the DP if the backend is of type VDI *) finally (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 ; + 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 -> @@ -3909,10 +3967,14 @@ module VBD = struct () ) (fun () -> + with_tracing ~task ~name:"VBD_deactivate" @@ fun () -> + let vmid = Storage.vm_of_domid domid in 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) + | Some x, Some (VDI path) -> + let sr, vdi = Storage.get_disk_by_name task path in + let dp = Storage.id_of (string_of_int x) vbd.id in + Storage.deactivate task dp sr vdi vmid + (* We don't need to detach Local or CDROM *) | _ -> () ) @@ -3921,18 +3983,58 @@ module VBD = struct raise (Xenopsd_error (Device_detach_rejected ("VBD", id_of vbd, s))) ) + let detach task vm vbd = + with_xc_and_xs (fun xc xs -> + let domid = domid_of_uuid ~xs (uuid_of_string vm) in + 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 + 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) + | _ -> + () + ) ; + cleanup_attached_vdis vm vbd.id + let insert task vm vbd d = on_frontend (fun xc xs frontend_domid domain_type -> - if domain_type <> Vm.Domain_HVM then - plug task vm {vbd with backend= Some d} - else + if domain_type <> Vm.Domain_HVM then ( + attach task vm {vbd with backend= Some d} ; + activate task vm {vbd with backend= Some d} + ) else let (device : Device_common.device) = device_by_id xc xs vm (device_kind_of ~xs vbd) (id_of vbd) in - let vdi = - attach_and_activate task xc xs frontend_domid vbd (Some d) - in + let vdi = attach' task xc xs frontend_domid vbd (Some d) in + activate' task xc xs frontend_domid vbd (Some d) ; let params, xenstore_data, _ = params_of_backend vdi.attach_info in let phystype = Device.Vbd.Phys in (* We store away the disk so we can implement VBD.stat *) @@ -5157,8 +5259,6 @@ let init () = {Xs_protocol.ACL.owner= 0; other= Xs_protocol.ACL.READ; acl= []} ) ; Device.Backend.init () ; - Xenops_server.default_numa_affinity_policy := - if !Xenopsd.numa_placement_compat then Best_effort else Any ; info "Default NUMA affinity policy is '%s'" Xenops_server.(string_of_numa_affinity_policy !default_numa_affinity_policy) ; Xenops_server.numa_placement := !Xenops_server.default_numa_affinity_policy ; diff --git a/ocaml/xs-trace/dune b/ocaml/xs-trace/dune index e34fc7e5575..4a19b8c888a 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)) (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 6360649fb20..a5f0c8becef 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/opam/xapi-tools.opam b/opam/xapi-tools.opam index da2e2ce2967..3116f8d3293 100644 --- a/opam/xapi-tools.opam +++ b/opam/xapi-tools.opam @@ -24,6 +24,7 @@ depends: [ "rpclib" "rresult" "uri" + "tyre" "xenctrl" "xmlm" "yojson" diff --git a/python3/libexec/nbd_client_manager.py b/python3/libexec/nbd_client_manager.py index 3d0920a3845..99dd85c6cc9 100644 --- a/python3/libexec/nbd_client_manager.py +++ b/python3/libexec/nbd_client_manager.py @@ -208,7 +208,8 @@ def connect_nbd(path, exportname): path, nbd_device, "-timeout", - "60", + "90", + "-persist", "-name", exportname, ] diff --git a/quality-gate.sh b/quality-gate.sh index 605d5142a38..f6540cb2a1f 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=497 + N=467 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 ' == '" diff --git a/scripts/xapi.conf b/scripts/xapi.conf index 46f859a8d42..91a5ea40f56 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 diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 19f0cf0e4a9..88980776b9b 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