diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index 4c2762b5222..d8259ca9cd8 100644 --- a/.git-blame-ignore-revs +++ b/.git-blame-ignore-revs @@ -29,6 +29,7 @@ b020cf35a1f2c274f95a4118d4596043cba6113f ff39018fd6d91985f9c893a56928771dfe9fa48d cbb9edb17dfd122c591beb14d1275acc39492335 d6ab15362548b8fe270bd14d5153b8d94e1b15c0 +b12cf444edea15da6274975e1b2ca6a7fce2a090 # ocp-indent d018d26d6acd4707a23288b327b49e44f732725e diff --git a/.github/workflows/1.249-lcm.yml b/.github/workflows/1.249-lcm.yml index 5fec8bef8d8..39132476bd9 100644 --- a/.github/workflows/1.249-lcm.yml +++ b/.github/workflows/1.249-lcm.yml @@ -15,7 +15,7 @@ jobs: test: ["", "-3"] steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: ref: '1.249-lcm' @@ -25,54 +25,43 @@ jobs: ocaml-test: name: Ocaml tests runs-on: ubuntu-20.04 - env: - package: "xapi-cli-protocol xapi-client xapi-consts xapi-database xapi-datamodel xapi-types xapi xe" steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: ref: '1.249-lcm' + - name: Free space + shell: bash + run: sudo rm -rf /usr/local/lib/android + - name: Pull configuration from xs-opam run: | curl --fail --silent https://raw.githubusercontent.com/xapi-project/xs-opam/release/yangtze/lcm/tools/xs-opam-ci.env | cut -f2 -d " " > .env - name: Load environment file id: dotenv - uses: falti/dotenv-action@v1.0.2 - - - name: Retrieve date for cache key (year-week) - id: cache-key - run: echo "date=$(/bin/date -u "+%Y%W")" >> $GITHUB_OUTPUT - shell: bash - - - name: Restore opam cache - id: opam-cache - uses: actions/cache@v3 - with: - path: "~/.opam" - # invalidate cache every week, gets built using a scheduled job - key: ${{ steps.cache-key.outputs.date }}-1.249 + uses: falti/dotenv-action@v1 - name: Update Ubuntu repositories + shell: bash run: sudo apt-get update - name: Use ocaml - uses: avsm/setup-ocaml@v1 + uses: ocaml/setup-ocaml@v2 with: - ocaml-version: ${{ steps.dotenv.outputs.ocaml_version_full }} - opam-repository: ${{ steps.dotenv.outputs.repository }} + ocaml-compiler: ${{ steps.dotenv.outputs.ocaml_version_full }} + opam-repositories: | + xs-opam: ${{ steps.dotenv.outputs.repository }} + dune-cache: true - name: Install dependencies - run: | - opam update - opam pin add . --no-action - opam depext -u ${{ env.package }} - opam upgrade - opam install ${{ env.package }} --deps-only --with-test -v + shell: bash + run: opam install . --deps-only --with-test -v - - name: Build + - name: Configure and build + shell: bash run: | opam exec -- ./configure opam exec -- make @@ -85,4 +74,4 @@ jobs: - name: Avoid built packages to appear in the cache # only packages in this repository follow a branch, the rest point # to a tag - run: opam uninstall ${{ env.package }} + run: opam pin list --short | xargs opam unpin diff --git a/.github/workflows/cleanup-xapi-environment/action.yml b/.github/workflows/cleanup-xapi-environment/action.yml deleted file mode 100644 index 96323007e4e..00000000000 --- a/.github/workflows/cleanup-xapi-environment/action.yml +++ /dev/null @@ -1,13 +0,0 @@ -name: Cleanup XenAPI environment -description: Cleanup XenAPI environment created using the setup-xapi-environment composite action - -runs: - using: "composite" - steps: - - name: Uninstall unversioned packages and remove pins - shell: bash - # This should purge them from the cache, unversioned package have - # 'master' as its version - run: | - opam list | awk -F " " '$2 == "master" { print $1 }' | xargs opam uninstall - opam pin list | cut -f1 -d "." | xargs opam unpin diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index 5a05a5dfc81..096fe18227b 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -14,7 +14,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Pull configuration from xs-opam run: | @@ -43,7 +43,7 @@ jobs: opam exec -- dune exec ocaml/xapi-storage/generator/src/main.exe -- gen_markdown --path=$STORAGE_DOCDIR - name: Deploy xapi-storage docs - uses: peaceiris/actions-gh-pages@v3 + uses: peaceiris/actions-gh-pages@v4 with: deploy_key: ${{ secrets.ACTIONS_STORAGE_DEPLOY_KEY }} publish_dir: ${{ env.STORAGE_DOCDIR }} diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index b15173805cf..aca7f00f4a6 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -14,7 +14,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Pull configuration from xs-opam run: | @@ -22,7 +22,7 @@ jobs: - name: Load environment file id: dotenv - uses: falti/dotenv-action@v1.0.4 + uses: falti/dotenv-action@v1 - name: Update Ubuntu repositories run: sudo apt-get update diff --git a/.github/workflows/generate-and-build-sdks.yml b/.github/workflows/generate-and-build-sdks.yml index 92f0f52b854..9657b1f9b8c 100644 --- a/.github/workflows/generate-and-build-sdks.yml +++ b/.github/workflows/generate-and-build-sdks.yml @@ -13,7 +13,7 @@ jobs: runs-on: ubuntu-20.04 steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Setup XenAPI environment uses: ./.github/workflows/setup-xapi-environment @@ -24,20 +24,54 @@ jobs: shell: bash run: opam exec -- make sdk + - name: Store C SDK source + uses: actions/upload-artifact@v4 + with: + name: SDK_Source_C + path: | + _build/install/default/xapi/sdk/c/* + !_build/install/default/xapi/sdk/c/dune + - name: Store C# SDK source - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: SDK_Source_CSharp path: _build/install/default/xapi/sdk/csharp/* - name: Store PowerShell SDK source - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: SDK_Source_PowerShell path: _build/install/default/xapi/sdk/powershell/* - - name: Cleanup XenAPI environment - uses: ./.github/workflows/cleanup-xapi-environment + - name: Trim dune cache + run: opam exec -- dune cache trim --size=2GiB + + build-c-sdk: + name: Build C SDK + runs-on: ubuntu-latest + needs: generate-sdk-sources + steps: + - name: Install dependencies + run: sudo apt-get install libxml2-dev + + - name: Retrieve C SDK source + uses: actions/download-artifact@v4 + with: + name: SDK_Source_C + path: source/ + + - name: Build C SDK + shell: bash + run: make -C source + + - name: Store C SDK + uses: actions/upload-artifact@v4 + with: + name: SDK_Artifacts_C + path: | + source/* + !source/src/*.o build-csharp-sdk: name: Build C# SDK @@ -49,7 +83,7 @@ jobs: run: echo "XAPI_VERSION_NUMBER=$("${{ inputs.xapi_version }}".TrimStart('v'))" | Out-File -FilePath $env:GITHUB_ENV -Encoding utf8 -Append - name: Retrieve C# SDK source - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: SDK_Source_CSharp path: source/ @@ -64,7 +98,7 @@ jobs: --verbosity=normal - name: Store C# SDK - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: SDK_Binaries_CSharp path: source/src/bin/Release/XenServer.NET.${{ env.XAPI_VERSION_NUMBER }}-prerelease-unsigned.nupkg @@ -81,13 +115,13 @@ jobs: 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@v3 + uses: actions/download-artifact@v4 with: name: SDK_Source_PowerShell path: source/ - name: Retrieve C# SDK binaries - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: SDK_Binaries_CSharp path: csharp/ @@ -95,7 +129,7 @@ jobs: # 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@v3 + uses: actions/setup-dotnet@v4 with: dotnet-version: | 6 @@ -135,7 +169,7 @@ jobs: ForEach-Object -Process { Copy-Item -Verbose $_.FullName -Destination "output" } - name: Store PowerShell SDK (.NET Framework 4.5) - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: SDK_Binaries_XenServerPowerShell_NET45 path: output/**/* @@ -155,19 +189,19 @@ jobs: 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@v3 + uses: actions/download-artifact@v4 with: name: SDK_Source_PowerShell path: source/ - name: Retrieve C# SDK binaries - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: SDK_Binaries_CSharp path: csharp/ - name: Set up dotnet CLI (.NET ${{ matrix.dotnet }}) - uses: actions/setup-dotnet@v3 + uses: actions/setup-dotnet@v4 with: dotnet-version: ${{ matrix.dotnet }} @@ -205,7 +239,7 @@ jobs: ForEach-Object -Process { Copy-Item -Verbose $_.FullName -Destination "output" } - name: Store PowerShell SDK (.NET ${{ matrix.dotnet }}) - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: SDK_Binaries_XenServerPowerShell_NET${{ matrix.dotnet }} path: output/**/* diff --git a/.github/workflows/hugo.yml b/.github/workflows/hugo.yml index c76cc3d9487..0b48e6c8a62 100644 --- a/.github/workflows/hugo.yml +++ b/.github/workflows/hugo.yml @@ -11,10 +11,10 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Setup Hugo - uses: peaceiris/actions-hugo@v2 + uses: peaceiris/actions-hugo@v3 with: hugo-version: '0.119.0' @@ -24,7 +24,7 @@ jobs: hugo --minify - name: Deploy - uses: peaceiris/actions-gh-pages@v3 + uses: peaceiris/actions-gh-pages@v4 with: deploy_key: ${{ secrets.ACTIONS_DOCS_DEPLOY_KEY }} publish_dir: ./doc/public diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index da0e2bd35a2..d4bf28aaab2 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -12,115 +12,9 @@ concurrency: # On new push, cancel old workflows from the same PR, branch or tag cancel-in-progress: true jobs: - python-test: - name: Python tests - runs-on: ubuntu-22.04 - strategy: - fail-fast: false - matrix: - python-version: ["2.7", "3.11"] - steps: - - name: Checkout code - uses: actions/checkout@v3 - with: - fetch-depth: 0 # To check which files changed: origin/master..HEAD - - uses: LizardByte/setup-python-action@master - with: - python-version: ${{matrix.python-version}} - - - uses: actions/cache@v3 - name: Setup cache for running pre-commit fast - with: - path: ~/.cache/pre-commit - key: pre-commit|${{ env.pythonLocation }}|${{ hashFiles('.pre-commit-config.yaml') }} - - - run: echo "::add-matcher::.github/workflows/python-warning-matcher.json" - name: "Setup GitHub for reporting Python warnings as annotations in pull request code review" - - - uses: pre-commit/action@v3.0.0 - name: Run pre-commit checks (no spaces at end of lines, etc) - if: ${{ matrix.python-version != '2.7' }} - with: - extra_args: --all-files --verbose --hook-stage commit - env: - SKIP: no-commit-to-branch - - - name: Install dependencies only needed for python 2 - if: ${{ matrix.python-version == '2.7' }} - run: pip install enum - - - name: Install dependencies only needed for python 3 - if: ${{ matrix.python-version != '2.7' }} - run: pip install pandas pytype toml wrapt - - - name: Install common dependencies for Python ${{matrix.python-version}} - run: pip install future mock pytest-coverage pytest-mock - - - name: Run Pytest for python 2 and get code coverage for Codecov - if: ${{ matrix.python-version == '2.7' }} - run: > - pytest - --cov=ocaml/xcp-rrdd - scripts/ ocaml/xcp-rrdd -vv -rA - --junitxml=.git/pytest${{matrix.python-version}}.xml - --cov-report term-missing - --cov-report xml:.git/coverage${{matrix.python-version}}.xml - env: - PYTHONDEVMODE: yes - - - name: Run Pytest for python 3 and get code coverage for Codecov - if: ${{ matrix.python-version != '2.7' }} - run: > - pytest - --cov=python3/ - python3/tests -vv -rA - --junitxml=.git/pytest${{matrix.python-version}}.xml - --cov-report term-missing - --cov-report xml:.git/coverage${{matrix.python-version}}.xml - env: - PYTHONDEVMODE: yes - - - name: Upload Python ${{matrix.python-version}} coverage report to Codecov - uses: codecov/codecov-action@v3 - with: - directory: .git - files: coverage${{matrix.python-version}}.xml - env_vars: OS,PYTHON - fail_ci_if_error: false - flags: python${{matrix.python-version}} - name: coverage${{matrix.python-version}} - verbose: true - - - uses: dciborow/action-pylint@0.1.0 - if: ${{ matrix.python-version != '2.7' }} - with: - reporter: github-pr-review - level: warning - # To be customized to cover remaining Python scripts: - glob_pattern: "**/*.py" - - - name: Run pytype checks - if: ${{ matrix.python-version != '2.7' }} - run: ./pytype_reporter.py - env: - PR_NUMBER: ${{ github.event.number }} - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - PYTYPE_REPORTER_DEBUG: True - - # Try to add pytype_report.py's summary file as a comment to the PR: - # Documentation: https://github.com/marketplace/actions/add-pr-comment - - name: Add the pytype summary as a comment to the PR (if permitted) - uses: mshick/add-pr-comment@v2 - # Depends on pytype checks, which are not run for python 2.7: - if: ${{ matrix.python-version != '2.7' }} - # Fails for user workflows without permissions(fork-based pull requests): - continue-on-error: true - with: - message-path: .git/pytype-summary.md # Add the content of it as comment - ocaml-tests: name: Run OCaml tests - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 env: # Ensure you also update test-sdk-builds # when changing this value, to keep builds @@ -128,7 +22,7 @@ jobs: XAPI_VERSION: "v0.0.0" steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Setup XenAPI environment uses: ./.github/workflows/setup-xapi-environment @@ -156,35 +50,5 @@ jobs: - name: Check disk space run: df -h || true - - name: Cleanup XenAPI environment - uses: ./.github/workflows/cleanup-xapi-environment - - deprecation-test: - name: Deprecation tests - runs-on: ubuntu-20.04 - - steps: - - name: Checkout code - uses: actions/checkout@v3 - - - name: Generate empty configuration for make to be happy - run: touch config.mk - - - name: quality-gate - run: make quality-gate - - - name: pyflakes - uses: reviewdog/action-pyflakes@master - with: - github_token: ${{ secrets.github_token }} - reporter: github-pr-review - level: error - - test-sdk-builds: - name: Test SDK builds - uses: ./.github/workflows/generate-and-build-sdks.yml - with: - # Ensure you also update ocaml-tests - # when changing this value, to keep builds - # consistent - xapi_version: "v0.0.0" + - name: Trim dune cache + run: opam exec -- dune cache trim --size=2GiB diff --git a/.github/workflows/other.yml b/.github/workflows/other.yml new file mode 100644 index 00000000000..7c00b893e4a --- /dev/null +++ b/.github/workflows/other.yml @@ -0,0 +1,112 @@ +name: Build and test (other) + +on: + push: + pull_request: + schedule: + # run daily, this refreshes the cache + - cron: "13 2 * * *" + +concurrency: # On new push, cancel old workflows from the same PR, branch or tag: + group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} + cancel-in-progress: true + +jobs: + python-test: + name: Python tests + runs-on: ubuntu-22.04 + strategy: + fail-fast: false + matrix: + python-version: ["2.7", "3.11"] + steps: + - name: Checkout code + uses: actions/checkout@v4 + with: + fetch-depth: 0 # To check which files changed: origin/master..HEAD + - uses: LizardByte/setup-python-action@master + with: + python-version: ${{matrix.python-version}} + + - uses: actions/cache@v4 + name: Setup cache for running pre-commit fast + with: + path: ~/.cache/pre-commit + key: pre-commit|${{ env.pythonLocation }}|${{ hashFiles('.pre-commit-config.yaml') }} + + - run: echo "::add-matcher::.github/workflows/python-warning-matcher.json" + name: "Setup GitHub for reporting Python warnings as annotations in pull request code review" + + - uses: pre-commit/action@v3.0.1 + name: Run pre-commit checks (no spaces at end of lines, etc) + if: ${{ matrix.python-version != '2.7' }} + with: + extra_args: --all-files --verbose --hook-stage commit + env: + SKIP: no-commit-to-branch + + - name: Run Pytest for python 2 and get code coverage for Codecov + if: ${{ matrix.python-version == '2.7' }} + run: > + pip install enum future mock pytest-coverage pytest-mock && + pytest + --cov=scripts scripts --cov-fail-under 45 -vv -rA + --cov-report term-missing + --cov-report xml:.git/coverage${{matrix.python-version}}.xml + + - name: Upload Python ${{matrix.python-version}} coverage report to Codecov + uses: codecov/codecov-action@v3 + with: + directory: .git + files: coverage${{matrix.python-version}}.xml + env_vars: OS,PYTHON + fail_ci_if_error: false + flags: python${{matrix.python-version}} + name: coverage${{matrix.python-version}} + verbose: true + + - uses: dciborow/action-pylint@0.1.0 + if: ${{ matrix.python-version != '2.7' }} + with: + reporter: github-pr-review + level: warning + # To be customized to cover remaining Python scripts: + glob_pattern: "**/*.py" + continue-on-error: true + + - name: Run pytype checks + if: ${{ matrix.python-version != '2.7' }} + run: pip install pandas pytype toml && ./pytype_reporter.py + env: + PR_NUMBER: ${{ github.event.number }} + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + PYTYPE_REPORTER_DEBUG: True + + - name: pyflakes + uses: reviewdog/action-pyflakes@v1 + with: + github_token: ${{ secrets.github_token }} + continue-on-error: true + + deprecation-test: + name: Deprecation tests + runs-on: ubuntu-22.04 + + steps: + - name: Checkout code + uses: actions/checkout@v4 + + - name: Generate empty configuration for make to be happy + run: touch config.mk + + - name: quality-gate + run: make quality-gate + + test-sdk-builds: + name: Test SDK builds + uses: ./.github/workflows/generate-and-build-sdks.yml + with: + # Ensure you also update ocaml-tests + # when changing this value, to keep builds + # consistent + xapi_version: "v0.0.0" diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 9045949aea2..1c3dca70fcd 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -12,10 +12,10 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Use python - uses: actions/setup-python@v4 + uses: actions/setup-python@v5 with: python-version: "3.x" @@ -30,7 +30,7 @@ jobs: make python - name: Store python distribution artifacts - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: XenAPI path: scripts/examples/python/dist/ @@ -47,33 +47,48 @@ jobs: needs: [build-python, build-sdks] steps: - name: Retrieve Python SDK distribution artifacts - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: XenAPI path: dist/ + - name: Retrieve C SDK distribution binaries + uses: actions/download-artifact@v4 + with: + name: SDK_Artifacts_C + path: libxenserver/usr/local/ + - name: Retrieve C# SDK distribution artifacts - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: SDK_Binaries_CSharp path: dist/ - name: Retrieve PowerShell 5.x SDK distribution artifacts - uses: actions/download-artifact@v3 + 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@v3 + uses: actions/download-artifact@v4 with: name: SDK_Binaries_XenServerPowerShell_NET6 path: sdk_powershell_7x/ + - name: Package C SDK artifacts for deployment + shell: bash + run: | + mkdir -p libxenserver/usr/local/lib + mv libxenserver/usr/local/libxenserver.* libxenserver/usr/local/lib/ + tar -zcvf libxenserver-prerelease.tar.gz -C ./libxenserver usr/local/lib/ usr/local/include/xen/api + 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 @@ -83,7 +98,8 @@ jobs: 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 + PowerShell-SDK-7.x-prerelease-unsigned.zip \ + libxenserver-prerelease.tar.gz libxenserver-prerelease.src.tar.gz env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} @@ -96,7 +112,7 @@ jobs: id-token: write steps: - name: Retrieve python distribution artifacts - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: XenAPI path: dist/ diff --git a/.github/workflows/setup-xapi-environment/action.yml b/.github/workflows/setup-xapi-environment/action.yml index 702162d42f3..d46ae3a5b96 100644 --- a/.github/workflows/setup-xapi-environment/action.yml +++ b/.github/workflows/setup-xapi-environment/action.yml @@ -8,10 +8,6 @@ inputs: runs: using: "composite" steps: - - name: Free space - shell: bash - run: sudo rm -rf /usr/local/lib/android - - name: Pull configuration from xs-opam shell: bash run: | @@ -25,12 +21,16 @@ runs: - name: Load environment file id: dotenv - uses: falti/dotenv-action@v1.0.4 + uses: falti/dotenv-action@v1 - name: Update Ubuntu repositories shell: bash run: sudo apt-get update + - name: Install python2 + shell: bash + run: sudo apt-get install python2 + - name: Use disk with more space for TMPDIR and XDG_CACHE_HOME shell: bash run: | @@ -42,13 +42,18 @@ runs: echo "TMPDIR=${TMPDIR}" >>"$GITHUB_ENV" echo "XDG_CACHE_HOME=${XDG_CACHE_HOME}" >>"$GITHUB_ENV" + # We set DUNE_CACHE_STORAGE_MODE, it is required for dune cache to work inside opam for now, + # otherwise it gets EXDEV and considers it a cache miss - name: Use ocaml uses: ocaml/setup-ocaml@v2 with: ocaml-compiler: ${{ steps.dotenv.outputs.ocaml_version_full }} opam-repositories: | xs-opam: ${{ steps.dotenv.outputs.repository }} + opam-pin: false dune-cache: true + env: + DUNE_CACHE_STORAGE_MODE: copy - name: Install dependencies shell: bash diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 0ca5ef37fee..668b4190ce1 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -14,6 +14,8 @@ # pre-commit run -av --hook-stage pre-push # default_stages: [commit, push] +default_language_version: + python: python3.11 repos: # Recommendation for a minimal git pre-commit hook: # https://github.com/pre-commit/pre-commit-hooks/blob/main/README.md: @@ -29,6 +31,95 @@ repos: - id: check-executables-have-shebangs exclude: ocaml + +# Improve Python formatting incrementally: +# https://dev.to/akaihola/improving-python-code-incrementally-3f7a +# +# darker checks if staged python changes are formatted according using +# the PEP8-aligned black formatter. It also checks if the imports are sorted. +# +# It is a good idea to run this before committing, and it is also run in the +# GitHub Workflow. +# +# Note: darker only checks the changes in files ending in .py! +# Python scripts that don't end in .py should be renamed to have the .py extension +# when moving them to python3/bin. +# (remove the .py extension in the Makefile when installing the file) +# +- repo: https://github.com/akaihola/darker + rev: 1.7.3 + hooks: + - id: darker + files: python3/ + name: check changes in Python3 tree using darker and isort + args: [--diff, --skip-string-normalization, --isort, -tpy36] + additional_dependencies: [isort] + +# +# Run pytest and diff-cover to check that the new /python3 test suite in passes. +# This hook uses a local venv containing the required dependencies. When adding +# new dependencies, they should be added to the additional_dependencies below. +# +- repo: local + hooks: + - id: pytest + files: python3/ + name: check that the Python3 test suite in passes + entry: env PYTHONDEVMODE=yes sh -c 'python3 -m pytest -vv && + diff-cover --ignore-whitespace --compare-branch=origin/feature/py3 + --show-uncovered --html-report .git/coverage-diff.html + --fail-under 50 .git/coverage3.11.xml' + require_serial: true + pass_filenames: false + language: python + types: [python] + additional_dependencies: + - coverage + - diff-cover + - future + - opentelemetry-api + - opentelemetry-exporter-zipkin-json + - opentelemetry-sdk + - pytest-coverage + - pytest-mock + - mock + - wrapt + - XenAPI + + +- repo: https://github.com/RobertCraigie/pyright-python + rev: v1.1.361 + hooks: + - id: pyright + name: check that python3 tree passes pyright/VSCode check + files: python3/ + additional_dependencies: + - mock + - opentelemetry-api + - opentelemetry-exporter-zipkin-json + - opentelemetry-sdk + - pytest + - pyudev + - XenAPI + + +# Check that pylint passes for the changes in new /python3 code. +- repo: local + hooks: + - id: pylint + files: python3/ + stages: [push] + name: check that changes to python3 tree pass pylint + entry: diff-quality --violations=pylint + --ignore-whitespace --compare-branch=origin/feature/py3 + pass_filenames: false + language: python + types: [python] + additional_dependencies: [diff-cover, pylint, pytest] + + +# pre-push hook (it only runs if you install pre-commit as a pre-push hook): +# It can be manually tested using: `pre-commit run -av --hook-stage push` # Recommendation for a minimal git pre-push hook: # While using pre-commit yields great results, it # is "not fast". Therefore only run it pre-push, @@ -53,4 +144,12 @@ repos: # developers have such version installed, it can be configured here: # language_version: python3.11 require_serial: true - additional_dependencies: [pandas, pytype] + additional_dependencies: + - future + - opentelemetry-api + - opentelemetry-exporter-zipkin-json + - opentelemetry-sdk + - pandas + - pytest + - pytype + files: python3/ diff --git a/Makefile b/Makefile index f272cd8e766..38c7545cc83 100644 --- a/Makefile +++ b/Makefile @@ -74,15 +74,20 @@ schema: dune runtest ocaml/idl doc: - dune build --profile=$(PROFILE) ocaml/idl/datamodel_main.exe +#html dune build --profile=$(PROFILE) -f @ocaml/doc/jsapigen mkdir -p $(XAPIDOC)/html cp -r _build/default/ocaml/doc/api $(XAPIDOC)/html cp _build/default/ocaml/doc/branding.js $(XAPIDOC)/html cp ocaml/doc/*.js ocaml/doc/*.html ocaml/doc/*.css $(XAPIDOC)/html - dune exec --profile=$(PROFILE) -- ocaml/idl/datamodel_main.exe -closed -markdown $(XAPIDOC)/markdown - cp ocaml/doc/*.dot ocaml/doc/doc-convert.sh $(XAPIDOC) +#markdown + dune build --profile=$(PROFILE) -f @ocaml/idl/markdowngen + mkdir -p $(XAPIDOC)/markdown + cp -r _build/default/ocaml/idl/autogen/*.md $(XAPIDOC)/markdown + cp -r _build/default/ocaml/idl/autogen/*.yml $(XAPIDOC)/markdown find ocaml/doc -name "*.md" -not -name "README.md" -exec cp {} $(XAPIDOC)/markdown/ \; +#other + cp ocaml/doc/*.dot ocaml/doc/doc-convert.sh $(XAPIDOC) # Build manpages, networkd generated these dune build --profile=$(PROFILE) -f @man @@ -112,6 +117,11 @@ sdk: sh ocaml/sdk-gen/windows-line-endings.sh $(XAPISDK)/csharp sh ocaml/sdk-gen/windows-line-endings.sh $(XAPISDK)/powershell +.PHONY: sdk-build-c + +sdk-build-c: sdk + cd _build/install/default/xapi/sdk/c && make clean && make -j $(JOBS) + .PHONY: sdk-build-java sdk-build-java: sdk @@ -243,9 +253,9 @@ install: build doc sdk doc-json gzip http-lib pciutil sexpr stunnel uuid xml-light2 zstd xapi-compression safe-resources \ message-switch message-switch-async message-switch-cli message-switch-core message-switch-lwt \ message-switch-unix xapi-idl forkexec xapi-forkexecd xapi-storage xapi-storage-script xapi-storage-cli \ - xapi-nbd varstored-guard xapi-log xapi-open-uri xapi-tracing xapi-expiry-alerts cohttp-posix \ + xapi-nbd varstored-guard xapi-log xapi-open-uri xapi-tracing xapi-tracing-export xapi-expiry-alerts cohttp-posix \ xapi-rrd xapi-inventory \ - xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-stdext + xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck # docs mkdir -p $(DESTDIR)$(DOCDIR) cp -r $(XAPIDOC)/jekyll $(DESTDIR)$(DOCDIR) @@ -265,9 +275,9 @@ uninstall: gzip http-lib pciutil sexpr stunnel uuid xml-light2 zstd xapi-compression safe-resources \ message-switch message-switch-async message-switch-cli message-switch-core message-switch-lwt \ message-switch-unix xapi-idl forkexec xapi-forkexecd xapi-storage xapi-storage-script xapi-log \ - xapi-open-uri xapi-tracing xapi-expiry-alerts cohttp-posix \ + xapi-open-uri xapi-tracing xapi-tracing-export xapi-expiry-alerts cohttp-posix \ xapi-rrd xapi-inventory \ - xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-stdext + xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck compile_flags.txt: Makefile (ocamlc -config-var ocamlc_cflags;\ diff --git a/README.markdown b/README.markdown index a4272105d1b..37174144a3e 100644 --- a/README.markdown +++ b/README.markdown @@ -4,7 +4,7 @@ Xapi Project's XenAPI Management Toolstack ![Build](https://github.com/xapi-project/xen-api/actions/workflows/main.yml/badge.svg?branch=master) Xen API (or xapi) is a management stack that configures and controls -Xen-enabled hosts and resource pools, and co-ordinates resources +Xen-enabled hosts and resource pools, and coordinates resources within the pool. Xapi exposes the Xen API interface for many languages and is a component of the XenServer project. Xen API is written mostly in [OCaml](http://caml.inria.fr/ocaml/) @@ -16,31 +16,31 @@ Xapi is the main component produced by the Linux Foundation's Build and Install ----------------- -To build xen-api from source, we recommend using [opam](https://opam.ocaml.org/doc/Manual.html) with the [xs-opam](https://github.com/xapi-project/xs-opam) repository (farther explanation in its [readme](https://github.com/xapi-project/xs-opam/blob/master/README.md)). +To build xen-api from source, we recommend using [opam](https://opam.ocaml.org/doc/Manual.html) with the [xs-opam](https://github.com/xapi-project/xs-opam) repository (further explanation in its [readme](https://github.com/xapi-project/xs-opam/blob/master/README.md)). 1) Install `opam` and `git` with your package manager. -2) Clone this repo, and work from it's root. +2) Clone this repo and work from its root. ```bash git clone https://github.com/xapi-project/xen-api && cd xen-api ``` -3) Figure out what version of ocaml-base-compiler to use. +3) Figure out which version of ocaml-base-compiler to use. - - Go to [this xs-opam file](https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env), and look for "OCAML_VERSION_FULL" - - Run that line, i.e: + - Go to [this xs-opam file](https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env), and look for `OCAML_VERSION_FULL`. + - Run that line, e.g.: ```bash - export OCAML_VERSION_FULL="4.10.1" + export OCAML_VERSION_FULL="4.14.1" ``` -4) Setup opam, with your Enviornment (i.e switch). +4) Setup opam with your environment (i.e. switch). ```bash opam init opam switch create xen-api ocaml-base-compiler.$OCAML_VERSION_FULL - # This basically "jumps you into" the enviornment you just created: + # This basically "jumps you into" the environment you just created: eval $(opam env --switch=xen-api --set-switch) ``` @@ -58,12 +58,7 @@ To build xen-api from source, we recommend using [opam](https://opam.ocaml.org/d 6) Install all the Packages. ```bash - PACKAGES="xapi-cli-protocol xapi-client xapi-consts xapi-datamodel xapi-types xapi xe xen-api-sdk xen-api-client xen-api-client-lwt xen-api-client-async xapi-rrdd xapi-rrdd-plugin xapi-rrd-transport xapi-rrd-transport-utils rrd-transport rrdd-plugin rrdd-plugins rrddump gzip http-lib pciutil safe-resources sexpr stunnel uuid xapi-compression xml-light2 zstd vhd-tool xs-toolstack" - - # NOT needed with opam>=2.1.0) Install all the dependencies (Including OS): - opam --yes depext --yes -u $PACKAGES # The first '--yes' is to install depext itself - # Install the Packages finally: - opam install $PACKAGES --yes --deps-only --with-test -v + opam install xs-toolstack # Update the current switch. (You're already on the correct one, just refresh it). eval $(opam env) ``` @@ -78,6 +73,29 @@ To build xen-api from source, we recommend using [opam](https://opam.ocaml.org/d The binaries should now be in `./_build/install/default/bin`! +Working From a Fork +------------------- +If you are working from within a clone of a fork of this repository, you will +need tags from the upstream repository in order to produce a build with the +correct versioning string. + +To fetch these tags, you must ensure that this repository is known to `git` (as a +remote, often called `upstream`) and then you can fetch the tags as follows: + +```bash +git remote add upstream https://github.com/xapi-project/xen-api +git fetch upstream --tags +``` + +You can check if this has been successful by invoking `git describe`. + +You can then push these tags to your remote repository to ensure they are cloned +in future: + +```bash +git push origin --tags +``` + Contributions ------------- diff --git a/dune-project b/dune-project index 747fc62b133..0d402cd7a9d 100644 --- a/dune-project +++ b/dune-project @@ -3,6 +3,7 @@ (generate_opam_files true) +(name "xapi") (source (github xapi-project/xen-api)) (license "LGPL-2.1-only WITH OCaml-LGPL-linking-exception") (authors "xen-api@lists.xen.org") @@ -66,6 +67,10 @@ (name xapi-tracing) ) +(package + (name xapi-tracing-export) +) + (package (name xapi-storage-script) ) @@ -262,21 +267,6 @@ (name xapi-inventory) ) -(package - (name xapi-stdext) - (synopsis "Xapi's standard library extension") - (description "Dummy package that enables the usage of dune-release") - (depends - (xapi-stdext-date (= :version)) - (xapi-stdext-encodings (= :version)) - (xapi-stdext-pervasives (= :version)) - (xapi-stdext-std (= :version)) - (xapi-stdext-threads (= :version)) - (xapi-stdext-unix (= :version)) - (xapi-stdext-zerocheck (= :version)) - ) -) - (package (name xapi-stdext-date) (synopsis "Xapi's standard library extension, Dates") diff --git a/forkexec.opam b/forkexec.opam index c458ac94713..a3296ea9771 100644 --- a/forkexec.opam +++ b/forkexec.opam @@ -21,6 +21,7 @@ depends: [ "xapi-log" "xapi-stdext-pervasives" "xapi-stdext-unix" + "xapi-tracing" ] synopsis: "Sub-process control service for xapi" description: diff --git a/forkexec.opam.template b/forkexec.opam.template index 6e9cd4df453..cf537533421 100644 --- a/forkexec.opam.template +++ b/forkexec.opam.template @@ -19,6 +19,7 @@ depends: [ "xapi-log" "xapi-stdext-pervasives" "xapi-stdext-unix" + "xapi-tracing" ] synopsis: "Sub-process control service for xapi" description: diff --git a/message-switch-core.opam b/message-switch-core.opam index 960934bea54..44e2983cc5b 100644 --- a/message-switch-core.opam +++ b/message-switch-core.opam @@ -22,6 +22,7 @@ depends: [ "ppx_sexp_conv" "rpclib" "sexplib" + "xapi-log" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/message-switch-core.opam.template b/message-switch-core.opam.template index 7ec11e91dc3..7f65fa07598 100644 --- a/message-switch-core.opam.template +++ b/message-switch-core.opam.template @@ -20,6 +20,7 @@ depends: [ "ppx_sexp_conv" "rpclib" "sexplib" + "xapi-log" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/ocaml/database/block_device_io.ml b/ocaml/database/block_device_io.ml index 3d4e10288b4..7587a34d5d5 100644 --- a/ocaml/database/block_device_io.ml +++ b/ocaml/database/block_device_io.ml @@ -90,6 +90,8 @@ open Xapi_stdext_pervasives.Pervasiveext open Xapi_stdext_unix +module Db_globs = Xapi_database.Db_globs +module Block_device_io_errors = Xapi_database.Block_device_io_errors let name = "block_device_io" diff --git a/ocaml/database/database_server_main.ml b/ocaml/database/database_server_main.ml index 4809bc7fd16..1dc59284263 100644 --- a/ocaml/database/database_server_main.ml +++ b/ocaml/database/database_server_main.ml @@ -17,7 +17,7 @@ let c = Condition.create () (** Handler for the remote database access URL *) let remote_database_access_handler_v1 req bio = - try Db_remote_cache_access_v1.handler req bio + try Xapi_database.Db_remote_cache_access_v1.handler req bio with e -> Printf.printf "Caught: %s\n" (Printexc.to_string e) ; Printexc.print_backtrace stdout ; @@ -26,14 +26,15 @@ let remote_database_access_handler_v1 req bio = (** Handler for the remote database access URL *) let remote_database_access_handler_v2 req bio = - try Db_remote_cache_access_v2.handler req bio + try Xapi_database.Db_remote_cache_access_v2.handler req bio with e -> Printf.printf "Caught: %s\n" (Printexc.to_string e) ; Printexc.print_backtrace stdout ; flush stdout ; raise e -module Local_tests = Database_test.Tests (Db_cache_impl) +module Local_tests = + Xapi_database.Database_test.Tests (Xapi_database.Db_cache_impl) let schema = Test_schemas.schema @@ -67,6 +68,7 @@ let _ = | Slave _ -> failwith "unimplemented" | Master db_filename -> + let open Xapi_database in Printf.printf "Database path: %s\n%!" db_filename ; let db = Parse_db_conf.make db_filename in Db_conn_store.initialise_db_connections [db] ; diff --git a/ocaml/database/db_cache_test.ml b/ocaml/database/db_cache_test.ml index 7fd7b0a5006..ed2a3296940 100644 --- a/ocaml/database/db_cache_test.ml +++ b/ocaml/database/db_cache_test.ml @@ -12,7 +12,8 @@ * GNU Lesser General Public License for more details. *) -open Db_cache_types +open Xapi_database +open Xapi_database.Db_cache_types let create_test_db () = let schema = Test_schemas.many_to_many in diff --git a/ocaml/database/dune b/ocaml/database/dune index 0b0c71425ff..e135f3d7e63 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -21,6 +21,7 @@ (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 @@ -48,7 +49,6 @@ xml-light2 xmlm ) - (wrapped false) (preprocess (pps ppx_deriving_rpc)) ) diff --git a/ocaml/database/unit_test_marshall.ml b/ocaml/database/unit_test_marshall.ml index c751646097c..a9a77a11560 100644 --- a/ocaml/database/unit_test_marshall.ml +++ b/ocaml/database/unit_test_marshall.ml @@ -11,9 +11,9 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -open Db_rpc_common_v1 -open Db_cache_types -open Db_filter_types +open Xapi_database.Db_rpc_common_v1 +open Xapi_database.Db_cache_types +open Xapi_database.Db_filter_types (* Check, for randomly chosen x's, that (unmarshall (marshall x)) = x *) diff --git a/ocaml/db_process/xapi_db_process.ml b/ocaml/db_process/xapi_db_process.ml index 633e2c14e30..fe5e509645e 100644 --- a/ocaml/db_process/xapi_db_process.ml +++ b/ocaml/db_process/xapi_db_process.ml @@ -14,7 +14,8 @@ module D = Debug.Make (struct let name = "xapi-db-process" end) open D -open Db_cache_types +open Xapi_database +open Xapi_database.Db_cache_types let compress = ref false diff --git a/ocaml/doc/basics.md b/ocaml/doc/basics.md index f659a795a14..783797051f0 100644 --- a/ocaml/doc/basics.md +++ b/ocaml/doc/basics.md @@ -1,12 +1,12 @@ # API Basics This document defines the XenServer Management API - an interface for remotely -configuring and controlling virtualised guests running on a Xen-enabled host. +configuring and controlling virtualized guests running on a Xen-enabled host. The API is presented here as a set of Remote Procedure Calls (RPCs). There are two supported wire formats, one based upon [XML-RPC](http://xmlrpc.scripting.com/spec.html) and one based upon [JSON-RPC](http://www.jsonrpc.org) (v1.0 and v2.0 are both -recognised). No specific language bindings are prescribed, although examples +recognized). No specific language bindings are prescribed, although examples will be given in the python programming language. Although we adopt some terminology from object-oriented programming, diff --git a/ocaml/doc/wire-protocol.md b/ocaml/doc/wire-protocol.md index 260039ab495..20e39627cc3 100644 --- a/ocaml/doc/wire-protocol.md +++ b/ocaml/doc/wire-protocol.md @@ -178,7 +178,7 @@ following manner: * our `void` type is transmitted as an empty string. -Both versions 1.0 and 2.0 of the JSON-RPC wire format are recognised and, +Both versions 1.0 and 2.0 of the JSON-RPC wire format are recognized and, depending on your client library, you can use either of them. ### JSON-RPC v1.0 @@ -486,7 +486,7 @@ session reference is returned under the key `Value` in the resulting dictionary ... "version", "originator")['Value'] ``` -This is what the call looks like when serialised +This is what the call looks like when serialized ```xml @@ -530,7 +530,7 @@ Once a reference to a VM has been acquired, a lifecycle operation may be invoked In this case the `start` message has been rejected, because the VM is a template, and so an error response has been returned. These high-level errors are returned as structured data (rather than as XML-RPC faults), -allowing them to be internationalised. +allowing them to be internationalized. Rather than querying fields individually, whole _records_ may be returned at once. To retrieve the record of a single object as a python dictionary: @@ -575,7 +575,7 @@ reference: ... "user", "passwd", "version", "originator") ``` -`pyjsonrpc` uses the JSON-RPC protocol v2.0, so this is what the serialised +`pyjsonrpc` uses the JSON-RPC protocol v2.0, so this is what the serialized request looks like: ```json @@ -623,7 +623,7 @@ Once a reference to a VM has been acquired, a lifecycle operation may be invoked In this case the `start` message has been rejected because the VM is a template, hence an error response has been returned. These high-level -errors are returned as structured data, allowing them to be internationalised. +errors are returned as structured data, allowing them to be internationalized. Rather than querying fields individually, whole _records_ may be returned at once. To retrieve the record of a single object as a python dictionary: diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index 3ed1d4eb891..3d132e8ed76 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -12,6 +12,7 @@ xapi-log xapi-stdext-pervasives xapi-stdext-unix + xapi-tracing ) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/forkexecd/lib/fe.ml b/ocaml/forkexecd/lib/fe.ml index bbad59dbfd2..c928cd3fc10 100644 --- a/ocaml/forkexecd/lib/fe.ml +++ b/ocaml/forkexecd/lib/fe.ml @@ -1,13 +1,13 @@ (* Disable "Warning 39: unused rec flag." caused by rpc *) [@@@warning "-39"] -type syslog_stdout_t = {enabled: bool; key: string option} [@@deriving rpc] +type syslog_stdout = {enabled: bool; key: string option} [@@deriving rpc] type setup_cmd = { cmdargs: string list ; env: string list ; id_to_fd_map: (string * int option) list - ; syslog_stdout: syslog_stdout_t + ; syslog_stdout: syslog_stdout ; redirect_stderr_to_stdout: bool } [@@deriving rpc] @@ -20,11 +20,9 @@ type process_result = WEXITED of int | WSIGNALED of int | WSTOPPED of int type ferpc = | Setup of setup_cmd | Setup_response of setup_response - | Cancel | Exec | Execed of int | Finished of process_result - | Log_reopen | Dontwaitpid [@@deriving rpc] diff --git a/ocaml/forkexecd/lib/fecomms.ml b/ocaml/forkexecd/lib/fecomms.ml index cc34a3c09f5..ee7c92fb7c6 100644 --- a/ocaml/forkexecd/lib/fecomms.ml +++ b/ocaml/forkexecd/lib/fecomms.ml @@ -1,25 +1,40 @@ module Unixext = Xapi_stdext_unix.Unixext -let open_unix_domain_sock () = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 +let update_ferpc_env tracing (ferpc : Fe.ferpc) : Fe.ferpc = + match ferpc with + | Setup setup_cmd -> + let env = setup_cmd.env @ Tracing.EnvHelpers.of_span tracing in + Setup {setup_cmd with env} + | Setup_response _ | Exec | Execed _ | Finished _ | Dontwaitpid -> + ferpc -let open_unix_domain_sock_server path = +let with_tracing ~tracing ~name f = Tracing.with_tracing ~parent:tracing ~name f + +let open_unix_domain_sock ?tracing () = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun _ -> + Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 + +let open_unix_domain_sock_server ?tracing path = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> Unixext.mkdir_rec (Filename.dirname path) 0o755 ; Unixext.unlink_safe path ; - let sock = open_unix_domain_sock () in + let sock = open_unix_domain_sock ?tracing () in try Unix.bind sock (Unix.ADDR_UNIX path) ; Unix.listen sock 5 ; sock with e -> Unix.close sock ; raise e -let open_unix_domain_sock_client path = - let sock = open_unix_domain_sock () in +let open_unix_domain_sock_client ?tracing path = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> + let sock = open_unix_domain_sock ?tracing () in try Unix.connect sock (Unix.ADDR_UNIX path) ; sock with e -> Unix.close sock ; raise e -let read_raw_rpc sock = +let read_raw_rpc ?tracing sock = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun _ -> let buffer = Bytes.make 12 '\000' in Unixext.really_read sock buffer 0 12 ; let header = Bytes.unsafe_to_string buffer in @@ -31,7 +46,9 @@ let read_raw_rpc sock = Unix.(shutdown sock SHUTDOWN_ALL) ; Error ("Header is not an integer: " ^ header) -let write_raw_rpc sock ferpc = +let write_raw_rpc ?tracing sock ferpc = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> + let ferpc = update_ferpc_env tracing ferpc in let body = Jsonrpc.to_string (Fe.rpc_of_ferpc ferpc) in let len = String.length body in let buffer = Printf.sprintf "%012d%s" len body in @@ -39,12 +56,14 @@ let write_raw_rpc sock ferpc = exception Connection_closed -let receive_named_fd sock = +let receive_named_fd ?tracing sock = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun _ -> let buffer = Bytes.make 36 '\000' in let len, _from, newfd = Unixext.recv_fd sock buffer 0 36 [] in let buffer = Bytes.unsafe_to_string buffer in if len = 0 then raise Connection_closed ; (newfd, buffer) -let send_named_fd sock uuid fd = +let send_named_fd ?tracing sock uuid fd = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun _ -> ignore (Unixext.send_fd_substring sock uuid 0 (String.length uuid) [] fd) diff --git a/ocaml/forkexecd/lib/forkhelpers.ml b/ocaml/forkexecd/lib/forkhelpers.ml index d55901c3c68..c3ce2133dc0 100644 --- a/ocaml/forkexecd/lib/forkhelpers.ml +++ b/ocaml/forkexecd/lib/forkhelpers.ml @@ -21,6 +21,8 @@ (* XXX: this is a work in progress *) +module D = Debug.Make (struct let name = __MODULE__ end) + let default_path = ["/sbin"; "/usr/sbin"; "/bin"; "/usr/bin"] let default_path_env_pair = [|"PATH=" ^ String.concat ":" default_path|] @@ -34,6 +36,8 @@ let test_path = let runtime_path = Option.value ~default:"/var" test_path +let with_tracing ~tracing ~name f = Tracing.with_tracing ~parent:tracing ~name f + let finally = Xapi_stdext_pervasives.Pervasiveext.finally type pidty = Unix.file_descr * int @@ -72,14 +76,47 @@ let waitpid (sock, pid) = in failwith msg -let waitpid_nohang ((sock, _) as x) = +(* [waitpid_nohang] reports the status of a socket to a process. The + intention is to make this non-blocking. If the process is finished, + the socket is closed and not otherwise. *) +let waitpid_nohang (sock, pid) = + let verbose = false in + if verbose then D.debug "%s pid=%d" __FUNCTION__ pid ; + let fail fmt = Printf.kprintf failwith fmt in Unix.set_nonblock sock ; - let r = - try waitpid x - with Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> - (0, Unix.WEXITED 0) - in - Unix.clear_nonblock sock ; r + match Fecomms.read_raw_rpc sock with + | Ok Fe.(Finished (WEXITED n)) -> + if verbose then D.debug "%s pid=%d WEXITED" __FUNCTION__ pid ; + Unix.close sock ; + (pid, Unix.WEXITED n) + | Ok Fe.(Finished (WSIGNALED n)) -> + if verbose then D.debug "%s pid=%d WSIGNALED" __FUNCTION__ pid ; + Unix.close sock ; + (pid, Unix.WSIGNALED n) + | Ok Fe.(Finished (WSTOPPED n)) -> + if verbose then D.debug "%s pid=%d WSTOPPED" __FUNCTION__ pid ; + Unix.close sock ; + (pid, Unix.WSTOPPED n) + | Ok status -> + Unix.clear_nonblock sock ; + fail "%s: unexpected status received (%s)" __FUNCTION__ + (Fe.ferpc_to_string status) + | Error msg -> + D.debug "%s pid=%d %s" __FUNCTION__ pid msg ; + Unix.clear_nonblock sock ; + fail "%s: error happened when trying to read the status. %s" __FUNCTION__ + msg + (* it's a bit crazy that we have Result.t and exceptions from + read_raw_rpc *) + | exception Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> + if verbose then D.debug "%s pid=%d EAGAIN EWOULDBLOCK" __FUNCTION__ pid ; + Unix.clear_nonblock sock ; + (0, Unix.WEXITED 0) (* this a convention, see MLI *) + | exception exn -> + D.debug "%s pid=%d %s" __FUNCTION__ pid (Printexc.to_string exn) ; + Unix.clear_nonblock sock ; + fail "%s: error happened when trying to read the status. %s" __FUNCTION__ + (Printexc.to_string exn) let dontwaitpid (sock, _pid) = ( try @@ -107,7 +144,8 @@ let getpid (_sock, pid) = pid type 'a result = Success of string * 'a | Failure of string * exn -let temp_dir_server = runtime_path ^ "/run/nonpersistent/forkexecd/" +let temp_dir_server = + Filename.concat runtime_path "/run/nonpersistent/forkexecd/" let temp_dir = try @@ -136,18 +174,20 @@ let with_logfile_fd ?(delete = true) prefix f = exception Spawn_internal_error of string * string * Unix.process_status -type syslog_stdout_t = +type syslog_stdout = | NoSyslogging | Syslog_DefaultKey | Syslog_WithKey of string (** Safe function which forks a command, closing all fds except a whitelist and having performed some fd operations in the child *) -let safe_close_and_exec ?env stdin stdout stderr +let safe_close_and_exec ?tracing ?env stdin stdout stderr (fds : (string * Unix.file_descr) list) ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) (cmd : string) (args : string list) = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> let sock = - Fecomms.open_unix_domain_sock_client (runtime_path ^ "/xapi/forker/main") + Fecomms.open_unix_domain_sock_client ?tracing + (Filename.concat runtime_path "/xapi/forker/main") in let stdinuuid = Uuidx.(to_string (make ())) in let stdoutuuid = Uuidx.(to_string (make ())) in @@ -194,7 +234,7 @@ let safe_close_and_exec ?env stdin stdout stderr | Syslog_WithKey k -> {Fe.enabled= true; Fe.key= Some k} in - Fecomms.write_raw_rpc sock + Fecomms.write_raw_rpc ?tracing sock (Fe.Setup { Fe.cmdargs= cmd :: args @@ -205,7 +245,7 @@ let safe_close_and_exec ?env stdin stdout stderr } ) ; - let response = Fecomms.read_raw_rpc sock in + let response = Fecomms.read_raw_rpc ?tracing sock in let s = match response with @@ -228,10 +268,14 @@ let safe_close_and_exec ?env stdin stdout stderr failwith msg in - let fd_sock = Fecomms.open_unix_domain_sock_client s.Fe.fd_sock_path in + let fd_sock = + Fecomms.open_unix_domain_sock_client ?tracing s.Fe.fd_sock_path + in add_fd_to_close_list fd_sock ; - let send_named_fd uuid fd = Fecomms.send_named_fd fd_sock uuid fd in + let send_named_fd uuid fd = + Fecomms.send_named_fd ?tracing fd_sock uuid fd + in List.iter (fun (uuid, _, srcfdo) -> @@ -243,8 +287,8 @@ let safe_close_and_exec ?env stdin stdout stderr ) predefined_fds ; List.iter (fun (uuid, srcfd) -> send_named_fd uuid srcfd) fds ; - Fecomms.write_raw_rpc sock Fe.Exec ; - match Fecomms.read_raw_rpc sock with + Fecomms.write_raw_rpc ?tracing sock Fe.Exec ; + match Fecomms.read_raw_rpc ?tracing sock with | Ok (Fe.Execed pid) -> (sock, pid) | Ok status -> @@ -265,8 +309,9 @@ let safe_close_and_exec ?env stdin stdout stderr ) close_fds -let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout = NoSyslogging) - ?(redirect_stderr_to_stdout = false) ?(timeout = -1.0) cmd args = +let execute_command_get_output_inner ?tracing ?env ?stdin + ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) + ?(timeout = -1.0) cmd args = let to_close = ref [] in let close fd = if List.mem fd !to_close then ( @@ -286,10 +331,14 @@ let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout = NoSyslogging) finally (fun () -> match + with_tracing ~tracing ~name:"Forkhelpers.with_logfile_out_fd" + @@ fun tracing -> with_logfile_fd "execute_command_get_out" (fun out_fd -> + with_tracing ~tracing ~name:"Forkhelpers.with_logfile_err_fd" + @@ fun tracing -> with_logfile_fd "execute_command_get_err" (fun err_fd -> let sock, pid = - safe_close_and_exec ?env + safe_close_and_exec ?tracing ?env (Option.map (fun (_, fd, _) -> fd) stdinandpipes) (Some out_fd) (Some err_fd) [] ~syslog_stdout ~redirect_stderr_to_stdout cmd args @@ -302,6 +351,7 @@ let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout = NoSyslogging) stdinandpipes ; if timeout > 0. then Unix.setsockopt_float sock Unix.SO_RCVTIMEO timeout ; + with_tracing ~tracing ~name:"Forkhelpers.waitpid" @@ fun _ -> try waitpid (sock, pid) with Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> Unix.kill pid Sys.sigkill ; @@ -322,12 +372,15 @@ let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout = NoSyslogging) ) (fun () -> List.iter Unix.close !to_close) -let execute_command_get_output ?env ?(syslog_stdout = NoSyslogging) +let execute_command_get_output ?tracing ?env ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) ?timeout cmd args = - execute_command_get_output_inner ?env ?stdin:None ?timeout ~syslog_stdout - ~redirect_stderr_to_stdout cmd args - -let execute_command_get_output_send_stdin ?env ?(syslog_stdout = NoSyslogging) - ?(redirect_stderr_to_stdout = false) ?timeout cmd args stdin = - execute_command_get_output_inner ?env ~stdin ~syslog_stdout + with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> + execute_command_get_output_inner ?tracing ?env ?stdin:None ?timeout + ~syslog_stdout ~redirect_stderr_to_stdout cmd args + +let execute_command_get_output_send_stdin ?tracing ?env + ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) + ?timeout cmd args stdin = + with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> + execute_command_get_output_inner ?tracing ?env ~stdin ~syslog_stdout ~redirect_stderr_to_stdout ?timeout cmd args diff --git a/ocaml/forkexecd/lib/forkhelpers.mli b/ocaml/forkexecd/lib/forkhelpers.mli index 6252f0e75ca..a91afa52a87 100644 --- a/ocaml/forkexecd/lib/forkhelpers.mli +++ b/ocaml/forkexecd/lib/forkhelpers.mli @@ -34,7 +34,7 @@ (** {2 High-level interface } *) -type syslog_stdout_t = +type syslog_stdout = | NoSyslogging | Syslog_DefaultKey | Syslog_WithKey of string @@ -44,8 +44,9 @@ val default_path : string list val default_path_env_pair : string array val execute_command_get_output : - ?env:string array - -> ?syslog_stdout:syslog_stdout_t + ?tracing:Tracing.Span.t + -> ?env:string array + -> ?syslog_stdout:syslog_stdout -> ?redirect_stderr_to_stdout:bool -> ?timeout:float -> string @@ -56,8 +57,9 @@ val execute_command_get_output : [Spawn_internal_error(stderr, stdout, Unix.process_status)] *) val execute_command_get_output_send_stdin : - ?env:string array - -> ?syslog_stdout:syslog_stdout_t + ?tracing:Tracing.Span.t + -> ?env:string array + -> ?syslog_stdout:syslog_stdout -> ?redirect_stderr_to_stdout:bool -> ?timeout:float -> string @@ -92,12 +94,13 @@ exception Subprocess_killed of int exception Subprocess_timeout val safe_close_and_exec : - ?env:string array + ?tracing:Tracing.Span.t + -> ?env:string array -> Unix.file_descr option -> Unix.file_descr option -> Unix.file_descr option -> (string * Unix.file_descr) list - -> ?syslog_stdout:syslog_stdout_t + -> ?syslog_stdout:syslog_stdout -> ?redirect_stderr_to_stdout:bool -> string -> string list @@ -111,8 +114,10 @@ val waitpid : pidty -> int * Unix.process_status (** [waitpid p] returns the (pid, Unix.process_status) *) val waitpid_nohang : pidty -> int * Unix.process_status -(** [waitpid_nohang p] returns the (pid, Unix.process_status) if the process has already - quit or (0, Unix.WEXITTED 0) if the process is still running. *) +(** [waitpid_nohang p] returns the (pid, Unix.process_status) if the + process has already quit or (0, Unix.WEXITTED 0) if the process is + still running. If the process is finished, the socket is closed + and not otherwise. *) val dontwaitpid : pidty -> unit (** [dontwaitpid p]: signals the caller's desire to never call waitpid. Note that the final diff --git a/ocaml/forkexecd/src/child.ml b/ocaml/forkexecd/src/child.ml index f6ede6c608d..0bdb5fc1dc1 100644 --- a/ocaml/forkexecd/src/child.ml +++ b/ocaml/forkexecd/src/child.ml @@ -3,13 +3,13 @@ let debug (fmt : ('a, unit, string, unit) format4) = exception Cancelled -type syslog_stdout_t = {enabled: bool; key: string option} +type syslog_stdout = {enabled: bool; key: string option} type state_t = { cmdargs: string list ; env: string list ; id_to_fd_map: (string * int option) list - ; syslog_stdout: syslog_stdout_t + ; syslog_stdout: syslog_stdout ; redirect_stderr_to_stdout: bool ; ids_received: (string * Unix.file_descr) list ; fd_sock2: Unix.file_descr option @@ -49,8 +49,6 @@ let handle_fd_sock fd_sock state = let handle_comms_sock comms_sock state = let call = Fecomms.read_raw_rpc comms_sock in match call with - | Ok Fe.Cancel -> - debug "Cancel" ; raise Cancelled | Ok Fe.Exec -> debug "Exec" ; {state with finished= true} diff --git a/ocaml/forkexecd/test/fe_test.ml b/ocaml/forkexecd/test/fe_test.ml index bb740d94df8..42991d5f16b 100644 --- a/ocaml/forkexecd/test/fe_test.ml +++ b/ocaml/forkexecd/test/fe_test.ml @@ -109,14 +109,23 @@ let test_delay () = let start = Unix.gettimeofday () in let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in let args = ["sleep"] in + (* Need to have fractional part because some internal usage split integer + and fractional and do computation. + Better to have a high fractional part (> 0.5) to more probably exceed + the unit. + *) + let timeout = 1.7 in try - Forkhelpers.execute_command_get_output ~timeout:4.0 exe args |> ignore ; + Forkhelpers.execute_command_get_output ~timeout exe args |> ignore ; failwith "Failed to timeout" with | Forkhelpers.Subprocess_timeout -> - Printf.printf "Caught timeout exception after %f seconds\n%!" - (Unix.gettimeofday () -. start) ; - () + let elapsed = Unix.gettimeofday () -. start in + Printf.printf "Caught timeout exception after %f seconds\n%!" elapsed ; + if elapsed < timeout then + failwith "Process exited too soon" ; + if elapsed > timeout +. 0.2 then + failwith "Excessive time elapsed" | e -> failwith (Printf.sprintf "Failed with unexpected exception: %s" @@ -140,6 +149,10 @@ let fail x = Printf.fprintf stderr "%s\n" x ; assert false +let expect expected s = + if s <> expected ^ "\n" then + fail (Printf.sprintf "output %s expected %s" s expected) + let test_exitcode () = let run_expect cmd expected = try Forkhelpers.execute_command_get_output cmd [] |> ignore @@ -150,15 +163,39 @@ let test_exitcode () = in run_expect "/bin/false" 1 ; run_expect "/bin/xe-fe-test-no-command" 127 ; + run_expect "/bin/xe-fe-no-path/xe-fe-test-no-command" 127 ; run_expect "/etc/hosts" 126 ; Printf.printf "\nCompleted exitcode tests\n" +let test_output () = + let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in + let expected_out = "output string" in + let expected_err = "error string" in + let args = ["echo"; expected_out; expected_err] in + let out, err = Forkhelpers.execute_command_get_output exe args in + expect expected_out out ; + expect expected_err err ; + print_endline "Completed output tests" + +let test_input () = + let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in + let input = "input string" in + let args = ["replay"] in + let out, _ = + Forkhelpers.execute_command_get_output_send_stdin exe args input + in + expect input out ; + print_endline "Completed input tests" + let master fds = Printf.printf "\nPerforming timeout tests\n%!" ; test_delay () ; test_notimeout () ; Printf.printf "\nCompleted timeout test\n%!" ; test_exitcode () ; + Printf.printf "\nPerforming input/output tests\n%!" ; + test_output () ; + test_input () ; let combinations = shuffle (all_combinations fds) in Printf.printf "Starting %d tests\n%!" (List.length combinations) ; let i = ref 0 in @@ -233,7 +270,15 @@ let slave = function pid (List.length filtered) ls ) -let sleep () = Unix.sleep 5 ; Printf.printf "Ok\n" +let sleep () = Unix.sleep 3 ; Printf.printf "Ok\n" + +let echo out err = + if out <> "" then print_endline out ; + if err <> "" then prerr_endline err + +let replay () = + let line = read_line () in + print_endline line let usage () = Printf.printf "Usage:\n" ; @@ -253,6 +298,10 @@ let _ = sleep () | _ :: "slave" :: rest -> slave rest + | _ :: "echo" :: out :: err :: _ -> + echo out err + | _ :: "replay" :: _ -> + replay () | [_] -> master max_fds | [_; fds] -> ( diff --git a/ocaml/forkexecd/test/fe_test.sh b/ocaml/forkexecd/test/fe_test.sh index fa5ffc514cd..aa0b9899ee7 100755 --- a/ocaml/forkexecd/test/fe_test.sh +++ b/ocaml/forkexecd/test/fe_test.sh @@ -6,13 +6,14 @@ export XDG_RUNTIME_DIR=${XDG_RUNTIME_DIR:-$TMPDIR} export FE_TEST=1 SOCKET=${XDG_RUNTIME_DIR}/xapi/forker/main +rm -f "$SOCKET" ../src/fe_main.exe & MAIN=$! cleanup () { kill $MAIN } -trap cleanup EXIT +trap cleanup EXIT INT for _ in $(seq 1 10); do test -S ${SOCKET} || sleep 1 done diff --git a/ocaml/idl/autogen/api-ref-autogen.md b/ocaml/idl/autogen/api-ref-autogen.md new file mode 100644 index 00000000000..1c64c0e8bfb --- /dev/null +++ b/ocaml/idl/autogen/api-ref-autogen.md @@ -0,0 +1,8 @@ +# API Reference + +Version **@xapi-version@** + +- [Classes](@root@management-api/classes.html) +- [Relationships Between Classes](@root@management-api/relationships-between-classes.html) +- [Types](@root@management-api/types.html) +- [ErrorHandling](@root@management-api/api-ref-autogen-errors.html) diff --git a/ocaml/idl/autogen/dune b/ocaml/idl/autogen/dune new file mode 100644 index 00000000000..483a0dbdef8 --- /dev/null +++ b/ocaml/idl/autogen/dune @@ -0,0 +1,6 @@ +(alias + (name markdowngen) + (deps + (source_tree .) + ) +) \ No newline at end of file diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index 15f1c4c66c6..4d4edd972ac 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -136,7 +136,7 @@ module Session = struct call ~flags:[`Session] ~name:"change_password" ~doc: "Change the account password; if your session is authenticated with \ - root priviledges then the old_pwd is validated and the new_pwd is set \ + root privileges then the old_pwd is validated and the new_pwd is set \ regardless" ~params: [ @@ -2057,7 +2057,10 @@ module Bond = struct let t = create_obj ~in_db:true ~in_product_since:rel_miami ~in_oss_since:None ~persist:PersistEverything ~gen_constructor_destructor:false ~name:_bond - ~descr:"" ~gen_events:true ~doccomments:[] + ~descr: + "A Network bond that combines physical network interfaces, also known \ + as link aggregation" + ~gen_events:true ~doccomments:[] ~messages_default_allowed_roles:_R_POOL_OP ~doc_tags:[Networking] ~messages:[create; destroy; set_mode; set_property] ~contents: @@ -5985,7 +5988,7 @@ module DR_task = struct ) ; (Set String, "whitelist", "The devices to use for disaster recovery") ] - ~result:(Ref _dr_task, "The reference to the created task") + ~result:(Ref _dr_task, "The reference of the created DR_task") ~doc: "Create a disaster recovery task which will query the supplied list of \ devices" @@ -6067,7 +6070,7 @@ module Event = struct ~doc: "Blocking call which returns a (possibly empty) batch of events. This \ method is only recommended for legacy use. New development should use \ - event.from which supercedes this method." + event.from which supersedes this method." ~custom_marshaller:true ~flags:[`Session] ~result:(Set (Record _event), "A set of events") ~errs:[Api_errors.session_not_registered; Api_errors.events_lost] @@ -6202,7 +6205,7 @@ module Blob = struct } ] ~doc:"Create a placeholder for a binary blob" ~flags:[`Session] - ~result:(Ref _blob, "The reference to the created blob") + ~result:(Ref _blob, "The reference of the created blob") ~allowed_roles:_R_POOL_OP () let destroy = @@ -6517,14 +6520,55 @@ module Network_sriov = struct end (** PCI devices *) +let pci_dom0_access = + Enum + ( "pci_dom0_access" + , [ + ("enabled", "dom0 can access this device as normal") + ; ( "disable_on_reboot" + , "On host reboot dom0 will be blocked from accessing this device" + ) + ; ("disabled", "dom0 cannot access this device") + ; ( "enable_on_reboot" + , "On host reboot dom0 will be allowed to access this device" + ) + ] + ) module PCI = struct + let disable_dom0_access = + call ~name:"disable_dom0_access" ~lifecycle:[] + ~doc: + "Hide a PCI device from the dom0 kernel. (Takes affect after next \ + boot.)" + ~params:[(Ref _pci, "self", "The PCI to hide")] + ~result:(pci_dom0_access, "The accessibility of this PCI from dom0") + ~allowed_roles:_R_POOL_OP () + + let enable_dom0_access = + call ~name:"enable_dom0_access" ~lifecycle:[] + ~doc: + "Unhide a PCI device from the dom0 kernel. (Takes affect after next \ + boot.)" + ~params:[(Ref _pci, "self", "The PCI to unhide")] + ~result:(pci_dom0_access, "The accessibility of this PCI from dom0") + ~allowed_roles:_R_POOL_OP () + + let get_dom0_access_status = + call ~name:"get_dom0_access_status" ~lifecycle:[] + ~doc:"Return a PCI device dom0 access status." + ~params:[(Ref _pci, "self", "The PCI")] + ~result:(pci_dom0_access, "The accessibility of this PCI from dom0") + ~allowed_roles:_R_POOL_OP () + let t = create_obj ~name:_pci ~descr:"A PCI device" ~doccomments:[] ~gen_constructor_destructor:false ~gen_events:true ~in_db:true ~lifecycle:[(Published, rel_boston, "")] - ~messages:[] ~messages_default_allowed_roles:_R_POOL_OP - ~persist:PersistEverything ~in_oss_since:None ~db_logging:Log_destroy + ~messages: + [disable_dom0_access; enable_dom0_access; get_dom0_access_status] + ~messages_default_allowed_roles:_R_POOL_OP ~persist:PersistEverything + ~in_oss_since:None ~db_logging:Log_destroy ~contents: [ uid _pci ~lifecycle:[(Published, rel_boston, "")] @@ -6618,21 +6662,6 @@ end (** Physical GPUs (pGPU) *) module PGPU = struct - let dom0_access = - Enum - ( "pgpu_dom0_access" - , [ - ("enabled", "dom0 can access this device as normal") - ; ( "disable_on_reboot" - , "On host reboot dom0 will be blocked from accessing this device" - ) - ; ("disabled", "dom0 cannot access this device") - ; ( "enable_on_reboot" - , "On host reboot dom0 will be allowed to access this device" - ) - ] - ) - let add_enabled_VGPU_types = call ~name:"add_enabled_VGPU_types" ~lifecycle:[(Published, rel_vgpu_tech_preview, "")] @@ -6753,7 +6782,11 @@ module PGPU = struct let enable_dom0_access = call ~name:"enable_dom0_access" - ~lifecycle:[(Published, rel_cream, "")] + ~lifecycle: + [ + (Published, rel_cream, "") + ; (Deprecated, "24.14.0", "Use PCI.enable_dom0_access instead.") + ] ~versioned_params: [ { @@ -6764,12 +6797,16 @@ module PGPU = struct ; param_default= None } ] - ~result:(dom0_access, "The accessibility of this PGPU from dom0") + ~result:(pci_dom0_access, "The accessibility of this PGPU from dom0") ~allowed_roles:_R_POOL_OP () let disable_dom0_access = call ~name:"disable_dom0_access" - ~lifecycle:[(Published, rel_cream, "")] + ~lifecycle: + [ + (Published, rel_cream, "") + ; (Deprecated, "24.14.0", "Use PCI.disable_dom0_access instead.") + ] ~versioned_params: [ { @@ -6780,7 +6817,7 @@ module PGPU = struct ; param_default= None } ] - ~result:(dom0_access, "The accessibility of this PGPU from dom0") + ~result:(pci_dom0_access, "The accessibility of this PGPU from dom0") ~allowed_roles:_R_POOL_OP () let t = @@ -6841,8 +6878,15 @@ module PGPU = struct "A map relating each VGPU type supported on this GPU to the \ maximum number of VGPUs of that type which can run simultaneously \ on this GPU" - ; field ~qualifier:DynamicRO ~ty:dom0_access - ~lifecycle:[(Published, rel_cream, "")] + ; field ~qualifier:DynamicRO ~ty:pci_dom0_access + ~lifecycle: + [ + (Published, rel_cream, "") + ; ( Deprecated + , "24.14.0" + , "Use PCI.get_dom0_access_status instead." + ) + ] ~default_value:(Some (VEnum "enabled")) "dom0_access" "The accessibility of this device from dom0" ; field ~qualifier:DynamicRO ~ty:Bool @@ -6889,7 +6933,8 @@ module GPU_group = struct ; param_default= Some (VMap []) } ] - ~result:(Ref _gpu_group, "") ~allowed_roles:_R_POOL_OP () + ~result:(Ref _gpu_group, "The reference of the created GPU_group") + ~allowed_roles:_R_POOL_OP () let destroy = call ~name:"destroy" @@ -7041,7 +7086,7 @@ module VGPU = struct ; param_default= Some (VRef null_ref) } ] - ~result:(Ref _vgpu, "reference to the newly created object") + ~result:(Ref _vgpu, "The reference of the created VGPU object") ~allowed_roles:_R_POOL_OP () let destroy = @@ -7356,7 +7401,7 @@ module PVS_proxy = struct let create = call ~name:"create" ~doc:"Configure a VM/VIF to use a PVS proxy" - ~result:(Ref _pvs_proxy, "the new PVS proxy") + ~result:(Ref _pvs_proxy, "The reference of the created PVS proxy") ~params: [ (Ref _pvs_site, "site", "PVS site that we proxy for") @@ -7626,7 +7671,8 @@ module USB_group = struct ; param_default= Some (VMap []) } ] - ~result:(Ref _usb_group, "") ~allowed_roles:_R_POOL_ADMIN () + ~result:(Ref _usb_group, "The reference of the created USB_group") + ~allowed_roles:_R_POOL_ADMIN () let destroy = call ~name:"destroy" ~lifecycle @@ -8172,6 +8218,7 @@ let http_actions = ; Bool_query_arg "include_dom0" ; Bool_query_arg "include_vhd_parents" ; Bool_query_arg "export_snapshots" + ; String_query_arg "excluded_device_types" ] , _R_VM_ADMIN , [] diff --git a/ocaml/idl/datamodel_certificate.ml b/ocaml/idl/datamodel_certificate.ml index b18a20e7656..ac77887b9f0 100644 --- a/ocaml/idl/datamodel_certificate.ml +++ b/ocaml/idl/datamodel_certificate.ml @@ -34,7 +34,8 @@ let certificate_type = ) let t = - create_obj ~name:_certificate ~descr:"Description" ~doccomments:[] + create_obj ~name:_certificate + ~descr:"An X509 certificate used for TLS connections" ~doccomments:[] ~gen_constructor_destructor:false ~gen_events:true ~in_db:true ~lifecycle ~persist:PersistEverything ~in_oss_since:None ~messages_default_allowed_roles:_R_READ_ONLY diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 709cb5eb059..fc13fb0a7b1 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/ocaml/idl/datamodel_common.ml @@ -10,7 +10,7 @@ open Datamodel_roles to leave a gap for potential hotfixes needing to increment the schema version.*) let schema_major_vsn = 5 -let schema_minor_vsn = 775 +let schema_minor_vsn = 776 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 0a0166dfe93..81dc1e10ed2 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1455,7 +1455,7 @@ let _ = ~doc: "The requested update could not be found. Please upload the update \ again. This can occur when you run xe update-pool-clean before xe \ - update-apply. " + update-apply." () ; error Api_errors.update_pool_apply_failed ["hosts"] ~doc:"The update cannot be applied for the following host(s)." () ; @@ -1913,11 +1913,6 @@ let _ = ~doc:"Failed to get available updates from a host." () ; error Api_errors.get_updates_failed [] ~doc:"Failed to get available updates from the pool." () ; - error Api_errors.get_updates_in_progress [] - ~doc: - "The operation could not be performed because getting updates is in \ - progress." - () ; error Api_errors.apply_updates_in_progress [] ~doc: "The operation could not be performed because applying updates is in \ diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 6c7895ec901..2f9d1d7ed83 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -1369,7 +1369,7 @@ let set_power_on_mode = ; (Changed, rel_stockholm, "Removed iLO script") ] ~in_product_since:rel_midnight_ride - ~doc:"Set the power-on-mode, host, user and password " + ~doc:"Set the power-on-mode, host, user and password" ~params: [ (Ref _host, "self", "The host") diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 28ff931ec59..5044adec27b 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -109,6 +109,12 @@ let prototyped_of_message = function Some "22.20.0" | "Repository", "set_gpgkey_path" -> Some "22.12.0" + | "PCI", "get_dom0_access_status" -> + Some "24.14.0" + | "PCI", "enable_dom0_access" -> + Some "24.14.0" + | "PCI", "disable_dom0_access" -> + Some "24.14.0" | "message", "destroy_many" -> Some "22.19.0" | "VTPM", "set_contents" -> diff --git a/ocaml/idl/datamodel_main.ml b/ocaml/idl/datamodel_main.ml index 77250738817..fa22d3b9d09 100644 --- a/ocaml/idl/datamodel_main.ml +++ b/ocaml/idl/datamodel_main.ml @@ -86,7 +86,7 @@ let _ = in if !markdown_mode then - Markdown_backend.all api !dirname ; + Markdown_backend.all api ; if !dirname <> "" then Unix.chdir !dirname ; if !dot_mode then diff --git a/ocaml/idl/datamodel_observer.ml b/ocaml/idl/datamodel_observer.ml index bbda9021898..1d80d030a62 100644 --- a/ocaml/idl/datamodel_observer.ml +++ b/ocaml/idl/datamodel_observer.ml @@ -95,7 +95,7 @@ let set_components = call ~name:"set_components" ~in_oss_since:None ~lifecycle:[] ~doc: "Set the components on which the observer will broadcast to. i.e. xapi, \ - xenopsd, networkd, etc" + xenopsd, networkd, etc." ~params: [ (Ref _observer, "self", "The observer") @@ -106,7 +106,7 @@ let set_components = let t = create_obj ~name:_observer ~descr: - "Describes a observer which will control observability activity in the \ + "Describes an observer which will control observability activity in the \ Toolstack" ~doccomments:[] ~gen_constructor_destructor:true ~gen_events:true ~in_db:true ~lifecycle:[] ~persist:PersistEverything ~in_oss_since:None diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index 1fdc3acf437..f556cf56407 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -1374,13 +1374,16 @@ let t = ~default_value:(Some (VMap [])) ~ty:(Map (String, String)) "cpu_info" "Details about the physical CPUs on the pool" - ; field ~qualifier:RW ~in_product_since:rel_dundee - ~default_value:(Some (VBool false)) ~ty:Bool + ; field ~qualifier:RW ~default_value:(Some (VBool false)) ~ty:Bool + ~lifecycle: + [ + (Published, rel_dundee, "") + ; (Deprecated, "24.14.0", "No longer considered by VM.create") + ] "policy_no_vendor_device" - "The pool-wide policy for clients on whether to use the vendor \ - device or not on newly created VMs. This field will also be \ - consulted if the 'has_vendor_device' field is not specified in \ - the VM.create call." + "This field was consulted when VM.create did not specify a value \ + for 'has_vendor_device'; VM.create now uses a simple default and \ + no longer consults this value." ; field ~qualifier:RW ~in_product_since:rel_ely ~default_value:(Some (VBool false)) ~ty:Bool "live_patching_disabled" diff --git a/ocaml/idl/datamodel_types.ml b/ocaml/idl/datamodel_types.ml index 364eafb42db..05ee08f5370 100644 --- a/ocaml/idl/datamodel_types.ml +++ b/ocaml/idl/datamodel_types.ml @@ -423,7 +423,6 @@ type api_value = | VMap of (api_value * api_value) list | VSet of api_value list | VRef of string - | VCustom of string * api_value [@@deriving rpc] (* For convenience, we use the same value here as is defined in the Ref module in @@ -766,7 +765,5 @@ let rec type_checks v t = all_true (List.map (fun v -> type_checks v t) vl) | VRef _, Ref _ -> true - | VCustom _, _ -> - true (* Type checks defered to phase-2 compile time *) | _, _ -> false diff --git a/ocaml/idl/datamodel_types.mli b/ocaml/idl/datamodel_types.mli index b2f474e927f..ef490cc4a66 100644 --- a/ocaml/idl/datamodel_types.mli +++ b/ocaml/idl/datamodel_types.mli @@ -120,7 +120,6 @@ type api_value = | VMap of (api_value * api_value) list | VSet of api_value list | VRef of string - | VCustom of string * api_value val rpc_of_api_value : api_value -> Rpc.t diff --git a/ocaml/idl/datamodel_values.ml b/ocaml/idl/datamodel_values.ml index c5c68b6b73f..a13330f971d 100644 --- a/ocaml/idl/datamodel_values.ml +++ b/ocaml/idl/datamodel_values.ml @@ -49,12 +49,10 @@ let rec to_rpc v = Rpc.Enum (List.map (fun v -> to_rpc v) vl) | VRef r -> Rpc.String r - | VCustom (_, _) -> - failwith "Can't RPC up a custom value" open Printf -let to_ocaml_string ?(v2 = false) v = +let to_ocaml_string v = let rec aux = function | Rpc.Null -> "Rpc.Null" @@ -80,18 +78,7 @@ let to_ocaml_string ?(v2 = false) v = | Rpc.Base64 t -> sprintf "Rpc.Base64 %s" t in - match v with - | VCustom (s, v') -> - if v2 then - (* s can contain stringified body of ocaml functions, and will break - * the aPI.ml code, we need to use the v' in that case. The version - * switch allows us to use this other version in gen_api.ml without - * having to duplicate lots of code *) - aux (to_rpc v') - else - s - | _ -> - aux (to_rpc v) + aux (to_rpc v) let rec to_db v = let open Schema.Value in @@ -116,8 +103,6 @@ let rec to_db v = Set (List.map to_string vl) | VRef r -> String r - | VCustom (_, y) -> - to_db y (* Generate suitable "empty" database value of specified type *) let gen_empty_db_val t = diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index c1a6b9a7d9c..f6236540bf1 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -1899,7 +1899,7 @@ let t = ; field ~qualifier:DynamicRO ~ty:(Set (Ref _vbd)) "VBDs" "virtual block devices" ; field ~qualifier:DynamicRO ~ty:(Set (Ref _vusb)) "VUSBs" - "vitual usb devices" + "virtual usb devices" ; field ~writer_roles:_R_POOL_ADMIN ~qualifier:DynamicRO ~ty:(Set (Ref _crashdump)) "crash_dumps" "crash dumps associated with this VM" @@ -2092,35 +2092,16 @@ let t = "hardware_platform_version" "The host virtual hardware platform version the VM can run on" ; field ~qualifier:StaticRO - ~lifecycle:[(Published, rel_dundee, "")] - ~doc_tags:[Windows] - ~default_value: - (Some - (VCustom - ( String.concat "\n" - [ - "(try Rpc.Bool (" - ; "let pool = List.hd \ - (Db_actions.DB_Action.Pool.get_all ~__context) in" - ; "let restrictions = \ - Db_actions.DB_Action.Pool.get_restrictions \ - ~__context ~self:pool in " - ; "let vendor_device_allowed = try List.assoc \ - \"restrict_pci_device_for_auto_update\" \ - restrictions = \"false\" with _ -> false in" - ; "let policy_says_its_ok = not \ - (Db_actions.DB_Action.Pool.get_policy_no_vendor_device \ - ~__context ~self:pool) in" - ; "vendor_device_allowed && policy_says_its_ok) with e \ - -> D.error \"Failure when defaulting \ - has_vendor_device field: %s\" (Printexc.to_string \ - e); Rpc.Bool false)" - ] - , VBool false - ) - ) - ) - ~ty:Bool "has_vendor_device" + ~lifecycle: + [ + (Published, rel_dundee, "") + ; ( Changed + , "24.14.0" + , "New default and not consulting Pool.policy_no_vendor_device" + ) + ] + ~doc_tags:[Windows] ~default_value:(Some (VBool true)) ~ty:Bool + "has_vendor_device" "When an HVM guest starts, this controls the presence of the \ emulated C000 PCI device which triggers Windows Update to fetch \ or update PV drivers." diff --git a/ocaml/idl/dune b/ocaml/idl/dune index 3dfa75af8c4..713462e7ffa 100644 --- a/ocaml/idl/dune +++ b/ocaml/idl/dune @@ -30,6 +30,7 @@ (modules datamodel_main dot_backend dtd_backend markdown_backend) (libraries dune-build-info + mustache xapi-datamodel xapi-stdext-std xapi-stdext-pervasives @@ -37,6 +38,16 @@ ) ) +(rule + (alias markdowngen) + (deps + (:x datamodel_main.exe) + (source_tree templates) + ) + (package xapi-datamodel) + (action (run %{x} -closed -markdown)) +) + (test (name schematest) (modes exe) diff --git a/ocaml/idl/json_backend/gen_json.ml b/ocaml/idl/json_backend/gen_json.ml index d47db08514d..dd24c0f11cf 100644 --- a/ocaml/idl/json_backend/gen_json.ml +++ b/ocaml/idl/json_backend/gen_json.ml @@ -107,8 +107,6 @@ end = struct Printf.sprintf "{%s}" (String.concat ", " (List.map string_of_default x)) | VRef x -> if x = "" then "Null" else x - | VCustom (_, y) -> - string_of_default y let of_lifecycle lc = `Assoc diff --git a/ocaml/idl/markdown_backend.ml b/ocaml/idl/markdown_backend.ml index edd95d95d50..38ec1c8caef 100644 --- a/ocaml/idl/markdown_backend.ml +++ b/ocaml/idl/markdown_backend.ml @@ -15,7 +15,7 @@ open Printf open Datamodel_types open Datamodel_utils open Dm_api -open Xapi_stdext_pervasives.Pervasiveext +module Unixext = Xapi_stdext_unix.Unixext (*column widths for the autogenerated tables*) let col_width_15 = 15 @@ -28,6 +28,10 @@ let col_width_40 = 40 let col_width_70 = 70 +let destdir = "autogen" + +let templatesdir = "templates" + let pad_right x max_width = let length = String.length x in if String.length x < max_width then @@ -78,14 +82,6 @@ let escape s = let escaped_list = List.map esc_char sl in String.concat "" escaped_list -let is_prim_type = function - | String | Int | Float | Bool | DateTime -> - true - | _ -> - false - -let is_prim_opt_type = function None -> true | Some (ty, _) -> is_prim_type ty - let rec of_ty_verbatim = function | SecretString | String -> "string" @@ -152,231 +148,387 @@ let string_of_qualifier = function | RW -> "_RW_" -let is_removal_marker x = - match x with Lifecycle.Removed, _, _ -> true | _ -> false +let render_file (infile, outfile) json templates_dir dest_dir = + let templ = + Unixext.string_of_file (Filename.concat templates_dir infile) + |> Mustache.of_string + in + let rendered = Mustache.render templ json in + let io = open_out (Filename.concat dest_dir outfile) in + Fun.protect + (fun () -> output_string io rendered) + ~finally:(fun () -> close_out io) -let is_deprecation_marker x = - match x with Lifecycle.Deprecated, _, _ -> true | _ -> false +let generate_class cls = + let class_json = + `O + [ + ("class_name", `String (escape cls.name)) + ; ("class_descr", `String (escape cls.description)) + ; ("has_descr", `Bool (cls.description <> "")) + ; ("class_deprecated", `Bool (cls.obj_lifecycle.state = Deprecated_s)) + ; ("class_removed", `Bool (cls.obj_lifecycle.state = Removed_s)) + ; ("is_event", `Bool (String.lowercase_ascii cls.name = "event")) + ; ("has_fields", `Bool (Datamodel_utils.fields_of_obj cls <> [])) + ; ( "fields" + , `A + (cls + |> Datamodel_utils.fields_of_obj + |> List.sort (fun x y -> + compare_case_ins + (Datamodel_utils.wire_name_of_field x) + (Datamodel_utils.wire_name_of_field y) + ) + |> List.map (fun field -> + `O + [ + ( "field_name" + , `String + (pad_right + ("`" + ^ Datamodel_utils.wire_name_of_field field + ^ "`" + ) + col_width_20 + ) + ) + ; ( "field_type" + , `String + (pad_right + ("`" ^ of_ty_verbatim field.ty ^ "`") + col_width_20 + ) + ) + ; ( "field_ctor" + , `String + (pad_right + (string_of_qualifier field.qualifier) + col_width_15 + ) + ) + ; ( "field_descr" + , `String + (pad_right + (escape field.field_description) + col_width_40 + ) + ) + ; ( "field_deprecated" + , `Bool + (field.lifecycle.state = Deprecated_s + || cls.obj_lifecycle.state = Deprecated_s + ) + ) + ; ( "field_removed" + , `Bool + (field.lifecycle.state = Removed_s + || cls.obj_lifecycle.state = Removed_s + ) + ) + ] + ) + ) + ) + ; ("has_rpcs", `Bool (cls.messages <> [])) + ; ( "all_rpcs" + , `A + (cls.messages + |> List.sort (fun x y -> compare_case_ins x.msg_name y.msg_name) + |> List.map (fun msg -> + let is_event_from = + String.lowercase_ascii cls.name = "event" + && String.lowercase_ascii msg.msg_name = "from" + in + let rpc_param_csv = + msg.msg_params + |> List.map (fun p -> + of_ty_verbatim p.param_type ^ " " ^ p.param_name + ) + |> String.concat ", " + in + let error_codes_csv = + msg.msg_errors + |> List.map (fun x -> sprintf "`%s`" x.err_name) + |> String.concat ", " + in + let rbac x = + match x.msg_allowed_roles with + | Some y when y <> [] -> + List.hd (List.rev y) + | _ -> + "" + in + `O + [ + ("rpc_name_escaped", `String (escape msg.msg_name)) + ; ("rpc_name", `String msg.msg_name) + ; ("rpc_descr", `String (escape msg.msg_doc)) + ; ("rpc_has_descr", `Bool (msg.msg_doc <> "")) + ; ( "rpc_deprecated" + , `Bool + (msg.msg_lifecycle.state = Lifecycle.Deprecated_s + || cls.obj_lifecycle.state = Deprecated_s + ) + ) + ; ( "rpc_removed" + , `Bool + (msg.msg_lifecycle.state = Lifecycle.Removed_s + || cls.obj_lifecycle.state = Removed_s + ) + ) + ; ("returns_void", `Bool (msg.msg_result = None)) + ; ( "return_type" + , `String + ( if is_event_from then + "event batch" + else + of_ty_opt_verbatim msg.msg_result + ) + ) + ; ( "return_descr" + , `String (escape (desc_of_ty_opt msg.msg_result)) + ) + ; ("rpc_param_csv", `String rpc_param_csv) + ; ("has_rbac", `Bool (rbac msg <> "")) + ; ("min_role", `String (rbac msg)) + ; ("session", `Bool msg.msg_session) + ; ("has_rpc_params", `Bool (msg.msg_params <> [])) + ; ( "rpc_params" + , `A + (msg.msg_params + |> List.map (fun p -> + `O + [ + ( "param_name" + , `String + (pad_right + ("`" ^ p.param_name ^ "`") + col_width_30 + ) + ) + ; ( "param_type" + , `String + (pad_right + ("`" + ^ of_ty_verbatim p.param_type + ^ "`" + ) + col_width_30 + ) + ) + ; ( "param_descr" + , `String + (pad_right (escape p.param_doc) + col_width_40 + ) + ) + ] + ) + ) + ) + ; ("has_error_codes", `Bool (msg.msg_errors <> [])) + ; ("error_codes_csv", `String error_codes_csv) + ] + ) + ) + ) + ] + in + render_file + ("class.mustache", sprintf "class-%s.md" (String.lowercase_ascii cls.name)) + class_json templatesdir destdir -(* Make a markdown section for an API-specified message *) -let markdown_section_of_message printer obj ~is_class_deprecated - ~is_class_removed x = - let is_event_from = - String.lowercase_ascii obj.name = "event" - && String.lowercase_ascii x.msg_name = "from" +let generate_types system = + let type_comparer x y = + match (x, y) with + | Enum (a, _), Enum (b, _) -> + compare_case_ins a b + | _ -> + compare x y in - let return_type = of_ty_opt_verbatim x.msg_result in - printer (sprintf "#### RPC name: %s" (escape x.msg_name)) ; - printer "" ; - if x.msg_lifecycle.state = Lifecycle.Removed_s || is_class_removed then ( - printer "**This message is removed.**" ; - printer "" - ) else if - x.msg_lifecycle.state = Lifecycle.Deprecated_s || is_class_deprecated - then ( - printer "**This message is deprecated.**" ; - printer "" - ) ; - printer "_Overview:_" ; - printer "" ; - printer (escape x.msg_doc) ; - printer "" ; - printer "_Signature:_" ; - printer "" ; - printer "```" ; - let result = - if is_event_from then - "" - else - of_ty_opt_verbatim x.msg_result + let enums = + Types.of_objects system + |> List.filter (function Enum (_, _) -> true | _ -> false) + |> List.sort type_comparer in - printer - (sprintf "%s %s (%s)" result x.msg_name - (String.concat ", " - ((if x.msg_session then ["session ref session_id"] else []) - @ List.map - (fun p -> of_ty_verbatim p.param_type ^ " " ^ p.param_name) - x.msg_params - ) - ) - ) ; - printer "```" ; - printer "" ; - if x.msg_params <> [] then ( - printer "_Arguments:_" ; - printer "" ; - printer - "|type |name \ - |description |" ; - printer - "|:-----------------------------|:-----------------------------|:---------------------------------------|" ; - if x.msg_session then - printer - "|session ref |session_id \ - |Reference to a valid session |" ; - let get_param_row p = - sprintf "|`%s`|%s|%s|" - (pad_right (of_ty_verbatim p.param_type) (col_width_30 - 2)) - (pad_right (escape p.param_name) col_width_30) - (pad_right (escape p.param_doc) col_width_40) - in - List.iter (fun p -> printer (get_param_row p)) x.msg_params ; - printer "" - ) ; - let print_rbac y = - match y.msg_allowed_roles with - | Some yy when yy <> [] -> - printer ("_Minimum Role:_ " ^ List.hd (List.rev yy)) ; - printer "" - | _ -> - () + let types_json = + `O + [ + ( "enums" + , `A + (List.map + (function + | Enum (name, options) -> + `O + [ + ("enum", `String name) + ; ( "enum_options" + , `A + (options + |> List.sort (fun (x, _) (y, _) -> + compare_case_ins x y + ) + |> List.map (fun (n, c) -> + `O + [ + ( "option_name" + , `String + (pad_right + ("`" ^ n ^ "`") + col_width_40 + ) + ) + ; ( "option_descr" + , `String + (pad_right (escape c) col_width_40) + ) + ] + ) + ) + ) + ] + | _ -> + `Null + ) + enums + ) + ) + ] in - print_rbac x ; - printer - ("_Return Type:_" - ^ if is_event_from then " an event batch" else sprintf " `%s`" return_type - ) ; - printer "" ; - let descr = desc_of_ty_opt x.msg_result in - if descr <> "" then ( - printer (escape descr) ; - printer "" - ) ; - if x.msg_errors <> [] then ( - let error_codes = - List.map (fun err -> sprintf "`%s`" err.err_name) x.msg_errors - in - printer - (sprintf "_Possible Error Codes:_ %s" (String.concat ", " error_codes)) ; - printer "" - ) + render_file ("types.mustache", "types.md") types_json templatesdir destdir -let print_field_table_of_obj printer ~is_class_deprecated ~is_class_removed x = - printer (sprintf "### Fields for class: " ^ escape x.name) ; - printer "" ; - if x.contents = [] then - printer ("Class " ^ escape x.name ^ " has no fields.") - else ( - printer - "|Field |Type |Qualifier \ - |Description |" ; - printer - "|:-------------------|:-------------------|:--------------|:---------------------------------------|" ; - let print_field_content printer - ({qualifier; ty; field_description= description; _} as y) = - let wired_name = Datamodel_utils.wire_name_of_field y in - let descr = - ( if y.lifecycle.state = Removed_s || is_class_removed then - "**Removed**. " - else if y.lifecycle.state = Deprecated_s || is_class_deprecated then - "**Deprecated**. " - else - "" - ) - ^ escape description - in - printer - (sprintf "|%s|`%s`|%s|%s|" - (pad_right (escape wired_name) col_width_20) - (pad_right (of_ty_verbatim ty) (col_width_20 - 2)) - (pad_right (string_of_qualifier qualifier) col_width_15) - (pad_right descr col_width_40) - ) - in - x - |> Datamodel_utils.fields_of_obj - |> List.sort (fun x y -> - compare_case_ins - (Datamodel_utils.wire_name_of_field x) - (Datamodel_utils.wire_name_of_field y) - ) - |> List.iter (print_field_content printer) ; - if String.lowercase_ascii x.name = "event" then - printer - (sprintf "|%s|`%s`|%s|%s|" - (pad_right "snapshot" col_width_20) - (pad_right "" (col_width_20 - 2)) - (pad_right "_RO/runtime_" col_width_15) - (pad_right - "The record of the database object that was added, changed or \ - deleted" - col_width_40 - ) +let generate_relationships api = + let relations = relations_of_api api in + let relationships_json = + `O + [ + ( "relationships" + , `A + (List.map + (function + | ((a, a_field), (b, b_field)) as rel -> + let c = Relations.classify api rel in + let afield = "`" ^ a ^ "." ^ a_field ^ "`" in + let bfield = "`" ^ b ^ "." ^ b_field ^ "`" in + `O + [ + ( "a_field" + , `String (pad_right afield (col_width_40 - 2)) + ) + ; ( "b_field" + , `String (pad_right bfield (col_width_40 - 2)) + ) + ; ( "relationship" + , `String + (pad_right + (Relations.string_of_classification c) + col_width_15 + ) + ) + ] + ) + relations + ) ) - ) + ] + in + render_file + ("relationships.mustache", "relationships-between-classes.md") + relationships_json templatesdir destdir -let of_obj printer x = - printer (sprintf "## Class: %s" (escape x.name)) ; - printer "" ; - let is_class_removed = x.obj_lifecycle.state = Removed_s in - let is_class_deprecated = x.obj_lifecycle.state = Deprecated_s in - if is_class_removed then ( - printer "**This class is removed.**" ; - printer "" - ) else if is_class_deprecated then ( - printer "**This class is deprecated.**" ; - printer "" - ) ; - printer (escape x.description) ; - printer "" ; - print_field_table_of_obj printer ~is_class_deprecated ~is_class_removed x ; - printer "" ; - printer (sprintf "### RPCs associated with class: " ^ escape x.name) ; - printer "" ; - if x.messages = [] then ( - printer - (sprintf "Class %s has no additional RPCs associated with it." - (escape x.name) - ) ; - printer "" - ) else - x.messages - |> List.sort (fun x y -> compare_case_ins x.msg_name y.msg_name) - |> List.iter - (markdown_section_of_message printer x ~is_class_deprecated - ~is_class_removed - ) +let generate_classes system = + let classes_json = + `O + [ + ( "classes" + , `A + (List.map + (fun x -> + let notice y = + match y.obj_lifecycle.state with + | Removed_s -> + "**Removed**. " + | Deprecated_s -> + "**Deprecated**. " + | _ -> + "" + in + `O + [ + ("name", `String x.name) + ; ("name_lower", `String (String.lowercase_ascii x.name)) + ; ( "description" + , `String + (pad_right + (notice x ^ escape x.description) + col_width_70 + ) + ) + ] + ) + system + ) + ) + ] + in + render_file + ("classes.mustache", "classes.md") + classes_json templatesdir destdir -let print_enum printer = function - | Enum (name, options) -> - printer - (sprintf "|`enum %s`| |" - (pad_right name (col_width_40 - 7)) - ) ; - printer - "|:---------------------------------------|:---------------------------------------|" ; - let print_option (opt, description) = - printer - (sprintf "|`%s`|%s|" - (pad_right opt (col_width_40 - 2)) - (pad_right (escape description) col_width_40) - ) - in - options - |> List.sort (fun (x, _) (y, _) -> compare_case_ins x y) - |> List.iter print_option ; - printer "" - | _ -> - () +let generate_toc system = + let classes_json = + `O + [ + ( "classes" + , `A + (List.map + (fun x -> + `O + [ + ("name", `String x.name) + ; ("name_lower", `String (String.lowercase_ascii x.name)) + ] + ) + system + ) + ) + ] + in + render_file ("toc.mustache", "toc.yml") classes_json templatesdir destdir -let error_doc printer {err_name= name; err_params= params; err_doc= doc} = - printer (sprintf "### %s" (escape name)) ; - printer "" ; - printer (escape doc) ; - printer "" ; - if params = [] then - printer "No parameters." - else ( - printer "_Signature:_" ; - printer "" ; - printer "```" ; - printer (sprintf "%s(%s)" name (String.concat ", " params)) ; - printer "```" - ) ; - printer "" +let generate_errors () = + (* Sort the errors alphabetically, then generate one section per code. *) + let errs = + Hashtbl.fold (fun name err acc -> (name, err) :: acc) Datamodel.errors [] + |> List.sort (fun (n1, _) (n2, _) -> compare n1 n2) + |> List.split + |> snd + in + let error_json = + `O + [ + ( "errors" + , `A + (List.map + (fun {err_name; err_params; err_doc} -> + `O + [ + ("error_code", `String (escape err_name)) + ; ("error_code_unescaped", `String err_name) + ; ("error_description", `String (escape err_doc)) + ; ("parameters", `String (String.concat ", " err_params)) + ] + ) + errs + ) + ) + ] + in + render_file + ("api_errors.mustache", "api-ref-autogen-errors.md") + error_json templatesdir destdir -let print_classes api io = - let printer text = fprintf io "%s\n" text in +let all api = (* Remove private messages that are only used internally (e.g. get_record_internal) *) let api = Dm_api.filter @@ -390,219 +542,10 @@ let print_classes api io = let system = objects_of_api api |> List.sort (fun x y -> compare_case_ins x.name y.name) in - let relations = relations_of_api api in - printer - "# API Reference - Types and Classes\n\n\ - ## Classes\n\n\ - The following classes are defined:\n\n\ - |Name \ - |Description |\n\ - |:-------------------|:---------------------------------------------------------------------|" ; - let get_descr obj = - ( if obj.obj_lifecycle.state = Removed_s then - "**Removed**. " - else if obj.obj_lifecycle.state = Deprecated_s then - "**Deprecated**. " - else - "" - ) - ^ escape obj.description - in - List.iter - (fun obj -> - printer - (sprintf "|`%s`|%s|" - (pad_right obj.name (col_width_20 - 2)) - (pad_right (get_descr obj) col_width_70) - ) - ) - system ; - printer - "\n\ - ## Relationships Between Classes\n\n\ - Fields that are bound together are shown in the following table:\n\n\ - |_object.field_ \ - |_object.field_ |_relationship_ |\n\ - |:---------------------------------------|:---------------------------------------|:--------------|" ; - List.iter - (function - | ((a, a_field), (b, b_field)) as rel -> - let c = Relations.classify api rel in - let afield = a ^ "." ^ a_field in - let bfield = b ^ "." ^ b_field in - printer - (sprintf "|`%s`|`%s`|%s|" - (pad_right afield (col_width_40 - 2)) - (pad_right bfield (col_width_40 - 2)) - (pad_right (Relations.string_of_classification c) col_width_15) - ) - ) - relations ; - printer - "\n\ - The following figure represents bound fields (as specified above) \ - diagramatically, using crow's foot notation to specify one-to-one, \ - one-to-many or many-to-many relationships:\n\n\ - ![Class relationships](classes.png 'Class relationships')\n\n\ - ## Types\n\n\ - ### Primitives\n\n\ - The following primitive types are used to specify methods and fields in \ - the API Reference:\n\n\ - |Type |Description |\n\ - |:-------|:-------------------------------------------|\n\ - |string |text strings |\n\ - |int |64-bit integers |\n\ - |float |IEEE double-precision floating-point numbers|\n\ - |bool |boolean |\n\ - |datetime|date and timestamp |\n\n\ - ### Higher-order types\n\n\ - The following type constructors are used:\n\n\ - |Type \ - |Description |\n\ - |:-----------------|:-------------------------------------------------------|\n\ - |_c_ ref |reference to an object of class \ - _c_ |\n\ - |_t_ set |a set of elements of type \ - _t_ |\n\ - |(_a -> b_) map |a table mapping values of type _a_ to values \ - of type _b_|\n\n\ - ### Enumeration types\n\n\ - The following enumeration types are used:\n" ; - let type_comparer x y = - match (x, y) with - | Enum (a, _), Enum (b, _) -> - compare_case_ins a b - | _ -> - compare x y - in - Types.of_objects system - |> List.sort type_comparer - |> List.iter (print_enum printer) ; - List.iter (fun x -> of_obj printer x) system -let print_errors io = - let printer text = fprintf io "%s\n" text in - printer - "# API Reference - Error Handling\n\n\ - When a low-level transport error occurs, or a request is malformed at the \ - HTTP\n\ - or RPC level, the server may send an HTTP 500 error response, or the client\n\ - may simulate the same. The client must be prepared to handle these errors,\n\ - though they may be treated as fatal.\n\n\ - On the wire, these are transmitted in a form similar to this when using the\n\ - XML-RPC protocol:\n\n\ - ```\n\ - $curl -D - -X POST https://server -H 'Content-Type: application/xml' \\\n\ - > -d '\n\ - > \n\ - > session.logout\n\ - > '\n\ - HTTP/1.1 500 Internal Error\n\ - content-length: 297\n\ - content-type:text/html\n\ - connection:close\n\ - cache-control:no-cache, no-store\n\n\ -

HTTP 500 internal server error

An unexpected error \ - occurred;\n\ - \ please wait a while and try again. If the problem persists, please \ - contact your\n\ - \ support representative.

Additional information \ -

Xmlrpc.Parse_error(&quo\n\ - t;close_tag", "open_tag", _)\n\ - ```\n\n\ - When using the JSON-RPC protocol:\n\n\ - ```\n\ - $curl -D - -X POST https://server/jsonrpc -H 'Content-Type: \ - application/json' \\\n\ - > -d '{\n\ - > \"jsonrpc\": \"2.0\",\n\ - > \"method\": \"session.login_with_password\",\n\ - > \"id\": 0\n\ - > }'\n\ - HTTP/1.1 500 Internal Error\n\ - content-length: 308\n\ - content-type:text/html\n\ - connection:close\n\ - cache-control:no-cache, no-store\n\n\ -

HTTP 500 internal server error

An unexpected error \ - occurred;\n\ - \ please wait a while and try again. If the problem persists, please \ - contact your\n\ - \ support representative.

Additional information \ -

Jsonrpc.Malformed_metho\n\ - d_request("{jsonrpc=...,method=...,id=...}")\n\ - ```\n\n\ - All other failures are reported with a more structured error response, to\n\ - allow better automatic response to failures, proper internationalisation of\n\ - any error message, and easier debugging.\n\n\ - On the wire, these are transmitted like this when using the XML-RPC \ - protocol:\n\n\ - ```xml\n\ - \ \n\ - \ \n\ - \ Status\n\ - \ Failure\n\ - \ \n\ - \ \n\ - \ ErrorDescription\n\ - \ \n\ - \ \n\ - \ \n\ - \ MAP_DUPLICATE_KEY\n\ - \ Customer\n\ - \ eSpiel Inc.\n\ - \ eSpiel Incorporated\n\ - \ \n\ - \ \n\ - \ \n\ - \ \n\ - \ \n\ - ```\n\n\ - Note that `ErrorDescription` value is an array of string values. The\n\ - first element of the array is an error code; the remainder of the array are\n\ - strings representing error parameters relating to that code. In this case,\n\ - the client has attempted to add the mapping _Customer ->\n\ - eSpiel Incorporated_ to a Map, but it already contains the mapping\n\ - _Customer -> eSpiel Inc._, and so the request has failed.\n\n\ - When using the JSON-RPC protocol v2.0, the above error is transmitted as:\n\n\ - ```json\n\ - {\n\ - \ \"jsonrpc\": \"2.0\",\n\ - \ \"error\": {\n\ - \ \"code\": 1,\n\ - \ \"message\": \"MAP_DUPLICATE_KEY\",\n\ - \ \"data\": [\n\ - \ \"Customer\",\"eSpiel Inc.\",\"eSpiel Incorporated\"\n\ - \ ]\n\ - \ },\n\ - \ \"id\": 3\n\ - \ }\n\ - ```\n\n\ - Finally, when using the JSON-RPC protocol v1.0:\n\n\ - ```json\n\ - {\n\ - \ \"result\": null,\n\ - \ \"error\": [\n\ - \ \"MAP_DUPLICATE_KEY\",\"Customer\",\"eSpiel Inc.\",\"eSpiel \ - Incorporated\"\n\ - \ ],\n\ - \ \"id\": \"xyz\"\n\ - }\n\ - ```\n\n\ - Each possible error code is documented in the following section.\n\n\ - ## Error Codes\n" ; - (* Sort the errors alphabetically, then generate one section per code. *) - let errs = - Hashtbl.fold (fun name err acc -> (name, err) :: acc) Datamodel.errors [] - in - List.iter (error_doc printer) - (snd (List.split (List.sort (fun (n1, _) (n2, _) -> compare n1 n2) errs))) - -let all api destdir = - Xapi_stdext_unix.Unixext.mkdir_rec destdir 0o755 ; - let with_file filename f = - let io = open_out (Filename.concat destdir filename) in - finally (fun () -> f io) (fun () -> close_out io) - in - with_file "api-ref-autogen.md" (print_classes api) ; - with_file "api-ref-autogen-errors.md" print_errors + List.iter generate_class system ; + generate_classes system ; + generate_relationships api ; + generate_types system ; + generate_errors () ; + generate_toc system diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 01c49bdbe88..c08c9671791 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -72,6 +72,23 @@ let overrides = ) ] +(** Generate enum__all and enum_to_string bindings for all enums *) +let gen_enum_helpers tys = + let gen_string_and_all = function + | DT.Set (DT.Enum (_, elist) as e) -> + let nlist = List.map fst elist in + [ + Printf.sprintf "let %s__all = %s" (OU.alias_of_ty e) + (OU.ocaml_list_of_enum nlist) + ; (Printf.sprintf "let %s_to_string = %s") + (OU.alias_of_ty e) + (OU.ocaml_to_string_of_enum nlist) + ] + | _ -> + [] + in + List.concat_map gen_string_and_all tys + (** Generate a single type declaration for simple types (eg not containing references to record objects) *) let gen_non_record_type tys = let rec aux accu = function @@ -171,8 +188,7 @@ let gen_record_type ~with_module highapi tys = | None -> "None" | Some default -> - sprintf "(Some (%s))" - (Datamodel_values.to_ocaml_string ~v2:true default) + sprintf "(Some (%s))" (Datamodel_values.to_ocaml_string default) in let make_to_field fld = let rpc_field = rpc_field fld in @@ -382,6 +398,7 @@ let gen_client_types highapi = ; gen_non_record_type all_types ; gen_record_type ~with_module:true highapi (toposort_types highapi all_types) + ; gen_enum_helpers all_types ; O.Signature.strings_of (Gen_client.gen_signature highapi) ] ) diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index db222970b92..13bc14a1f4b 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/ocaml/idl/ocaml_backend/gen_db_actions.ml @@ -271,13 +271,14 @@ let ocaml_of_tbl_fields xs = let open_db_module = [ "let __t = Context.database_of __context in" - ; "let module DB = (val (Db_cache.get __t) : Db_interface.DB_ACCESS) in" + ; "let module DB = (val (Xapi_database.Db_cache.get __t) : \ + Xapi_database.Db_interface.DB_ACCESS) in" ] let db_action api : O.Module.t = let api = make_db_api api in let expr = "expr" in - let expr_arg = O.Named (expr, "Db_filter_types.expr") in + let expr_arg = O.Named (expr, "Xapi_database.Db_filter_types.expr") in let get_refs_where (obj : obj) = let tbl = Escaping.escape_obj obj.DT.name in let body = @@ -526,13 +527,13 @@ let db_action api : O.Module.t = | FromObject GetAllRecords -> String.concat "\n" [ - "let expr' = Db_filter_types.True in" + "let expr' = Xapi_database.Db_filter_types.True in" ; "get_records_where ~" ^ Gen_common.context ^ " ~expr:expr'" ] | FromObject GetAllRecordsWhere -> String.concat "\n" [ - "let expr' = Db_filter.expr_of_string expr in" + "let expr' = Xapi_database.Db_filter.expr_of_string expr in" ; "get_records_where ~" ^ Gen_common.context ^ " ~expr:expr'" ] | _ -> @@ -577,7 +578,7 @@ let db_action api : O.Module.t = O.Module.make ~name:_db_action ~preamble: [ - "open Db_cache_types" + "open Xapi_database.Db_cache_types" ; "module D=Debug.Make(struct let name=\"db\" end)" ; "open D" ] diff --git a/ocaml/idl/ocaml_backend/ocaml_utils.ml b/ocaml/idl/ocaml_backend/ocaml_utils.ml index e3ab8ac19dd..a01ae955586 100644 --- a/ocaml/idl/ocaml_backend/ocaml_utils.ml +++ b/ocaml/idl/ocaml_backend/ocaml_utils.ml @@ -58,9 +58,15 @@ let ocaml_of_record_field = function let ocaml_of_module_name x = String.capitalize_ascii x +let ocaml_map_enum_ sep f list = String.concat sep (List.map f list) + (** Convert an IDL enum into a polymorhic variant. *) let ocaml_of_enum list = - "[ " ^ String.concat " | " (List.map constructor_of list) ^ " ]" + Printf.sprintf "[%s]" (ocaml_map_enum_ " | " constructor_of list) + +(* Create a to_string function for a polymorphic variant. *) +let ocaml_list_of_enum list = + Printf.sprintf "[%s]" (ocaml_map_enum_ "; " constructor_of list) (** Convert an IDL type to a function name; we need to generate functions to marshal/unmarshal from XML for each unique IDL type *) @@ -90,6 +96,11 @@ let rec alias_of_ty = function | Option x -> sprintf "%s_option" (alias_of_ty x) +(** Create the body of a to_string function for an enum *) +let ocaml_to_string_of_enum list = + let single name = Printf.sprintf {|%s -> "%s"|} (constructor_of name) name in + Printf.sprintf "function %s" (ocaml_map_enum_ " | " single list) + (** Convert an IDL type into a string containing OCaml code representing the type. *) let rec ocaml_of_ty = function diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index c8e5972c9a6..60ddad41e91 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 = "186131ad48f40dff30246e8e0c0dbf0a" +let last_known_schema_hash = "8c3cb4546e7dc9e8d9d05c8194d8a3d6" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/idl/templates/api_errors.mustache b/ocaml/idl/templates/api_errors.mustache new file mode 100644 index 00000000000..d2e877e25d1 --- /dev/null +++ b/ocaml/idl/templates/api_errors.mustache @@ -0,0 +1,145 @@ +--- + layout: doc +--- + +# Error Handling + +When a low-level transport error occurs, or a request is malformed at the HTTP +or RPC level, the server may send an HTTP 500 error response, or the client +may simulate the same. The client must be prepared to handle these errors, +though they may be treated as fatal. + +For example, the following malformed request when using the XML-RPC protocol: + +```sh +$curl -D - -X POST https://server -H 'Content-Type: application/xml' \ +> -d ' +> +> session.logout +> ' +``` + +results to the following response: + +```sh +HTTP/1.1 500 Internal Error +content-length: 297 +content-type:text/html +connection:close +cache-control:no-cache, no-store + +

HTTP 500 internal server error

An unexpected error occurred; + please wait a while and try again. If the problem persists, please contact your + support representative.

Additional information

Xmlrpc.Parse_error(&quo +t;close_tag", "open_tag", _) +``` + +When using the JSON-RPC protocol: + +```sh +$curl -D - -X POST https://server/jsonrpc -H 'Content-Type: application/json' \ +> -d '{ +> "jsonrpc": "2.0", +> "method": "session.login_with_password", +> "id": 0 +> }' +``` + +the response is: + +```sh +HTTP/1.1 500 Internal Error +content-length: 308 +content-type:text/html +connection:close +cache-control:no-cache, no-store + +

HTTP 500 internal server error

An unexpected error occurred; + please wait a while and try again. If the problem persists, please contact your + support representative.

Additional information

Jsonrpc.Malformed_metho +d_request("{jsonrpc=...,method=...,id=...}") +``` + +All other failures are reported with a more structured error response, to +allow better automatic response to failures, proper internationalization of +any error message, and easier debugging. + +On the wire, these are transmitted like this when using the XML-RPC protocol: + +```xml + + + Status + Failure + + + ErrorDescription + + + + MAP_DUPLICATE_KEY + Customer + eSpiel Inc. + eSpiel Incorporated + + + + + +``` + +Note that `ErrorDescription` value is an array of string values. The +first element of the array is an error code; the remainder of the array are +strings representing error parameters relating to that code. In this case, +the client has attempted to add the mapping _Customer -> +eSpiel Incorporated_ to a Map, but it already contains the mapping +_Customer -> eSpiel Inc._, hence the request has failed. + +When using the JSON-RPC protocol v2.0, the above error is transmitted as: + +```json +{ + "jsonrpc": "2.0", + "error": { + "code": 1, + "message": "MAP_DUPLICATE_KEY", + "data": [ + "Customer", + "eSpiel Inc.", + "eSpiel Incorporated" + ] + }, + "id": 3 +} +``` + +Finally, when using the JSON-RPC protocol v1.0: + +```json +{ + "result": null, + "error": [ + "MAP_DUPLICATE_KEY", + "Customer", + "eSpiel Inc.", + "eSpiel Incorporated" + ], + "id": "xyz" +} +``` + +Each possible error code is documented in the following section. + +## Error Codes +{{#errors}} + +### {{{error_code}}} + +{{{error_description}}} + +_Signature:_ + +``` +{{{error_code_unescaped}}}({{parameters}}) +``` +{{/errors}} \ No newline at end of file diff --git a/ocaml/idl/templates/class.mustache b/ocaml/idl/templates/class.mustache new file mode 100644 index 00000000000..1112c851642 --- /dev/null +++ b/ocaml/idl/templates/class.mustache @@ -0,0 +1,89 @@ +--- + layout: doc +--- + +# Class: {{{class_name}}} +{{#class_deprecated}} + +**This class is deprecated.** +{{/class_deprecated}} +{{#class_removed}} + +**This class is removed.** +{{/class_removed}} +{{#has_descr}} + +{{{class_descr}}} +{{/has_descr}} + +## Fields for class: {{{class_name}}} +{{#has_fields}} + +|Field |Type |Qualifier |Description | +|:-------------------|:-------------------|:--------------|:---------------------------------------| +{{/has_fields}} +{{#fields}} +|{{{field_name}}}|{{{field_type}}}|{{{field_ctor}}}|{{#field_deprecated}}**Deprecated.** {{/field_deprecated}}{{#field_removed}}**Removed.** {{/field_removed}}{{{field_descr}}}| +{{/fields}} +{{#is_event}} +|snapshot |object record |_RO/runtime_ |The record of the database object that was added, changed or deleted| +{{/is_event}} +{{^has_fields}} + +Class {{{class_name}}} has no fields. +{{/has_fields}} + +## RPCs associated with class: {{{class_name}}} +{{#all_rpcs}} + +### RPC name: {{{rpc_name_escaped}}} +{{#rpc_deprecated}} + +**This message is deprecated.** +{{/rpc_deprecated}} +{{#rpc_removed}} + +**This message is removed.** +{{/rpc_removed}} + +_Overview:_ +{{#rpc_has_descr}} + +{{{rpc_descr}}} +{{/rpc_has_descr}} + +_Signature:_ + +``` +{{{return_type}}} {{{rpc_name}}} ({{#session}}session ref session_ref{{#has_rpc_params}}, {{/has_rpc_params}}{{/session}}{{{rpc_param_csv}}}) +``` + +_Arguments:_ + +|Type |Name |Description | +|:-----------------------------|:-----------------------------|:---------------------------------------| +{{#session}} +|`session ref` |`session_ref` |Reference to a valid session | +{{/session}} +{{#rpc_params}} +|{{{param_type}}}|{{{param_name}}}|{{{param_descr}}}| +{{/rpc_params}} + +{{#has_rbac}} +_Minimum Role:_ {{min_role}} + +{{/has_rbac}} +_Return Type:_ `{{{return_type}}}` +{{^returns_void}} + +{{{return_descr}}} +{{/returns_void}} +{{#has_error_codes}} + +_Possible Error Codes:_ {{{error_codes_csv}}} +{{/has_error_codes}} +{{/all_rpcs}} +{{^has_rpcs}} + +Class {{{class_name}}} has no RPCs associated with it. +{{/has_rpcs}} \ No newline at end of file diff --git a/ocaml/idl/templates/classes.mustache b/ocaml/idl/templates/classes.mustache new file mode 100644 index 00000000000..3730d77d0bc --- /dev/null +++ b/ocaml/idl/templates/classes.mustache @@ -0,0 +1,13 @@ +--- + layout: doc +--- + +# Classes + +The following classes are defined: + +|Name |Description | +|:-------------------|:---------------------------------------------------------------------| +{{#classes}} +|[{{{name}}}](@root@management-api/class-{{{name_lower}}}.html)|{{{description}}}| +{{/classes}} diff --git a/ocaml/idl/templates/relationships.mustache b/ocaml/idl/templates/relationships.mustache new file mode 100644 index 00000000000..6678c875681 --- /dev/null +++ b/ocaml/idl/templates/relationships.mustache @@ -0,0 +1,18 @@ +--- + layout: doc +--- + +# Relationships Between Classes + +Fields that are bound together are shown in the following table: + +|_object.field_ |_object.field_ |_relationship_ | +|:-------------------------------------|:-------------------------------------|:--------------| +{{#relationships}} +|{{{a_field}}}|{{{b_field}}}|{{relationship}}| +{{/relationships}} + +The following figure represents bound fields (as specified above) using crow's +foot notation to specify one-to-one, one-to-many, or many-to-many relationships: + +![Class relationships](classes.png 'Class relationships') \ No newline at end of file diff --git a/ocaml/idl/templates/toc.mustache b/ocaml/idl/templates/toc.mustache new file mode 100644 index 00000000000..01f81f0982f --- /dev/null +++ b/ocaml/idl/templates/toc.mustache @@ -0,0 +1,15 @@ +- title: API Reference + url: @root@api-ref-autogen.html + subfolderlist: + - title: Classes + url: @root@management-api/classes.html +{{#classes}} + - title: Class:{{{name}}} + url: @root@management-api/class-{{{name_lower}}}.html +{{/classes}} + - title: Relationships Between Classes + url: @root@management-api/relationships-between-classes.html + - title: Types + url: @root@management-api/types.html + - title: Error Handling + url: @root@management-api/api-ref-autogen-errors.html diff --git a/ocaml/idl/templates/types.mustache b/ocaml/idl/templates/types.mustache new file mode 100644 index 00000000000..f1ebc136899 --- /dev/null +++ b/ocaml/idl/templates/types.mustache @@ -0,0 +1,42 @@ +--- + layout: doc +--- + +# Types + +## Primitives + +The following primitive types are used to specify methods and fields in +the API Reference: + +|Type |Description | +|:---------|:-------------------------------------------| +|`string` |text strings | +|`int` |64-bit integers | +|`float` |IEEE double-precision floating-point numbers| +|`bool` |boolean | +|`datetime`|date and timestamp | + +## Higher-order types + +The following type constructors are used: + +|Type |Description | +|:-------------|:-------------------------------------------------------| +|`c ref` |reference to an object of class `c` | +|`t set` |a set of elements of type `t` | +|`(a -> b) map`|a table mapping values of type `a` to values of type `b`| + +## Enumeration types + +The following enumeration types are used: +{{#enums}} + +### Enum {{{enum}}} + +|Named value |Description | +|:---------------------------------------|:----------------------------------------------------| +{{#enum_options}} +|{{{option_name}}}|{{{option_descr}}}| +{{/enum_options}} +{{/enums}} \ No newline at end of file diff --git a/ocaml/libs/ezxenstore/core/dune b/ocaml/libs/ezxenstore/core/dune index 2eabd6bea12..b1b11e8b6a0 100644 --- a/ocaml/libs/ezxenstore/core/dune +++ b/ocaml/libs/ezxenstore/core/dune @@ -1,7 +1,6 @@ (library (name ezxenstore_core) (public_name ezxenstore.core) - (wrapped false) (libraries cmdliner logs diff --git a/ocaml/libs/ezxenstore/lib_test/main.ml b/ocaml/libs/ezxenstore/lib_test/main.ml index 1605fc2ba08..5226f5240aa 100644 --- a/ocaml/libs/ezxenstore/lib_test/main.ml +++ b/ocaml/libs/ezxenstore/lib_test/main.ml @@ -6,7 +6,7 @@ let set_socket_path path = Xs_transport.xenstored_socket := path let test socket = set_socket_path socket ; - let open Xenstore in + let open Ezxenstore_core.Xenstore in if Unix.geteuid () <> 0 then (* non-root won't have access to xenstore *) `Ok 0 else diff --git a/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml b/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml index d65bc43d466..e552ecb1e5a 100644 --- a/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml +++ b/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml @@ -19,7 +19,7 @@ end module Make (Debug : DEBUG) = struct open Debug - open Xenstore + open Ezxenstore_core.Xenstore exception Watch_overflow @@ -46,7 +46,7 @@ module Make (Debug : DEBUG) = struct val watch_fired : Xenctrl.handle - -> Xenstore.Xs.xsh + -> Ezxenstore_core.Xenstore.Xs.xsh -> string -> Xenctrl.domaininfo IntMap.t -> IntSet.t @@ -56,9 +56,11 @@ module Make (Debug : DEBUG) = struct val found_running_domain : int -> string -> unit - val domain_appeared : Xenctrl.handle -> Xenstore.Xs.xsh -> int -> unit + val domain_appeared : + Xenctrl.handle -> Ezxenstore_core.Xenstore.Xs.xsh -> int -> unit - val domain_disappeared : Xenctrl.handle -> Xenstore.Xs.xsh -> int -> unit + val domain_disappeared : + Xenctrl.handle -> Ezxenstore_core.Xenstore.Xs.xsh -> int -> unit end let watch ~xs token path = diff --git a/ocaml/libs/http-lib/client_server_test.sh b/ocaml/libs/http-lib/client_server_test.sh index 6757878f963..601ed257f99 100644 --- a/ocaml/libs/http-lib/client_server_test.sh +++ b/ocaml/libs/http-lib/client_server_test.sh @@ -1,3 +1,5 @@ +#!/bin/bash + set -eux trap 'kill $(jobs -p)' EXIT diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index dfc10dccb15..efa34f0bddd 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -35,6 +35,7 @@ (library (name httpsvr) (wrapped false) + (modes best) (modules http_svr http_proxy server_io) (libraries astring @@ -51,6 +52,7 @@ (tests (names http_test radix_tree_test) (package http-lib) + (modes (best exe)) (modules http_test radix_tree_test) (libraries alcotest diff --git a/ocaml/libs/sexpr/sExpr.ml b/ocaml/libs/sexpr/sExpr.ml index 2976f121f68..ec354e373b1 100644 --- a/ocaml/libs/sexpr/sExpr.ml +++ b/ocaml/libs/sexpr/sExpr.ml @@ -27,6 +27,8 @@ 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 + (* XXX: This escapes "'c'" and "\'c\'" to "\\'c\\'". * They are both unescaped as "'c'". They have been ported * to make sure that this corner case is left unchanged. @@ -36,28 +38,31 @@ let unescape_buf buf s = * that have guaranteed invariants and optimised performances *) let escape s = let open Astring in - let escaped = Buffer.create (String.length s + 10) in - String.iter - (fun c -> - let c' = + if String.exists is_escape_char s then ( + let escaped = Buffer.create (String.length s + 10) in + String.iter + (fun c -> match c with | '\\' -> - "\\\\" + Buffer.add_string escaped "\\\\" | '"' -> - "\\\"" + Buffer.add_string escaped "\\\"" | '\'' -> - "\\\'" + Buffer.add_string escaped "\\\'" | _ -> - Astring.String.of_char c - in - Buffer.add_string escaped c' - ) - s ; - Buffer.contents escaped + Buffer.add_char escaped c + ) + s ; + Buffer.contents escaped + ) else + s let unescape s = - let buf = Buffer.create (String.length s) in - unescape_buf buf s ; Buffer.contents buf + if String.contains s '\\' then ( + let buf = Buffer.create (String.length s) in + unescape_buf buf s ; Buffer.contents buf + ) else + s let mkstring x = String (unescape x) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index 05a0ba27fda..0e1160818c2 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -1,18 +1,26 @@ (library - (name tracing) - (public_name xapi-tracing) - (libraries - cohttp - cohttp-posix - ptime - ptime.clock.os - rpclib.core - rpclib.json - xapi-log - xapi-open-uri - xapi-stdext-threads - xapi-stdext-unix - zstd - ) - (preprocess (pps ppx_deriving_rpc)) -) + (name tracing) + (modules tracing) + (libraries re uri xapi-log xapi-stdext-threads) + (public_name xapi-tracing)) + +(library + (name tracing_export) + (modules tracing_export) + (public_name xapi-tracing-export) + (libraries + cohttp + cohttp-posix + ptime + ptime.clock.os + rpclib.core + rpclib.json + tracing + uri + xapi-log + xapi-open-uri + xapi-stdext-threads + xapi-stdext-unix + zstd) + (preprocess + (pps ppx_deriving_rpc))) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 87326fb65cf..6e1ed32810a 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -88,8 +88,6 @@ let observe = ref true let set_observe mode = observe := mode -let ( let@ ) f x = f x - module SpanKind = struct type t = Server | Consumer | Client | Producer | Internal [@@deriving rpcty] @@ -154,6 +152,8 @@ module SpanContext = struct None let trace_id_of_span_context t = t.trace_id + + let span_id_of_span_context t = t.span_id end module SpanLink = struct @@ -216,6 +216,21 @@ module Span = struct let get_tag t tag = Attributes.find tag t.attributes + let get_name span = span.name + + let get_parent span = span.parent + + let get_span_kind span = span.span_kind + + let get_begin_time span = span.begin_time + + let get_end_time span = span.end_time + + let get_events span = span.events + + let get_attributes span = + Attributes.fold (fun k v tags -> (k, v) :: tags) span.attributes [] + let finish ?(attributes = Attributes.empty) ~span () = let attributes = Attributes.union (fun _k a _b -> Some a) attributes span.attributes @@ -281,6 +296,8 @@ module Spans = struct let spans = Hashtbl.create 100 + let span_count () = Hashtbl.length spans + let max_spans = ref 1000 let set_max_spans x = max_spans := x @@ -591,7 +608,7 @@ let get_tracer ~name = | Some provider -> Tracer.create ~name ~provider | None -> - warn "No provider found for tracing %s" name ; + (* warn "No provider found for tracing %s" name ; *) Tracer.no_op let enable_span_garbage_collector ?(timeout = 86400.) () = @@ -618,314 +635,33 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f = warn "Failed to start tracing: %s" (Printexc.to_string e) ; f None -module Export = struct - let export_interval = ref 30. - - let set_export_interval t = export_interval := t - - let host_id = ref "localhost" - - let set_host_id id = host_id := id - - let service_name = ref None +module EnvHelpers = struct + let traceparent_key = "TRACEPARENT" - let set_service_name name = service_name := Some name - - let get_service_name () = - match !service_name with + let of_traceparent traceparent = + match traceparent with | None -> - warn "service name not yet set!" ; - "unknown" - | Some name -> - name - - module Content = struct - module Json = struct - module Zipkinv2 = struct - module ZipkinSpan = struct - type zipkinEndpoint = {serviceName: string} [@@deriving rpcty] - - type annotation = {timestamp: int; value: string} [@@deriving rpcty] - - type t = { - id: string - ; traceId: string - ; parentId: string option - ; name: string - ; timestamp: int - ; duration: int - ; kind: string option - ; localEndpoint: zipkinEndpoint - ; annotations: annotation list - ; tags: (string * string) list - } - [@@deriving rpcty] - - type t_list = t list [@@deriving rpcty] - - let kind_to_zipkin_kind = function - | SpanKind.Internal -> - None - | k -> - Some k - - let json_of_t_list s = - Rpcmarshal.marshal t_list.Rpc.Types.ty s |> Jsonrpc.to_string - end - - let zipkin_span_of_span (s : Span.t) : ZipkinSpan.t = - let serviceName = get_service_name () in - let annotations = - List.map - (fun event : ZipkinSpan.annotation -> - let timestamp = - int_of_float (event.SpanEvent.time *. 1000000.) - in - let value = event.SpanEvent.name in - {timestamp; value} - ) - s.events - in - { - id= s.context.span_id - ; traceId= s.context.trace_id - ; parentId= Option.map (fun x -> x.Span.context.span_id) s.parent - ; name= s.name - ; timestamp= int_of_float (s.begin_time *. 1000000.) - ; duration= - Option.value s.end_time ~default:(Unix.gettimeofday () *. 1000000.) - -. s.begin_time - |> ( *. ) 1000000. - |> int_of_float - ; kind= - Option.map SpanKind.to_string - (ZipkinSpan.kind_to_zipkin_kind s.span_kind) - ; localEndpoint= {serviceName} - ; annotations - ; tags= - Attributes.fold (fun k v tags -> (k, v) :: tags) s.attributes [] - } - - let content_of (spans : Span.t list) = - List.map zipkin_span_of_span spans |> ZipkinSpan.json_of_t_list - end - end - end - - module Destination = struct - module File = struct - let trace_log_dir = ref "/var/log/dt/zipkinv2/json" - - let max_file_size = ref (1 lsl 20) - - let compress_tracing_files = ref true - - let set_trace_log_dir dir = trace_log_dir := dir - - let get_trace_log_dir () = !trace_log_dir - - let set_max_file_size size = max_file_size := size - - let set_compress_tracing_files enabled = compress_tracing_files := enabled - - let file_name = ref None - - let lock = Mutex.create () - - let new_file_name () = - let date = Ptime_clock.now () |> Ptime.to_rfc3339 ~frac_s:6 in - let ( // ) = Filename.concat in - let name = - !trace_log_dir - // String.concat "-" [get_service_name (); !host_id; date] - ^ ".ndjson" - in - file_name := Some name ; - name - - let with_fd file_name = - Xapi_stdext_unix.Unixext.with_file file_name - [O_WRONLY; O_CREAT; O_APPEND] - 0o700 - - let write fd str = - let content = str ^ "\n" in - ignore @@ Unix.write_substring fd content 0 (String.length content) - - let export json = - try - let file_name = - match !file_name with None -> new_file_name () | Some x -> x - in - Xapi_stdext_unix.Unixext.mkdir_rec (Filename.dirname file_name) 0o700 ; - let@ fd = file_name |> with_fd in - write fd json ; - if (Unix.fstat fd).st_size >= !max_file_size then ( - debug "Tracing: Rotating file %s > %d" file_name !max_file_size ; - if !compress_tracing_files then - Zstd.Fast.compress_file Zstd.Fast.compress ~file_path:file_name - ~file_ext:"zst" ; - ignore @@ new_file_name () - ) ; - Ok () - with e -> Error e - - let with_stream f = - Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () -> f export) - end - - module Http = struct - module Request = Cohttp.Request.Make (Cohttp_posix_io.Buffered_IO) - module Response = Cohttp.Response.Make (Cohttp_posix_io.Buffered_IO) - - let export ~url json = - try - let body = json in - let headers = - Cohttp.Header.of_list - ([ - ("Content-Type", "application/json") - ; ("Content-Length", string_of_int (String.length body)) - ] - @ - match Uri.host url with - | None -> - [] - | Some h -> - let port = - match Uri.port url with - | Some p -> - ":" ^ string_of_int p - | None -> - "" - in - [("Host", h ^ port)] - ) - in - Open_uri.with_open_uri url (fun fd -> - let request = - Cohttp.Request.make ~meth:`POST ~version:`HTTP_1_1 ~headers url - in - let ic = Unix.in_channel_of_descr fd in - let oc = Unix.out_channel_of_descr fd in - Request.write - (fun writer -> Request.write_body writer body) - request oc ; - (* We flush instead of closing the sending stream as nginx responds to a TCP - half-shutdown with a full shutdown of both directions of the HTTP request *) - flush oc ; - match try Response.read ic with _ -> `Eof with - | `Eof -> - Ok () - | `Invalid x -> - Error (Failure ("invalid read: " ^ x)) - | `Ok response - when Cohttp.Code.(response.status |> code_of_status |> is_error) - -> - Error (Failure (Cohttp.Code.string_of_status response.status)) - | `Ok response -> - let body = Buffer.create 128 in - let reader = Response.make_body_reader response ic in - let rec loop () = - match Response.read_body_chunk reader with - | Cohttp.Transfer.Chunk x -> - Buffer.add_string body x ; loop () - | Cohttp.Transfer.Final_chunk x -> - Buffer.add_string body x - | Cohttp.Transfer.Done -> - () - in - loop () ; Ok () - ) - with e -> Error e - end - - let export_to_endpoint parent traces endpoint = - debug "Tracing: About to export" ; - try - File.with_stream (fun file_export -> - let export, name = - match endpoint with - | Url url -> - (Http.export ~url, "Tracing.Http.export") - | Bugtool -> - (file_export, "Tracing.File.export") - in - let all_spans = - Hashtbl.fold (fun _ spans acc -> spans @ acc) traces [] - in - let attributes = - [ - ("export.span.count", List.length all_spans |> string_of_int) - ; ("export.endpoint", endpoint_to_string endpoint) - ; ( "xs.tracing.spans_table.count" - , Hashtbl.length Spans.spans |> string_of_int - ) - ; ( "xs.tracing.finished_spans_table.count" - , Hashtbl.length traces |> string_of_int - ) - ] - in - let@ _ = with_tracing ~parent ~attributes ~name in - Content.Json.Zipkinv2.content_of all_spans - |> export - |> Result.iter_error raise - ) - with exn -> - debug "Tracing: unable to export span : %s" (Printexc.to_string exn) + [] + | Some traceparent -> + [String.concat "=" [traceparent_key; traceparent]] - let flush_spans () = - let span_list = Spans.since () in - let attributes = - [("export.traces.count", Hashtbl.length span_list |> string_of_int)] - in - let@ parent = - with_tracing ~parent:None ~attributes ~name:"Tracing.flush_spans" - in - get_tracer_providers () - |> List.filter (fun x -> x.TracerProvider.enabled) - |> List.concat_map (fun x -> TracerProvider.get_endpoints x) - |> List.iter (export_to_endpoint parent span_list) - - let delay = Delay.make () - - (* Note this signal will flush the spans and terminate the exporter thread *) - let signal () = Delay.signal delay - - let create_exporter () = - enable_span_garbage_collector () ; - Thread.create - (fun () -> - let signaled = ref false in - while not !signaled do - debug "Tracing: Waiting %d seconds before exporting spans" - (int_of_float !export_interval) ; - if not (Delay.wait delay !export_interval) then ( - debug "Tracing: we are signaled, export spans now and exit" ; - signaled := true - ) ; - flush_spans () - done - ) - () - - let exporter = ref None - - let lock = Mutex.create () + let to_traceparent env = + let env_opt = + List.find_opt (String.starts_with ~prefix:traceparent_key) env + in + Option.bind env_opt (fun key_value -> + match String.split_on_char '=' key_value with + | [key; traceparent] when String.equal key traceparent_key -> + Some traceparent + | _ -> + None + ) - let main () = - Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () -> - match !exporter with - | None -> - let tid = create_exporter () in - exporter := Some tid ; - tid - | Some tid -> - tid - ) - end + let of_span span = + match span with + | None -> + [] + | Some span -> + Some (span |> Span.get_context |> SpanContext.to_traceparent) + |> of_traceparent end - -let flush_and_exit = Export.Destination.signal - -let main = Export.Destination.main diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index ee30b29f041..b7f33b6d051 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -34,12 +34,24 @@ module SpanKind : sig val to_string : t -> string end +module Attributes : sig + include Map.S with type key := String.t + + val of_list : (string * 'a) list -> 'a t + + val to_assoc_list : 'a t -> (string * 'a) list +end + module Status : sig type status_code type t end +module SpanEvent : sig + type t = {name: string; time: float; attributes: string Attributes.t} +end + module SpanContext : sig type t @@ -48,6 +60,8 @@ module SpanContext : sig val of_traceparent : string -> t option val trace_id_of_span_context : t -> string + + val span_id_of_span_context : t -> string end module Span : sig @@ -61,9 +75,23 @@ module Span : sig val add_event : t -> string -> (string * string) list -> t + val get_events : t -> SpanEvent.t list + val set_span_kind : t -> SpanKind.t -> t + val get_span_kind : t -> SpanKind.t + val get_tag : t -> string -> string + + val get_name : t -> string + + val get_parent : t -> t option + + val get_begin_time : t -> float + + val get_end_time : t -> float option + + val get_attributes : t -> (string * string) list end module Spans : sig @@ -71,6 +99,10 @@ module Spans : sig val set_max_traces : int -> unit + val span_count : unit -> int + + val since : unit -> (string, Span.t list) Hashtbl.t + val dump : unit -> (string, Span.t list) Hashtbl.t * (string, Span.t list) Hashtbl.t end @@ -133,6 +165,8 @@ val get_tracer_providers : unit -> TracerProvider.t list val get_tracer : name:string -> Tracer.t +val enable_span_garbage_collector : ?timeout:float -> unit -> unit + val with_tracing : ?attributes:(string * string) list -> ?parent:Span.t option @@ -140,36 +174,37 @@ val with_tracing : -> (Span.t option -> 'a) -> 'a -module Export : sig - val set_export_interval : float -> unit - - val set_host_id : string -> unit - - val set_service_name : string -> unit - - module Destination : sig - module File : sig - val set_max_file_size : int -> unit - - val set_trace_log_dir : string -> unit - - val get_trace_log_dir : unit -> string - - val set_compress_tracing_files : bool -> unit - end - - val flush_spans : unit -> unit - - module Http : sig - val export : url:Uri.t -> string -> (unit, exn) result - end - end -end - val set_observe : bool -> unit val validate_attribute : string * string -> bool -val flush_and_exit : unit -> unit - -val main : unit -> Thread.t +(** [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. + *) + + 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 + [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 + string list of environmental variables [env_var_lst]. If there is no such + evironmental variable in the list, it returns [None]. + *) + + val of_span : Span.t option -> string list + (** [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 new file mode 100644 index 00000000000..a769b2403bc --- /dev/null +++ b/ocaml/libs/tracing/tracing_export.ml @@ -0,0 +1,328 @@ +(* + * Copyright (C) 2024 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module D = Debug.Make (struct let name = "tracing_export" end) + +module Delay = Xapi_stdext_threads.Threadext.Delay +open D +open Tracing + +let ( let@ ) f x = f x + +let export_interval = ref 30. + +let set_export_interval t = export_interval := t + +let host_id = ref "localhost" + +let set_host_id id = host_id := id + +let service_name = ref "unknown" + +let set_service_name name = service_name := name + +let get_service_name () = !service_name + +module Content = struct + module Json = struct + module ZipkinV2 = struct + (* Module that helps export spans under Zipkin protocol, version 2. *) + module ZipkinSpan = struct + type zipkinEndpoint = {serviceName: string} [@@deriving rpcty] + + type annotation = {timestamp: int; value: string} [@@deriving rpcty] + + type t = { + id: string + ; traceId: string + ; parentId: string option + ; name: string + ; timestamp: int + ; duration: int + ; kind: string option + ; localEndpoint: zipkinEndpoint + ; annotations: annotation list + ; tags: (string * string) list + } + [@@deriving rpcty] + + type t_list = t list [@@deriving rpcty] + + let kind_to_zipkin_kind = function + | SpanKind.Internal -> + None + | k -> + Some k + + let json_of_t_list s = + Rpcmarshal.marshal t_list.Rpc.Types.ty s |> Jsonrpc.to_string + end + + let zipkin_span_of_span (s : Span.t) : ZipkinSpan.t = + let serviceName = get_service_name () in + let annotations = + s + |> Span.get_events + |> List.map (fun event : ZipkinSpan.annotation -> + let timestamp = + int_of_float (event.SpanEvent.time *. 1000000.) + in + let value = event.SpanEvent.name in + {timestamp; value} + ) + in + { + id= s |> Span.get_context |> SpanContext.span_id_of_span_context + ; traceId= s |> Span.get_context |> SpanContext.trace_id_of_span_context + ; parentId= + s + |> Span.get_parent + |> Option.map (fun x -> + x |> Span.get_context |> SpanContext.span_id_of_span_context + ) + ; name= s |> Span.get_name + ; timestamp= int_of_float (Span.get_begin_time s *. 1000000.) + ; duration= + Option.value (Span.get_end_time s) + ~default:(Unix.gettimeofday () *. 1000000.) + -. Span.get_begin_time s + |> ( *. ) 1000000. + |> int_of_float + ; kind= + s + |> Span.get_span_kind + |> ZipkinSpan.kind_to_zipkin_kind + |> Option.map SpanKind.to_string + ; localEndpoint= {serviceName} + ; annotations + ; tags= Span.get_attributes s + } + + let content_of (spans : Span.t list) = + List.map zipkin_span_of_span spans |> ZipkinSpan.json_of_t_list + end + end +end + +module Destination = struct + module File = struct + let trace_log_dir = ref "/var/log/dt/zipkinv2/json" + + let max_file_size = ref (1 lsl 20) + + let compress_tracing_files = ref true + + let set_trace_log_dir dir = trace_log_dir := dir + + let get_trace_log_dir () = !trace_log_dir + + let set_max_file_size size = max_file_size := size + + let set_compress_tracing_files enabled = compress_tracing_files := enabled + + let file_name = ref None + + let lock = Mutex.create () + + let make_file_name () = + let date = Ptime_clock.now () |> Ptime.to_rfc3339 ~frac_s:6 in + let ( // ) = Filename.concat in + let name = + !trace_log_dir + // String.concat "-" [get_service_name (); !host_id; date] + ^ ".ndjson" + in + file_name := Some name ; + name + + let with_fd file_name = + Xapi_stdext_unix.Unixext.with_file file_name + [O_WRONLY; O_CREAT; O_APPEND] + 0o700 + + let write fd str = + let content = str ^ "\n" in + ignore @@ Unix.write_substring fd content 0 (String.length content) + + let export json = + try + let file_name = + match !file_name with None -> make_file_name () | Some x -> x + in + Xapi_stdext_unix.Unixext.mkdir_rec (Filename.dirname file_name) 0o700 ; + let@ fd = file_name |> with_fd in + write fd json ; + if (Unix.fstat fd).st_size >= !max_file_size then ( + debug "Tracing: Rotating file %s > %d" file_name !max_file_size ; + if !compress_tracing_files then + Zstd.Fast.compress_file Zstd.Fast.compress ~file_path:file_name + ~file_ext:"zst" ; + ignore @@ make_file_name () + ) ; + Ok () + with e -> Error e + + let with_stream f = + Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () -> f export) + end + + module Http = struct + module Request = Cohttp.Request.Make (Cohttp_posix_io.Buffered_IO) + module Response = Cohttp.Response.Make (Cohttp_posix_io.Buffered_IO) + + let export ~url json = + try + let body = json in + let content_headers = + [ + ("Content-Type", "application/json") + ; ("Content-Length", string_of_int (String.length body)) + ] + in + let host = + match (Uri.host url, Uri.port url) with + | None, _ -> + None + | Some host, None -> + Some host + | Some host, Some port -> + Some (Printf.sprintf "%s:%d" host port) + in + let host_headers = + Option.fold ~none:[] ~some:(fun h -> [("Host", h)]) host + in + let headers = + List.concat [content_headers; host_headers] |> Cohttp.Header.of_list + in + + Open_uri.with_open_uri url (fun fd -> + let request = + Cohttp.Request.make ~meth:`POST ~version:`HTTP_1_1 ~headers url + in + (* `with_open_uri` already closes the `fd`. And therefore + according to the documentation of `in_channel_of_descr` and + `out_channel_of_descr` we should not close the channels on top of + `fd`. *) + let ic = Unix.in_channel_of_descr fd in + let oc = Unix.out_channel_of_descr fd in + Request.write + (fun writer -> Request.write_body writer body) + request oc ; + (* We flush instead of closing the sending stream as nginx responds to a TCP + half-shutdown with a full shutdown of both directions of the HTTP request *) + flush oc ; + match try Response.read ic with _ -> `Eof with + | `Eof -> + Ok () + | `Invalid x -> + Error (Failure ("invalid read: " ^ x)) + | `Ok response + when Cohttp.Code.(response.status |> code_of_status |> is_error) + -> + Error (Failure (Cohttp.Code.string_of_status response.status)) + | `Ok _ -> + Ok () + ) + with e -> Error e + end + + let export_to_endpoint parent traces endpoint = + debug "Tracing: About to export" ; + try + File.with_stream (fun file_export -> + let export, name = + match endpoint with + | Url url -> + (Http.export ~url, "Tracing.Http.export") + | Bugtool -> + (file_export, "Tracing.File.export") + in + let all_spans = + Hashtbl.fold (fun _ spans acc -> spans @ acc) traces [] + in + let attributes = + [ + ("export.span.count", all_spans |> List.length |> string_of_int) + ; ("export.endpoint", endpoint_to_string endpoint) + ; ( "xs.tracing.spans_table.count" + , Spans.span_count () |> string_of_int + ) + ; ( "xs.tracing.finished_spans_table.count" + , traces |> Hashtbl.length |> string_of_int + ) + ] + in + let@ _ = with_tracing ~parent ~attributes ~name in + all_spans + |> Content.Json.ZipkinV2.content_of + |> export + |> Result.iter_error raise + ) + with exn -> + debug "Tracing: unable to export span : %s" (Printexc.to_string exn) + + let flush_spans () = + let span_list = Spans.since () in + let attributes = + [("export.traces.count", Hashtbl.length span_list |> string_of_int)] + in + let@ parent = + with_tracing ~parent:None ~attributes ~name:"Tracing.flush_spans" + in + get_tracer_providers () + |> List.filter TracerProvider.get_enabled + |> List.concat_map TracerProvider.get_endpoints + |> List.iter (export_to_endpoint parent span_list) + + let delay = Delay.make () + + (* Note this signal will flush the spans and terminate the exporter thread *) + let signal () = Delay.signal delay + + let create_exporter () = + enable_span_garbage_collector () ; + Thread.create + (fun () -> + let signaled = ref false in + while not !signaled do + debug "Tracing: Waiting %d seconds before exporting spans" + (int_of_float !export_interval) ; + if not (Delay.wait delay !export_interval) then ( + debug "Tracing: we are signaled, export spans now and exit" ; + signaled := true + ) ; + flush_spans () + done + ) + () + + let exporter = ref None + + let lock = Mutex.create () + + let main () = + Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () -> + match !exporter with + | None -> + let tid = create_exporter () in + exporter := Some tid ; + tid + | Some tid -> + tid + ) +end + +let flush_and_exit = Destination.signal + +let main = Destination.main diff --git a/ocaml/libs/tracing/tracing_export.mli b/ocaml/libs/tracing/tracing_export.mli new file mode 100644 index 00000000000..3f8ca750026 --- /dev/null +++ b/ocaml/libs/tracing/tracing_export.mli @@ -0,0 +1,95 @@ +(* +* Copyright (C) 2024 Cloud Software Group +* +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU Lesser General Public License as published +* by the Free Software Foundation; version 2.1 only. with the special +* exception on linking described in file LICENSE. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU Lesser General Public License for more details. +*) + +(** [Tracing_export] is a module dedicated for the creation and management of + threads that export the tracing data. + *) + +val set_export_interval : float -> unit +(** [set_export_interval seconds] sets the time interval between consecutive + exports of the finished spans to [seconds]. + + Default is every [30.] seconds. + *) + +val set_host_id : string -> unit +(** [set_host_id id] sets the id of the host to [id]. + + Default is ["localhost"]. + *) + +val set_service_name : string -> unit +(** [set_service_name name] sets the name of the service to [name]. + All spans will be exported under this service's name. + + Default name is ["unknown"]. + *) + +(** [Destination] is a module for managing the export of tracing data to + different types of endpoints, whether is exporting it to a [File] or an + [Http] endpoint. + *) +module Destination : sig + (** [File] is a module for managing the files in which the tracing data is + exported. + *) + module File : sig + val set_max_file_size : int -> unit + (** [set_max_file_size n] sets the maximum file size to [n]. If a file is + is already created at the time of export and the file exceeds the + maximum size, a new tracing file is created. + *) + + val set_trace_log_dir : string -> unit + (** [set_trace_log_dir log_dir] sets the location to which traces will be + exported. + + Default is ["/var/log/dt/zipkinv2/json"] + *) + + val get_trace_log_dir : unit -> string + (** [get_trace_log_dir ()] returns the cuurent location to which traces are + exported. + *) + + val set_compress_tracing_files : bool -> unit + (** [set_compress_tracing_files flag] sets wheater or not the tracing files + are compressed or not. + *) + end + + val flush_spans : unit -> unit + (** [flush_spans ()] forcefully flushes the spans to the current enabled + endpoints. + *) + + (** [Http] is a module for managing exporting tracing data to an http + endpoint. + *) + module Http : sig + val export : url:Uri.t -> string -> (unit, exn) result + (** [export ~url json] forcefully flushes json formatted spans [json] to the + given [url] . + *) + 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 main : unit -> Thread.t +(** [main ()] starts the exporter thread. + *) diff --git a/ocaml/libs/uuid/uuidx.ml b/ocaml/libs/uuid/uuidx.ml index de471da0e1b..01dbda46899 100644 --- a/ocaml/libs/uuid/uuidx.ml +++ b/ocaml/libs/uuid/uuidx.ml @@ -83,3 +83,15 @@ let string_of_uuid = to_string let uuid_of_int_array = of_int_array let int_array_of_uuid = to_int_array + +module Hash = struct + (** Derive a deterministic UUID from a string: the same + string maps to the same UUID. We are using our own namespace; the + namespace is not a secret *) + + let namespace = + let ns = "e93e0639-2bdb-4a59-8b46-352b3f408c19" in + Uuidm.(of_string ns |> Option.get) + + let string str = Uuidm.v5 namespace str +end diff --git a/ocaml/libs/uuid/uuidx.mli b/ocaml/libs/uuid/uuidx.mli index 57b4058b8ca..618235b4ae6 100644 --- a/ocaml/libs/uuid/uuidx.mli +++ b/ocaml/libs/uuid/uuidx.mli @@ -81,3 +81,11 @@ val make_cookie : unit -> cookie val cookie_of_string : string -> cookie val string_of_cookie : cookie -> string + +module Hash : sig + (** hash a string (deterministically) into a UUID. This uses + namespace UUID e93e0639-2bdb-4a59-8b46-352b3f408c19. *) + + (* UUID Version 5 derived from argument string and namespace UUID *) + val string : string -> 'a t +end diff --git a/ocaml/message-switch/.coverage.sh b/ocaml/message-switch/.coverage.sh deleted file mode 100644 index 2c8f7be72b7..00000000000 --- a/ocaml/message-switch/.coverage.sh +++ /dev/null @@ -1,34 +0,0 @@ -#!/bin/bash - -set -ex - -COVERAGE_DIR=.coverage -rm -rf $COVERAGE_DIR -mkdir -p $COVERAGE_DIR -pushd $COVERAGE_DIR -if [ -z "$KEEP" ]; then trap "popd; rm -rf $COVERAGE_DIR" EXIT; fi - -$(which cp) -r ../* . - -opam pin add bisect_ppx 1.3.3 -y -opam install ocveralls -y - -# install test deps -opam install message-switch-async cohttp-async -y - -export BISECT_ENABLE=YES -jbuilder runtest - -outs=($(find . | grep bisect.*.out)) -bisect-ppx-report -I $(dirname ${outs[1]}) -text report ${outs[@]} -bisect-ppx-report -I $(dirname ${outs[1]}) -summary-only -text summary ${outs[@]} -if [ -n "$HTML" ]; then bisect-ppx-report -I $(dirname ${outs[1]}) -html ../html-report ${outs[@]}; fi - -if [ -n "$TRAVIS" ]; then - echo "\$TRAVIS set; running ocveralls and sending to coveralls.io..." - ocveralls --prefix _build/default ${outs[@]} --send -else - echo "\$TRAVIS not set; displaying results of bisect-report..." - cat report - cat summary -fi diff --git a/ocaml/message-switch/async/protocol_async.ml b/ocaml/message-switch/async/protocol_async.ml index 9ec9cc42b74..5898d22f77f 100644 --- a/ocaml/message-switch/async/protocol_async.ml +++ b/ocaml/message-switch/async/protocol_async.ml @@ -30,9 +30,16 @@ module M = struct let iter f t = Deferred.List.iter t ~f + let iter_dontwait f t = + Deferred.don't_wait_for @@ Deferred.List.iter ~how:`Parallel t ~f + let any = Deferred.any + let all = Deferred.all + let is_determined = Deferred.is_determined + + let return_unit = Deferred.unit end let connect path = @@ -95,6 +102,20 @@ module M = struct ) end + module Condition = struct + open Async_kernel + + type 'a t = 'a Condition.t + + let create = Condition.create + + let wait = Condition.wait + + let broadcast = Condition.broadcast + + let signal = Condition.signal + end + module Clock = struct type timer = {cancel: unit Ivar.t} @@ -117,3 +138,4 @@ end module Client = Message_switch_core.Make.Client (M) module Server = Message_switch_core.Make.Server (M) +module Mtest = Message_switch_core.Mtest.Make (M) diff --git a/ocaml/message-switch/async/protocol_async.mli b/ocaml/message-switch/async/protocol_async.mli index f691c24c989..d18b37b742c 100644 --- a/ocaml/message-switch/async/protocol_async.mli +++ b/ocaml/message-switch/async/protocol_async.mli @@ -19,3 +19,5 @@ open Message_switch_core module Client : S.CLIENT with type 'a io = 'a Deferred.t module Server : S.SERVER with type 'a io = 'a Deferred.t + +module Mtest : Mtest.MTEST with type 'a io = 'a Deferred.t diff --git a/ocaml/message-switch/cli/dune b/ocaml/message-switch/cli/dune index beb3741dc85..c0741e71348 100644 --- a/ocaml/message-switch/cli/dune +++ b/ocaml/message-switch/cli/dune @@ -5,6 +5,7 @@ cmdliner message-switch-core message-switch-unix + mtime rpclib.core rpclib.json threads.posix diff --git a/ocaml/message-switch/cli/main.ml b/ocaml/message-switch/cli/main.ml index 197061a17ea..19324a5a25f 100644 --- a/ocaml/message-switch/cli/main.ml +++ b/ocaml/message-switch/cli/main.ml @@ -76,23 +76,36 @@ let help = ; `P (Printf.sprintf "Check bug reports at %s" project_url) ] +(* Durations, in nanoseconds *) +let second = 1_000_000_000L + +let minute = 60_000_000_000L + +let hour = 3600_000_000_000L + +let day = 86400_000_000_000L + (* Commands *) let diagnostics common_opts = Client.connect ~switch:common_opts.Common.path () >>|= fun t -> Client.diagnostics ~t () >>|= fun d -> let open Message_switch_core.Protocol in - let in_the_past = Int64.sub d.Diagnostics.current_time in + let in_the_past ts = + if d.Diagnostics.current_time < ts then + 0L + else + Int64.sub d.Diagnostics.current_time ts + in let time f x = - let open Int64 in - let secs = div (f x) 1_000_000_000L in - let secs' = rem secs 60L in - let mins = div secs 60L in - let mins' = rem mins 60L in - let hours = div mins 60L in - let hours' = rem hours 24L in - let days = div hours 24L in - let fragment name = function + let timespan = f x in + let ( // ) = Int64.div in + let ( %% ) = Int64.rem in + let secs = timespan %% minute // second in + let mins = timespan %% hour // minute in + let hours = timespan %% day // hour in + let days = timespan // day in + let format name = function | 0L -> [] | 1L -> @@ -101,11 +114,10 @@ let diagnostics common_opts = [Printf.sprintf "%Ld %ss" n name] in let bits = - fragment "day" days - @ fragment "hour" hours' - @ fragment "min" mins' - @ fragment "second" secs' - @ [] + format "day" days + @ format "hour" hours + @ format "min" mins + @ format "second" secs in let length = List.length bits in let _, rev_bits = @@ -122,7 +134,16 @@ let diagnostics common_opts = ) (0, []) bits in - String.concat "" (List.rev rev_bits) ^ "ago" + let format_secs ts = + Mtime.Span.(Format.asprintf "%a " pp (of_uint64_ns ts)) + in + let timestrings = + if rev_bits = [] then + [format_secs (timespan %% minute)] + else + List.rev rev_bits + in + String.concat "" timestrings ^ "ago" in let origin = function | Anonymous id -> diff --git a/ocaml/message-switch/core/dune b/ocaml/message-switch/core/dune index 676fa3f20ee..6debbc895c7 100644 --- a/ocaml/message-switch/core/dune +++ b/ocaml/message-switch/core/dune @@ -9,6 +9,8 @@ sexplib sexplib0 uri + xapi-log + xapi-stdext-threads ) (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) ) diff --git a/ocaml/message-switch/core/make.ml b/ocaml/message-switch/core/make.ml index 54e8904e1a9..224012909ac 100644 --- a/ocaml/message-switch/core/make.ml +++ b/ocaml/message-switch/core/make.ml @@ -16,6 +16,10 @@ open Sexplib.Std open Protocol +module D = Debug.Make (struct let name = "Message_switch.make" end) + +open D + module Connection = functor (IO : Cohttp.S.IO) @@ -406,4 +410,92 @@ functor in let _ = loop c None in return (Ok t) + + let listen_p ~process ~switch:port ~queue:name () = + let token = Printf.sprintf "%d" (Unix.getpid ()) in + let protect_connect path f = + M.connect path >>= fun conn -> + f conn >>= function + | Ok _ as ok -> + return ok + | Error _ as err -> + M.disconnect conn >>= fun () -> return err + in + let reconnect () = + protect_connect port @@ fun request_conn -> + Connection.rpc request_conn (In.Login token) >>|= fun (_ : string) -> + protect_connect port @@ fun reply_conn -> + Connection.rpc reply_conn (In.Login token) >>|= fun (_ : string) -> + return (Ok (request_conn, reply_conn)) + in + reconnect () >>|= fun ((request_conn, reply_conn) as c) -> + let request_shutdown = M.Ivar.create () in + let on_shutdown = M.Ivar.create () in + let mutex = M.Mutex.create () in + Connection.rpc request_conn (In.CreatePersistent name) >>|= fun _ -> + let t = {request_shutdown; on_shutdown} in + let reconnect () = + M.disconnect request_conn >>= fun () -> + M.disconnect reply_conn >>= reconnect + in + let rec loop c from = + let transfer = {In.from; timeout; queues= [name]} in + let frame = In.Transfer transfer in + let message = Connection.rpc request_conn frame in + any [map (fun _ -> ()) message; M.Ivar.read request_shutdown] + >>= fun () -> + if is_determined (M.Ivar.read request_shutdown) then ( + M.Ivar.fill on_shutdown () ; return (Ok ()) + ) else + message >>= function + | Error _e -> + M.Mutex.with_lock mutex reconnect >>|= fun c -> loop c from + | Ok raw -> ( + let transfer = Out.transfer_of_rpc (Jsonrpc.of_string raw) in + let print_error = function + | Ok (_ : string) -> + return () + | Error _ as err -> + error "message switch reply received error" ; + ignore @@ error_to_msg err ; + return () + in + match transfer.Out.messages with + | [] -> + loop c from + | _ :: _ -> + iter_dontwait + (fun (i, m) -> + process m.Message.payload >>= fun response -> + ( match m.Message.kind with + | Message.Response _ -> + return () (* configuration error *) + | Message.Request reply_to -> + let request = + In.Send + ( reply_to + , { + Message.kind= Message.Response i + ; payload= response + } + ) + in + M.Mutex.with_lock mutex (fun () -> + Connection.rpc reply_conn request + ) + >>= print_error + ) + >>= fun () -> + let request = In.Ack i in + M.Mutex.with_lock mutex (fun () -> + Connection.rpc reply_conn request + ) + >>= print_error + ) + transfer.Out.messages ; + loop c (Some transfer.Out.next) + ) + in + let _ = loop c None in + return (Ok t) end diff --git a/ocaml/message-switch/core/mtest.ml b/ocaml/message-switch/core/mtest.ml new file mode 100644 index 00000000000..3b8da9803fe --- /dev/null +++ b/ocaml/message-switch/core/mtest.ml @@ -0,0 +1,42 @@ +module type MTEST = sig + type +'a io + + val mutex_provides_mutal_exclusion : unit -> unit io +end + +module Make = +functor + (M : S.BACKEND) + -> + struct + open M.IO + + type 'a io = 'a M.IO.t + + let ocaml_lock = Mutex.create () + + let mu = M.Mutex.create () + + let cond = M.Condition.create () + + let broadcast () = M.Condition.broadcast cond () + + let mutex_provides_mutal_exclusion () : unit io = + let promises = + List.init 100 (fun _ -> + M.Condition.wait cond >>= fun () -> + M.Mutex.with_lock mu (fun () -> + M.IO.return_unit >>= fun () -> + (* the with_lock implementation should ensure that only one + monad can try to acquire this lock *) + assert (Mutex.try_lock ocaml_lock) ; + M.IO.return_unit >>= fun () -> + Mutex.unlock ocaml_lock ; M.IO.return_unit + ) + ) + in + broadcast () ; + ignore @@ all promises ; + Printf.printf "%s test.\n" (M.whoami ()) ; + M.IO.return_unit + end diff --git a/ocaml/message-switch/core/s.ml b/ocaml/message-switch/core/s.ml index f99e0582687..423304d1b24 100644 --- a/ocaml/message-switch/core/s.ml +++ b/ocaml/message-switch/core/s.ml @@ -29,9 +29,15 @@ module type BACKEND = sig val iter : ('a -> unit t) -> 'a list -> unit t + val iter_dontwait : ('a -> unit t) -> 'a list -> unit + val any : 'a t list -> 'a t + val all : 'a t list -> 'a list t + val is_determined : 'a t -> bool + + val return_unit : unit t end val connect : string -> (IO.ic * IO.oc) IO.t @@ -56,6 +62,18 @@ module type BACKEND = sig val with_lock : t -> (unit -> 'a IO.t) -> 'a IO.t end + module Condition : sig + type 'a t + + val create : unit -> 'a t + + val wait : 'a t -> 'a IO.t + + val broadcast : 'a t -> 'a -> unit + + val signal : 'a t -> 'a -> unit + end + module Clock : sig type timer @@ -89,6 +107,14 @@ module type SERVER = sig (** Connect to [switch] and start processing messages on [queue] via function [process] *) + val listen_p : + process:(string -> string io) + -> switch:string + -> queue:string + -> unit + -> t result io + (** same as above, but processes requests concurrently *) + val shutdown : t:t -> unit -> unit io (** [shutdown t] shutdown a server *) end diff --git a/ocaml/message-switch/core_test/async/server_async_main.ml b/ocaml/message-switch/core_test/async/server_async_main.ml index 2372cb34c98..cd7984bec27 100644 --- a/ocaml/message-switch/core_test/async/server_async_main.ml +++ b/ocaml/message-switch/core_test/async/server_async_main.ml @@ -23,6 +23,8 @@ let path = ref "/var/run/message-switch/sock" let name = ref "server" +let concurrent = ref false + let shutdown = Ivar.create () let process = function @@ -33,7 +35,10 @@ let process = function let main () = let (_ : 'a Deferred.t) = - Server.listen ~process ~switch:!path ~queue:!name () + if !concurrent then + Server.listen_p ~process ~switch:!path ~queue:!name () + else + Server.listen ~process ~switch:!path ~queue:!name () in Ivar.read shutdown >>= fun () -> Clock.after (Time.Span.of_sec 1.) >>= fun () -> exit 0 @@ -49,6 +54,11 @@ let _ = , Arg.Set_string name , Printf.sprintf "name to send message to (default %s)" !name ) + ; ( "-concurrent" + , Arg.Set concurrent + , Printf.sprintf "set concurrent processing of messages (default %b)" + !concurrent + ) ] (fun x -> P.fprintf stderr "Ignoring unexpected argument: %s" x) "Respond to RPCs on a name" ; diff --git a/ocaml/message-switch/core_test/basic-rpc-test.sh b/ocaml/message-switch/core_test/basic-rpc-test.sh index e73c3a873d1..877790370a2 100755 --- a/ocaml/message-switch/core_test/basic-rpc-test.sh +++ b/ocaml/message-switch/core_test/basic-rpc-test.sh @@ -1,12 +1,14 @@ #!/bin/bash set -e -SPATH=${TMPDIR:-/tmp}/sock -SWITCHPATH=${TMPDIR:-/tmp}/switch +SPATH=${TMPDIR:-/tmp}/sock_s +SWITCHPATH=${TMPDIR:-/tmp}/switch_s rm -rf ${SWITCHPATH} && mkdir -p ${SWITCHPATH} +echo Test message switch serial processing + echo Checking the switch can start late ./server_unix_main.exe -path $SPATH & sleep 1 diff --git a/ocaml/message-switch/core_test/concur-rpc-test.sh b/ocaml/message-switch/core_test/concur-rpc-test.sh new file mode 100755 index 00000000000..a91768972fe --- /dev/null +++ b/ocaml/message-switch/core_test/concur-rpc-test.sh @@ -0,0 +1,45 @@ +#!/bin/bash +set -e + +SPATH="${TMPDIR:-/tmp}/sock_p-$$" +SWITCHPATH="${TMPDIR:-/tmp}/switch_p-$$" + +trap "cleanup" TERM INT + +function cleanup { + rm -rf "${SWITCHPATH}" +} + +rm -rf "${SWITCHPATH}" && mkdir -p "${SWITCHPATH}" + +echo Test message switch concurrent processing + +echo Checking the switch can start late +test -x ./server_unix_main.exe || exit 1 +./server_unix_main.exe -path "$SPATH" & +sleep 1 +test -x ../switch/switch_main.exe && test -x ./client_unix_main.exe || exit 1 +../switch/switch_main.exe --path "$SPATH" --statedir "${SWITCHPATH}" & +./client_unix_main.exe -path "$SPATH" -secs 5 +sleep 2 + +echo Performance test of Lwt to Lwt +test -x lwt/server_main.exe && test -x lwt/client_main.exe || exit 1 +lwt/server_main.exe -path "$SPATH" -concurrent & +lwt/client_main.exe -path "$SPATH" -secs 5 +sleep 2 + +echo Performance test of Async to Lwt +test -x lwt/server_main.exe && test -x async/client_async_main.exe || exit 1 +lwt/server_main.exe -path "$SPATH" -concurrent & +async/client_async_main.exe -path "$SPATH" -secs 5 +sleep 2 + +echo Performance test of Async to Async +test -x async/server_async_main.exe && test -x async/client_async_main.exe || exit 1 +async/server_async_main.exe -path "$SPATH" -concurrent & +async/client_async_main.exe -path "$SPATH" -secs 5 +sleep 2 + +../cli/main.exe shutdown --path "$SPATH" +sleep 2 diff --git a/ocaml/message-switch/core_test/dune b/ocaml/message-switch/core_test/dune index d500c101354..449f2fae5c5 100644 --- a/ocaml/message-switch/core_test/dune +++ b/ocaml/message-switch/core_test/dune @@ -3,13 +3,43 @@ (names client_unix_main server_unix_main + lock_test_async + lock_test_lwt + ) + (modules + client_unix_main + server_unix_main + lock_test_async + lock_test_lwt ) (libraries message-switch-unix + message-switch-core + message-switch-async + message-switch-lwt threads.posix ) ) +(rule + (alias runtest) + (deps + lock_test_async.exe + ) + (action (run ./lock_test_async.exe)) + (package message-switch) +) + +(rule + (alias runtest) + (deps + lock_test_lwt.exe + ) + (action (run ./lock_test_lwt.exe)) + (package message-switch) +) + + (rule (alias runtest) (deps @@ -27,3 +57,20 @@ (package message-switch) ) +(rule + (alias runtest) + (deps + client_unix_main.exe + server_unix_main.exe + async/client_async_main.exe + async/server_async_main.exe + lwt/client_main.exe + lwt/server_main.exe + lwt/link_test_main.exe + ../switch/switch_main.exe + ../cli/main.exe + ) + (action (run ./concur-rpc-test.sh)) + (package message-switch) +) + diff --git a/ocaml/message-switch/core_test/lock_test_async.ml b/ocaml/message-switch/core_test/lock_test_async.ml new file mode 100644 index 00000000000..85cde8eaecb --- /dev/null +++ b/ocaml/message-switch/core_test/lock_test_async.ml @@ -0,0 +1,13 @@ +open Core +open Async +open Message_switch_async + +let ( >>= ) = Deferred.( >>= ) + +let test_async_lock () = Protocol_async.Mtest.mutex_provides_mutal_exclusion () + +let () = + don't_wait_for + (test_async_lock () >>= fun () -> shutdown 0 ; Deferred.return ()) + +let () = never_returns (Scheduler.go ()) diff --git a/ocaml/message-switch/core_test/lock_test_lwt.ml b/ocaml/message-switch/core_test/lock_test_lwt.ml new file mode 100644 index 00000000000..784599dafa4 --- /dev/null +++ b/ocaml/message-switch/core_test/lock_test_lwt.ml @@ -0,0 +1,5 @@ +open Message_switch_lwt + +let test_lwt_lock = Protocol_lwt.Mtest.mutex_provides_mutal_exclusion () + +let () = Lwt_main.run test_lwt_lock diff --git a/ocaml/message-switch/core_test/lwt/server_main.ml b/ocaml/message-switch/core_test/lwt/server_main.ml index c30021ff35d..ece423dcb74 100644 --- a/ocaml/message-switch/core_test/lwt/server_main.ml +++ b/ocaml/message-switch/core_test/lwt/server_main.ml @@ -20,6 +20,8 @@ let path = ref "/var/run/message-switch/sock" let name = ref "server" +let concurrent = ref false + let t, u = Lwt.task () let process = function @@ -29,8 +31,13 @@ let process = function return x let main () = - Message_switch_lwt.Protocol_lwt.Server.listen ~process ~switch:!path - ~queue:!name () + ( if !concurrent then + Message_switch_lwt.Protocol_lwt.Server.listen_p ~process ~switch:!path + ~queue:!name () + else + Message_switch_lwt.Protocol_lwt.Server.listen ~process ~switch:!path + ~queue:!name () + ) >>= fun _ -> t >>= fun () -> Lwt_unix.sleep 1. @@ -45,6 +52,11 @@ let _ = , Arg.Set_string name , Printf.sprintf "name to send message to (default %s)" !name ) + ; ( "-concurrent" + , Arg.Set concurrent + , Printf.sprintf "set concurrent processing of messages (default %b)" + !concurrent + ) ] (fun x -> Printf.fprintf stderr "Ignoring unexpected argument: %s" x) "Respond to RPCs on a name" ; diff --git a/ocaml/message-switch/lwt/protocol_lwt.ml b/ocaml/message-switch/lwt/protocol_lwt.ml index 6da59eb3212..26c9c874d55 100644 --- a/ocaml/message-switch/lwt/protocol_lwt.ml +++ b/ocaml/message-switch/lwt/protocol_lwt.ml @@ -27,9 +27,15 @@ module M = struct let iter = Lwt_list.iter_s + let iter_dontwait f lst = Lwt.async (fun () -> Lwt_list.iter_p f lst) + let any = Lwt.choose + let all = Lwt.all + let is_determined t = Lwt.state t <> Lwt.Sleep + + let return_unit = Lwt.return_unit end let connect path = @@ -75,6 +81,18 @@ module M = struct let with_lock = Lwt_mutex.with_lock end + module Condition = struct + type 'a t = 'a Lwt_condition.t + + let create = Lwt_condition.create + + let signal = Lwt_condition.signal + + let wait c = Lwt_condition.wait c + + let broadcast = Lwt_condition.broadcast + end + module Clock = struct type timer = unit Lwt.t @@ -90,3 +108,4 @@ end module Client = Message_switch_core.Make.Client (M) module Server = Message_switch_core.Make.Server (M) +module Mtest = Message_switch_core.Mtest.Make (M) diff --git a/ocaml/message-switch/lwt/protocol_lwt.mli b/ocaml/message-switch/lwt/protocol_lwt.mli index c9bd220155d..64ca15c0e8e 100644 --- a/ocaml/message-switch/lwt/protocol_lwt.mli +++ b/ocaml/message-switch/lwt/protocol_lwt.mli @@ -19,3 +19,5 @@ open Message_switch_core module Client : S.CLIENT with type 'a io = 'a Lwt.t module Server : S.SERVER with type 'a io = 'a Lwt.t + +module Mtest : Mtest.MTEST with type 'a io = 'a Lwt.t diff --git a/ocaml/message-switch/switch/switch_main.ml b/ocaml/message-switch/switch/switch_main.ml index 9bf78973a85..583baf6e594 100644 --- a/ocaml/message-switch/switch/switch_main.ml +++ b/ocaml/message-switch/switch/switch_main.ml @@ -75,6 +75,13 @@ module Lwt_result = struct let ( >>= ) m f = m >>= fun x -> f (Stdlib.Result.get_ok x) end +let exn_hook e = + let bt = Printexc.get_raw_backtrace () in + error "Caught exception in Lwt.async: %s" (Printexc.to_string e) ; + error "backtrace: %s" (Printexc.raw_backtrace_to_string bt) + +let () = Lwt.async_exception_hook := exn_hook + let make_server config trace_config = let open Config in info "Started server on %s" config.path ; diff --git a/ocaml/message-switch/unix/protocol_unix.ml b/ocaml/message-switch/unix/protocol_unix.ml index 678b302ab5a..485964a40ec 100644 --- a/ocaml/message-switch/unix/protocol_unix.ml +++ b/ocaml/message-switch/unix/protocol_unix.ml @@ -546,5 +546,7 @@ module Server = struct let (_ : Thread.t) = thread_forever (loop connections) None in Ok () + let listen_p = listen + let shutdown ~t:_ () = failwith "Shutdown is unimplemented" end diff --git a/ocaml/nbd/lib/local_xapi_session.ml b/ocaml/nbd/lib/local_xapi_session.ml index ccc71e2d9c2..08167ad6e1a 100644 --- a/ocaml/nbd/lib/local_xapi_session.ml +++ b/ocaml/nbd/lib/local_xapi_session.ml @@ -13,7 +13,7 @@ *) open Lwt.Infix -module Xen_api = Xen_api_lwt_unix +module Xen_api = Xen_api_client_lwt.Xen_api_lwt_unix let wait_for_xapi_and_login () = let rpc = Xen_api.make Consts.xapi_unix_domain_socket_uri in diff --git a/ocaml/nbd/src/cleanup.ml b/ocaml/nbd/src/cleanup.ml index 213933fa56b..a3c0fd60d35 100644 --- a/ocaml/nbd/src/cleanup.ml +++ b/ocaml/nbd/src/cleanup.ml @@ -13,7 +13,7 @@ *) open Lwt.Infix -module Xen_api = Xen_api_lwt_unix +module Xen_api = Xen_api_client_lwt.Xen_api_lwt_unix let ignore_exn_log_error msg t = Lwt.catch t (fun e -> Lwt_log.error (msg ^ ": " ^ Printexc.to_string e)) diff --git a/ocaml/nbd/src/main.ml b/ocaml/nbd/src/main.ml index 21c48b5acac..d8f67a8c49a 100644 --- a/ocaml/nbd/src/main.ml +++ b/ocaml/nbd/src/main.ml @@ -15,7 +15,7 @@ open Lwt.Infix (* Xapi external interfaces: *) -module Xen_api = Xen_api_lwt_unix +module Xen_api = Xen_api_client_lwt.Xen_api_lwt_unix let ignore_exn_delayed t () = Lwt.catch t (fun _ -> Lwt.return_unit) diff --git a/ocaml/quicktest/qt.ml b/ocaml/quicktest/qt.ml index 1764f12ce8f..d390f0dfc38 100644 --- a/ocaml/quicktest/qt.ml +++ b/ocaml/quicktest/qt.ml @@ -132,26 +132,32 @@ module VM = struct Some x end - let install rpc session_id ~template ~name = + let install rpc session_id ~template ~name ?sr () = let template_uuid = Client.Client.VM.get_uuid ~rpc ~session_id ~self:template in - let newvm_uuid = - cli_cmd - [ - "vm-install" - ; "template-uuid=" ^ template_uuid - ; "new-name-label=" ^ name - ] + let cmd = + ["vm-install"; "template-uuid=" ^ template_uuid; "new-name-label=" ^ name] in + let sr_uuid = + Option.map + (fun sr -> Client.Client.SR.get_uuid ~rpc ~session_id ~self:sr) + sr + in + let cmd = + cmd @ Option.fold ~none:[] ~some:(fun x -> ["sr-uuid=" ^ x]) sr_uuid + in + let newvm_uuid = cli_cmd cmd in Client.Client.VM.get_by_uuid ~rpc ~session_id ~uuid:newvm_uuid let uninstall rpc session_id vm = let uuid = Client.Client.VM.get_uuid ~rpc ~session_id ~self:vm in cli_cmd ["vm-uninstall"; "uuid=" ^ uuid; "--force"] |> ignore - let with_new rpc session_id ~template f = - let vm = install rpc session_id ~template ~name:"temp_quicktest_vm" in + let with_new rpc session_id ~template ?sr f = + let vm = + install rpc session_id ~template ~name:"temp_quicktest_vm" ?sr () + in Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> f vm) (fun () -> uninstall rpc session_id vm) diff --git a/ocaml/quicktest/qt.mli b/ocaml/quicktest/qt.mli index f0edde13a56..15dbb785f28 100644 --- a/ocaml/quicktest/qt.mli +++ b/ocaml/quicktest/qt.mli @@ -50,7 +50,12 @@ module VM : sig end val with_new : - rpc -> API.ref_session -> template:API.ref_VM -> (API.ref_VM -> 'a) -> 'a + rpc + -> API.ref_session + -> template:API.ref_VM + -> ?sr:API.ref_SR + -> (API.ref_VM -> 'a) + -> 'a val dom0_of_host : rpc -> API.ref_session -> API.ref_host -> API.ref_VM (** Return a host's domain zero *) diff --git a/ocaml/quicktest/quicktest_vm_lifecycle.ml b/ocaml/quicktest/quicktest_vm_lifecycle.ml index 88fd9b8d664..b3de6b5b309 100644 --- a/ocaml/quicktest/quicktest_vm_lifecycle.ml +++ b/ocaml/quicktest/quicktest_vm_lifecycle.ml @@ -91,12 +91,18 @@ let one rpc session_id vm test = | Halted -> wait_for_domid (fun domid' -> domid' = -1L) -let test rpc session_id vm_template () = - Qt.VM.with_new rpc session_id ~template:vm_template (fun vm -> +let test rpc session_id sr_info vm_template () = + let sr = sr_info.Qt.sr in + Qt.VM.with_new rpc session_id ~template:vm_template ~sr (fun vm -> List.iter (one rpc session_id vm) all_possible_tests ) let tests () = let open Qt_filter in - [[("VM lifecycle tests", `Slow, test)] |> conn |> vm_template "CoreOS"] + [ + [("VM lifecycle tests", `Slow, test)] + |> conn + |> sr SR.(all |> allowed_operations [`vdi_create]) + |> vm_template "CoreOS" + ] |> List.concat diff --git a/ocaml/sdk-gen/README.md b/ocaml/sdk-gen/README.md index 7473d141f83..fb4d71650bf 100644 --- a/ocaml/sdk-gen/README.md +++ b/ocaml/sdk-gen/README.md @@ -12,9 +12,7 @@ The Python module is not auto-generated, it can be found at [XenAPI.py](../../scripts/examples/python/XenAPI/XenAPI.py). To compile the generated source code, follow the instructions in the corresponding -README files. The (patched) third party libraries required for the compilation -of the C# and PowerShell source code can be obtained from -[xenserver/dotnet-packages](https://github.com/xenserver/dotnet-packages) +`README` files. The repository [xenserver/xenserver-samples](https://github.com/xenserver/xenserver-samples) contains a number of examples for each of the five programming languages to help diff --git a/ocaml/sdk-gen/c/README.dist b/ocaml/sdk-gen/c/README.dist index dfe92390216..e5fb8622069 100644 --- a/ocaml/sdk-gen/c/README.dist +++ b/ocaml/sdk-gen/c/README.dist @@ -58,4 +58,3 @@ Compiling from source --------------------- To build, simply type "make" in the libxenserver/src directory. -To build on Windows with cygwin type "make CYGWIN=1". diff --git a/ocaml/sdk-gen/c/autogen/src/xen_common.c b/ocaml/sdk-gen/c/autogen/src/xen_common.c index 9081f9bd725..9178d3fd43f 100644 --- a/ocaml/sdk-gen/c/autogen/src/xen_common.c +++ b/ocaml/sdk-gen/c/autogen/src/xen_common.c @@ -292,10 +292,7 @@ set_api_version(xen_session *session) void xen_session_logout(xen_session *session) { - abstract_value params[] = - { - }; - xen_call_(session, "session.logout", params, 0, NULL, NULL); + xen_call_(session, "session.logout", NULL, 0, NULL, NULL); if (session->error_description != NULL) { @@ -314,10 +311,7 @@ xen_session_logout(xen_session *session) void xen_session_local_logout(xen_session *session) { - abstract_value params[] = - { - }; - xen_call_(session, "session.local_logout", params, 0, NULL, NULL); + xen_call_(session, "session.local_logout", NULL, 0, NULL, NULL); if (session->error_description != NULL) { @@ -336,14 +330,11 @@ xen_session_local_logout(xen_session *session) bool xen_session_get_all_subject_identifiers(xen_session *session, struct xen_string_set **result) { - abstract_value params[] = - { - }; abstract_type result_type = abstract_type_string_set; *result = NULL; - xen_call_(session, "session.get_all_subject_identifiers", params, 0, &result_type, result); + xen_call_(session, "session.get_all_subject_identifiers", NULL, 0, &result_type, result); return session->ok; } @@ -351,14 +342,10 @@ bool bool xen_session_get_all_subject_identifiers_async(xen_session *session, xen_task *result) { - abstract_value params[] = - { - }; - abstract_type result_type = abstract_type_string; *result = NULL; - xen_call_(session, "Async.session.get_all_subject_identifiers", params, 0, &result_type, result); + xen_call_(session, "Async.session.get_all_subject_identifiers", NULL, 0, &result_type, result); return session->ok; } diff --git a/ocaml/sdk-gen/c/gen_c_binding.ml b/ocaml/sdk-gen/c/gen_c_binding.ml index 0c84af4ac93..757046ac336 100644 --- a/ocaml/sdk-gen/c/gen_c_binding.ml +++ b/ocaml/sdk-gen/c/gen_c_binding.ml @@ -2,7 +2,7 @@ * Copyright (c) Cloud Software Group, Inc. *) -(* Generator of C bindings from the datamodel *) +(* Generator of the C SDK from the datamodel *) open Printf open Datamodel_types @@ -55,49 +55,38 @@ let enum_maps = ref TypeSet.empty let all_headers = ref [] -let joined sep f l = - let r = List.map f l in - String.concat sep (List.filter (fun x -> String.compare x "" != 0) r) +let rec is_last x list = + match list with + | [] -> + false + | hd :: [] -> + if hd = x then true else false + | hd :: tl -> + if hd = x then false else is_last x tl let rec main () = - let include_dir = Filename.concat destdir "include" in - let src_dir = Filename.concat destdir "src" in - - gen_failure_h () ; - gen_failure_c () ; - let filtered_classes = List.filter (fun x -> not (List.mem x.name ["session"; "debug"; "data_source"])) classes in - List.iter - (fun x -> - ( gen_class write_predecl predecl_filename x include_dir ; - gen_class write_decl decl_filename x include_dir ; - gen_class write_impl impl_filename x - ) - src_dir - ) - filtered_classes ; + List.iter gen_decl filtered_classes ; + List.iter gen_impl filtered_classes ; all_headers := List.map (fun x -> x.name) filtered_classes ; - TypeSet.iter (gen_enum write_enum_decl decl_filename include_dir) !enums ; - TypeSet.iter (gen_enum write_enum_impl impl_filename src_dir) !enums ; - TypeSet.iter - (gen_enum write_enum_internal_decl internal_decl_filename include_dir) - !enums ; + TypeSet.iter render_enum !enums ; maps := TypeSet.add (Map (String, Int)) !maps ; maps := TypeSet.add (Map (Int, Int)) !maps ; maps := TypeSet.add (Map (String, Set String)) !maps ; maps := TypeSet.add (Map (String, Map (String, String))) !maps ; - TypeSet.iter (gen_map write_map_decl decl_filename include_dir) !maps ; - TypeSet.iter (gen_map write_map_impl impl_filename src_dir) !maps ; + + TypeSet.iter (function Map (l, r) -> render_map_decl l r | _ -> ()) !maps ; + TypeSet.iter (function Map (l, r) -> render_map_impl l r | _ -> ()) !maps ; TypeSet.iter - (gen_map write_enum_map_internal_decl internal_decl_filename include_dir) + (function Map (l, r) -> render_enum_map l r | _ -> ()) !enum_maps ; let class_records = @@ -122,7 +111,10 @@ let rec main () = json1 templates_dir destdir ; let sorted_headers = - List.sort String.compare (List.map decl_filename !all_headers) + !all_headers + |> List.filter (fun x -> not (Astring.String.is_suffix ~affix:"internal" x)) + |> List.map String.lowercase_ascii + |> List.sort String.compare in let json2 = `O @@ -136,302 +128,305 @@ let rec main () = ("xen_all.h.mustache", "include/xen/api/xen_all.h") json2 templates_dir destdir -and gen_class f g clas targetdir = - let out_chan = open_out (Filename.concat targetdir (g clas.name)) in - finally (fun () -> f clas out_chan) ~always:(fun () -> close_out out_chan) - -and gen_enum f g targetdir = function - | Enum (name, _) as x -> - if not (List.mem name !all_headers) then - all_headers := name :: !all_headers ; - let out_chan = open_out (Filename.concat targetdir (g name)) in - finally (fun () -> f x out_chan) ~always:(fun () -> close_out out_chan) - | _ -> - assert false - -and gen_map f g targetdir = function - | Map (l, r) -> - let name = mapname l r in - if not (List.mem name !all_headers) then - all_headers := name :: !all_headers ; - let out_chan = open_out (Filename.concat targetdir (g name)) in - finally - (fun () -> f name l r out_chan) - ~always:(fun () -> close_out out_chan) - | _ -> - assert false - -and write_predecl {name= classname; _} out_chan = - let print format = fprintf out_chan format in - let protect = protector (classname ^ "_decl") in - let tn = typename classname in - let record_tn = record_typename classname in - let record_opt_tn = record_opt_typename classname in - - print_h_header out_chan protect ; - - if classname <> "event" then ( - print "typedef void *%s;\n\n" tn ; - print "%s\n" (predecl_set tn) - ) ; - print "%s\n" (predecl record_tn) ; - print "%s\n" (predecl_set record_tn) ; - if classname <> "event" then ( - print "%s\n" (predecl record_opt_tn) ; - print "%s\n" (predecl_set record_opt_tn) - ) ; - print_h_footer out_chan +and gen_decl cls = + let headers = ref (StringSet.add (cls.name ^ "_decl") StringSet.empty) in + let rec get_needed = function + | Field fr -> + find_needed headers fr.ty + | Namespace (_, cs) -> + List.iter get_needed cs + in + List.iter get_needed cls.contents ; -and write_decl {name= classname; contents; description; messages; _} out_chan = - let print format = fprintf out_chan format in - let protect = protector classname in - let tn = typename classname in - let record_tn = record_typename classname in - let record_opt_tn = record_opt_typename classname in - let class_has_refs = true (* !!! *) in - let needed = ref (StringSet.add (classname ^ "_decl") StringSet.empty) in - let record = decl_record needed tn record_tn contents in - let record_opt = decl_record_opt tn record_tn record_opt_tn in - let message_decls = - decl_messages needed classname - (List.filter - (fun x -> not (classname = "event" && x.msg_name = "from")) - messages - ) + let asyncParams x = + if x.msg_async then + { + param_type= Ref "task" + ; param_name= "*result" + ; param_doc= "" + ; param_release= x.msg_release + ; param_default= None + } + :: x.msg_params + else + x.msg_params in - let full_stop = - if Astring.String.is_suffix ~affix:"." description then "" else "." + let syncParams x = + match x.msg_result with + | Some res -> + { + param_type= fst res + ; param_name= "*result" + ; param_doc= "" + ; param_release= x.msg_release + ; param_default= None + } + :: x.msg_params + | None -> + x.msg_params + in + let paramJson x = + `O + [ + ("param_name", `String (paramname x.param_name)) + ; ("param_type", `String (c_type_of_ty headers false x.param_type)) + ] in + let json = + `O + [ + ("class_upper", `String (String.uppercase_ascii cls.name)) + ; ("class_lower", `String (String.lowercase_ascii cls.name)) + ; ("class_doc", `String (Helper.comment false (full_class_doc cls))) + ; ("is_event", `Bool (cls.name = "event")) + ; ( "headers" + , `A + (List.map + (fun x -> `O [("header", `String x)]) + ("common" :: StringSet.elements !headers + |> List.map String.lowercase_ascii + |> List.sort String.compare + |> List.filter (fun x -> + not (Astring.String.is_suffix ~affix:"internal" x) + ) + ) + ) + ) + ; ( "fields" + , `A + (cls + |> Datamodel_utils.fields_of_obj + |> List.map (fun field -> + `O + [ + ( "field_name_lower" + , `String (fieldname (String.concat "_" field.full_name)) + ) + ; ( "field_type" + , `String (c_type_of_ty headers true field.ty) + ) + ] + ) + ) + ) + ; ( "messages" + , `A + (cls.messages + |> List.filter (fun x -> + not (cls.name = "event" && x.msg_name = "from") + ) + |> List.map (fun x -> + `O + [ + ( "msg_name_lower" + , `String (String.lowercase_ascii x.msg_name) + ) + ; ( "msg_doc" + , `String (Helper.comment true (full_msg_doc x)) + ) + ; ("is_async", `Bool x.msg_async) + ; ("sync_params", `A (List.map paramJson (syncParams x))) + ; ("async_params", `A (List.map paramJson (asyncParams x))) + ] + ) + ) + ) + ] + in + render_file + ( "class_decl.h.mustache" + , sprintf "include/xen/api/xen_%s_decl.h" (String.lowercase_ascii cls.name) + ) + json templates_dir destdir ; + render_file + ( "class.h.mustache" + , sprintf "include/xen/api/xen_%s.h" (String.lowercase_ascii cls.name) + ) + json templates_dir destdir - let rec get_needed x = - match x with +and gen_impl cls = + let headers = ref StringSet.empty in + let rec get_needed = function | Field fr -> - find_needed'' needed fr.ty + find_needed headers fr.ty | Namespace (_, cs) -> List.iter get_needed cs in - List.iter get_needed contents ; - - print_h_header out_chan protect ; - print "%s\n" (hash_includes !needed) ; + List.iter get_needed cls.contents ; - print "\n\n%s\n\n\n" - (Helper.comment false - (sprintf "The %s class.\n\n%s%s" classname description full_stop) - ) ; - - if classname <> "event" then ( - print "%s\n\n" - (decl_free tn (String.lowercase_ascii classname) false "handle") ; - print "%s\n" (decl_set tn false) - ) ; - print "%s\n" record ; - if classname <> "event" then - print "%s\n" record_opt ; - print "%s\n\n" (decl_set record_tn class_has_refs) ; - if classname <> "event" then - print "%s\n\n" (decl_set record_opt_tn true) ; - print "%s\n" message_decls ; - print_h_footer out_chan - -and predecl_set tn = predecl (tn ^ "_set") - -and predecl tn = sprintf "struct %s;" tn - -and decl_set tn referenced = - let alloc_com = - Helper.comment true (sprintf "Allocate a %s_set of the given size." tn) - in - - sprintf - "\n\ - typedef struct %s_set\n\ - {\n\ - \ size_t size;\n\ - \ %s *contents[];\n\ - } %s_set;\n\n\ - %s\n\ - extern %s_set *\n\ - %s_set_alloc(size_t size);\n\n\ - %s\n" - tn tn tn alloc_com tn tn - (decl_free (sprintf "%s_set" tn) "*set" referenced "set") + List.iter + (fun x -> + List.iter (fun p -> find_needed headers p.param_type) x.msg_params ; + match x.msg_result with + | Some res -> + find_needed headers (fst res) + | None -> + () + ) + cls.messages ; -and decl_free tn cn referenced thing = - let com = - Helper.comment true - (sprintf - "Free the given %s%s. The given %s must have been allocated by this \ - library." - tn - (if referenced then ", and all referenced values" else "") - thing - ) + let allFields = cls |> Datamodel_utils.fields_of_obj in + let result_type message = + match message.msg_result with + | Some res -> + abstract_type false (fst res) + | None -> + "" in - - sprintf "%s\nextern void\n%s_free(%s %s);" com tn tn cn - -and decl_record needed tn record_tn contents = - sprintf - "\n\ - typedef struct %s\n\ - {\n\ - %s %s\n\ - } %s;\n\n\ - %s\n\ - extern %s *\n\ - %s_alloc(void);\n\n\ - %s\n" - record_tn - (if tn <> "xen_event" then sprintf " %s handle;\n" tn else "") - (record_fields contents needed) - record_tn - (Helper.comment true (sprintf "Allocate a %s." record_tn)) - record_tn record_tn - (decl_free record_tn "*record" true "record") - -and decl_record_opt tn record_tn record_opt_tn = - sprintf - "\n\ - typedef struct %s\n\ - {\n\ - \ bool is_record;\n\ - \ union\n\ - \ {\n\ - \ %s handle;\n\ - \ %s *record;\n\ - \ } u;\n\ - } %s;\n\n\ - %s\n\ - extern %s *\n\ - %s_alloc(void);\n\n\ - %s\n" - record_opt_tn tn record_tn record_opt_tn - (Helper.comment true (sprintf "Allocate a %s." record_opt_tn)) - record_opt_tn record_opt_tn - (decl_free record_opt_tn "*record_opt" true "record_opt") - -and record_fields contents needed = - joined "\n " (record_field needed "") contents - -and record_field needed prefix content = - match content with - | Field fr -> - sprintf "%s%s%s;" - (c_type_of_ty needed true fr.ty) - prefix (fieldname fr.field_name) - | Namespace (p, c) -> - joined "\n " (record_field needed (prefix ^ fieldname p ^ "_")) c - -and decl_messages needed classname messages = - joined "\n\n" (decl_message needed classname) messages - -and decl_message needed classname message = - let message_sig = message_signature needed classname message in - let messageAsyncVersion = decl_message_async needed classname message in - sprintf "%s\n%sextern %s;\n%s" - (get_message_comment message) - (get_deprecated_message message) - message_sig messageAsyncVersion - -and decl_message_async needed classname message = - if message.msg_async then ( - let messageSigAsync = message_signature_async needed classname message in - needed := StringSet.add "task_decl" !needed ; - sprintf "\n%s\n%sextern %s;\n" - (get_message_comment message) - (get_deprecated_message message) - messageSigAsync - ) else - "" - -and get_message_comment message = - let full_stop = - if Astring.String.is_suffix ~affix:"." message.msg_doc then "" else "." + let init_result message = + match message.msg_result with + | Some res -> ( + match fst res with + | SecretString | String | Ref _ | Set _ | Map _ | Record _ -> + true + | _ -> + false + ) + | None -> + false in - let minimum_allowed_role = get_minimum_allowed_role message in - let content = - sprintf "%s%s\nMinimum allowed role: %s." message.msg_doc full_stop - minimum_allowed_role + let is_result_record message = + match message.msg_result with + | Some res -> ( + match fst res with Record _ -> true | _ -> false + ) + | None -> + false in - Helper.comment true content - -and impl_messages needed classname messages = - joined "\n\n" (impl_message needed classname) messages - -and impl_message needed classname message = - let message_sig = message_signature needed classname message in - let param_count = List.length message.msg_params in - - let param_decl, param_call = - if param_count = 0 then - ("", "NULL") + let asyncParams x = + if x.msg_async then + { + param_type= Ref "task" + ; param_name= "*result" + ; param_doc= "" + ; param_release= x.msg_release + ; param_default= None + } + :: x.msg_params else - let param_pieces = abstract_params message.msg_params in - - ( sprintf - " abstract_value param_values[] =\n\ - \ {\n\ - \ %s\n\ - \ };\n" - param_pieces - , "param_values" - ) + x.msg_params in - - let result_bits = - match message.msg_result with + let syncParams x = + match x.msg_result with | Some res -> - abstract_result_handling classname message.msg_name param_count res + { + param_type= fst res + ; param_name= "*result" + ; param_doc= "" + ; param_release= x.msg_release + ; param_default= None + } + :: x.msg_params | None -> - sprintf - " xen_call_(session, \"%s.%s\", %s, %d, NULL, NULL);\n\ - \ return session->ok;\n" - classname message.msg_name param_call param_count + x.msg_params in - - let messageAsyncImpl = impl_message_async needed classname message in - sprintf "%s%s\n{\n%s\n%s}\n%s" - (get_deprecated_message message) - message_sig param_decl result_bits messageAsyncImpl - -and impl_message_async needed classname message = - if message.msg_async then - let messageSigAsync = message_signature_async needed classname message in - let param_count = List.length message.msg_params in - - let param_decl, _ = - if param_count = 0 then - ("", "NULL") - else - let param_pieces = abstract_params message.msg_params in - - ( sprintf - " abstract_value param_values[] =\n\ - \ {\n\ - \ %s\n\ - \ };\n" - param_pieces - , "param_values" - ) + let messageJson msg = + let paramJson p = + `O + [ + ("param_name", `String (paramname p.param_name)) + ; ("param_type", `String (c_type_of_ty headers false p.param_type)) + ; ("abstract_param_type", `String (abstract_type false p.param_type)) + ; ("abstract_member", `String (abstract_member p.param_type)) + ; ( "abstract_member_conv" + , `String (abstract_param_conv p.param_name p.param_type) + ) + ; ("is_last", `Bool (is_last p msg.msg_params)) + ] in + `O + [ + ("msg_name_lower", `String (String.lowercase_ascii msg.msg_name)) + ; ("msg_name", `String msg.msg_name) + ; ("msg_doc", `String (Helper.comment true (full_msg_doc msg))) + ; ("is_async", `Bool msg.msg_async) + ; ("sync_params", `A (List.map paramJson (syncParams msg))) + ; ("async_params", `A (List.map paramJson (asyncParams msg))) + ; ("msg_params", `A (List.map paramJson msg.msg_params)) + ; ("abstract_result_type", `String (result_type msg)) + ; ("has_params", `Bool (List.length msg.msg_params <> 0)) + ; ("param_count", `String (string_of_int (List.length msg.msg_params))) + ; ("has_result", `Bool (String.compare (result_type msg) "" <> 0)) + ; ("init_result", `Bool (init_result msg)) + ; ("is_result_record", `Bool (is_result_record msg)) + ] + in + let fieldJson field = + let fullName = String.concat "_" field.full_name in + let freeing = free_impl ("record->" ^ fieldname fullName) true field.ty in + `O + [ + ("field_name_lower", `String (fieldname fullName)) + ; ("field_name", `String fullName) + ; ("abstract_field_type", `String (abstract_type true field.ty)) + ; ("can_free", `Bool (freeing <> "")) + ; ("free_record_field", `String freeing) + ; ("is_last", `Bool (is_last field allFields)) + ] + in + let json = + `O + [ + ("class_name", `String cls.name) + ; ("class_lower", `String (String.lowercase_ascii cls.name)) + ; ("is_event", `Bool (cls.name = "event")) + ; ( "has_all_records" + , `Bool + (List.exists (fun x -> x.msg_name = "get_all_records") cls.messages) + ) + ; ( "headers" + , `A + (List.map + (fun x -> `O [("header", `String x)]) + (["common"; String.lowercase_ascii cls.name] + |> List.sort String.compare + ) + ) + ) + ; ( "internal_headers" + , `A + (List.map + (fun x -> `O [("header", `String x)]) + ("internal" :: StringSet.elements !headers + |> List.map String.lowercase_ascii + |> List.sort String.compare + |> List.filter (fun x -> + Astring.String.is_suffix ~affix:"internal" x + ) + ) + ) + ) + ; ("fields", `A (allFields |> List.map fieldJson)) + ; ( "messages" + , `A + (cls.messages + |> List.filter (fun x -> + not (cls.name = "event" && x.msg_name = "from") + ) + |> List.map messageJson + ) + ) + ] + in + render_file + ( "class.c.mustache" + , sprintf "src/xen_%s.c" (String.lowercase_ascii cls.name) + ) + json templates_dir destdir - let result_bits = - abstract_result_handling_async classname message.msg_name param_count - in - sprintf "\n%s%s\n{\n%s\n%s}" - (get_deprecated_message message) - messageSigAsync param_decl result_bits - else - "" +and full_stop x = if Astring.String.is_suffix ~affix:"." x then "" else "." -and abstract_params params = joined ",\n " abstract_param params +and full_class_doc cls = + let intro = sprintf "The %s class.\n\n" cls.name in + intro ^ cls.description ^ full_stop cls.description -and abstract_param p = - let ab_typ = abstract_type false p.param_type in - sprintf "{ .type = &%s,\n .u.%s_val = %s }" ab_typ - (abstract_member p.param_type) - (abstract_param_conv p.param_name p.param_type) +and full_msg_doc message = + let role = + sprintf "\nMinimum allowed role: %s." (get_minimum_allowed_role message) + in + let deprecated = get_deprecated_info_message message in + let deprecated = if deprecated = "" then "" else "\n" ^ deprecated in + message.msg_doc ^ full_stop message.msg_doc ^ role ^ deprecated and abstract_param_conv name = function | Set _ | Map _ -> @@ -454,9 +449,7 @@ and abstract_member = function "bool" | DateTime -> "datetime" - | Set _ -> - "set" - | Map _ -> + | Set _ | Map _ -> "set" | Record _ -> "struct" @@ -464,81 +457,6 @@ and abstract_member = function eprintf "%s" (Types.to_string x) ; assert false -and abstract_result_handling classname msg_name param_count = function - | typ, _ -> ( - let call = - if param_count = 0 then - sprintf - "xen_call_(session, \"%s.%s\", NULL, 0, &result_type, result);" - classname msg_name - else - sprintf "XEN_CALL_(\"%s.%s\");" classname msg_name - in - - match typ with - | String | Ref _ | Int | Float | Bool | DateTime | Set _ | Map _ -> - sprintf "%s\n\n%s %s\n return session->ok;\n" - (abstract_result_type typ) (initialiser_of_ty typ) call - | Record n -> - let record_tn = record_typename n in - sprintf - " abstract_type result_type = %s_abstract_type_;\n\n\ - %s %s\n\n\ - \ if (session->ok)\n\ - \ {\n\ - \ (*result)->handle = xen_strdup_((*result)->uuid);\n\ - \ }\n\n\ - \ return session->ok;\n" - record_tn - (initialiser_of_ty (Record n)) - call - | Enum (_, _) -> - sprintf "%s\n %s\n return session->ok;\n" - (abstract_result_type typ) call - | x -> - eprintf "%s" (Types.to_string x) ; - assert false - ) - -and abstract_result_handling_async classname msg_name param_count = - let call = - if param_count = 0 then - sprintf - "xen_call_(session, \"Async.%s.%s\", NULL, 0, &result_type, result);" - classname msg_name - else - sprintf "XEN_CALL_(\"Async.%s.%s\");" classname msg_name - in - sprintf - " abstract_type result_type = abstract_type_string;\n\n\ - \ *result = NULL;\n\ - \ %s\n\ - \ return session->ok;\n" - call - -and abstract_record_field classname prefix prefix_caps content = - match content with - | Field fr -> - let fn = fieldname fr.field_name in - sprintf - "{ .key = \"%s%s\",\n\ - \ .type = &%s,\n\ - \ .offset = offsetof(%s, %s%s) }" prefix_caps fr.field_name - (abstract_type true fr.ty) - (record_typename classname) - prefix fn - | Namespace (p, c) -> - joined ",\n " - (abstract_record_field classname - (prefix ^ fieldname p ^ "_") - (prefix_caps ^ p ^ "_") - ) - c - -and abstract_result_type typ = - let ab_typ = abstract_type false typ in - sprintf " abstract_type result_type = %s;" ab_typ - and abstract_type record = function | SecretString | String -> "abstract_type_string" @@ -586,623 +504,207 @@ and abstract_type record = function | Option n -> abstract_type record n -and get_deprecated_message message = - let deprecatedMessage = get_deprecated_info_message message in - if deprecatedMessage = "" then - sprintf "" - else - sprintf "/* " ^ deprecatedMessage ^ " */\n" - -and message_signature needed classname message = - let front = - { - param_type= Ref "session" - ; param_name= "session" - ; param_doc= "" - ; param_release= message.msg_release - ; param_default= None - } - :: - ( match message.msg_result with - | Some res -> - [ - { - param_type= fst res - ; param_name= "*result" - ; param_doc= "" - ; param_release= message.msg_release - ; param_default= None - } - ] - | None -> - [] - ) - in - let params = joined ", " (param needed) (front @ message.msg_params) in - sprintf "bool\n%s(%s)" (messagename classname message.msg_name) params - -and message_signature_async needed classname message = - let sessionParam = - { - param_type= Ref "session" - ; param_name= "session" - ; param_doc= "" - ; param_release= message.msg_release - ; param_default= None - } - in - let taskParam = - { - param_type= Ref "task" - ; param_name= "*result" - ; param_doc= "" - ; param_release= message.msg_release - ; param_default= None - } - in - let params = - joined ", " (param needed) (sessionParam :: taskParam :: message.msg_params) - in - sprintf "bool\n%s(%s)" (messagename_async classname message.msg_name) params - -and param needed p = - let t = p.param_type in - let n = p.param_name in - sprintf "%s%s" (c_type_of_ty needed false t) (paramname n) - -and hash_includes needed = - String.concat "\n" - (List.sort String.compare - (List.filter - (function s -> s <> "") - (List.map hash_include ("common" :: StringSet.elements needed)) - ) - ) - -and hash_include n = - if Astring.String.is_suffix ~affix:"internal" n then - sprintf "#include \"%s\"" (decl_filename n) - else if n = "session" then - "" - else - sprintf "#include <%s>" (decl_filename n) - -and write_enum_decl x out_chan = - match x with - | Enum (name, contents) -> - let print format = fprintf out_chan format in - let protect = protector name in - let tn = typename name in - - print_h_header out_chan protect ; - - print - "\n\ - %s\n\n\n\ - enum %s\n\ - {\n\ - %s\n\ - };\n\n\n\ - typedef struct %s_set\n\ - {\n\ - \ size_t size;\n\ - \ enum %s contents[];\n\ - } %s_set;\n\n\ - %s\n\ - extern %s_set *\n\ - %s_set_alloc(size_t size);\n\n\ - %s\n\n\n\ - %s\n\ - extern const char *\n\ - %s_to_string(enum %s val);\n\n\n\ - %s\n\ - extern enum %s\n\ - %s_from_string(xen_session *session, const char *str);\n\n" - (hash_include "common") tn - (joined ",\n\n" (enum_entry name) - (contents - @ [("undefined", "Unknown to this version of the bindings.")] - ) - ) - tn tn tn - (Helper.comment true (sprintf "Allocate a %s_set of the given size." tn)) - tn tn - (decl_free (sprintf "%s_set" tn) "*set" false "set") - (Helper.comment true - "Return the name corresponding to the given code. This string must \ - not be modified or freed." - ) - tn tn - (Helper.comment true - "Return the correct code for the given string, or set the session \ - object to failure and return an undefined value if the given \ - string does not match a known code." - ) - tn tn ; - - print_h_footer out_chan - | _ -> - () +and replace_dashes x = + Astring.String.map (fun y -> match y with '-' -> '_' | _ -> y) x -and enum_entry enum_name = function - | n, c -> - sprintf "%s\n XEN_%s_%s" - (Helper.comment true ~indent:4 c) - (String.uppercase_ascii enum_name) - (Astring.String.map - (fun x -> match x with '-' -> '_' | _ -> x) - (String.uppercase_ascii n) - ) - -and write_enum_impl x out_chan = +and render_enum x = match x with | Enum (name, contents) -> - let print format = fprintf out_chan format in - let tn = typename name in - - print - "%s\n\n\ - #include \n\n\ - %s\n\ - %s\n\ - %s\n\n\n\ - /*\n\ - \ * Maintain this in the same order as the enum declaration!\n\ - \ */\n\ - static const char *lookup_table[] =\n\ - {\n\ - %s\n\ - };\n\n\n\ - extern %s_set *\n\ - %s_set_alloc(size_t size)\n\ - {\n\ - \ return calloc(1, sizeof(%s_set) +\n\ - \ size * sizeof(enum %s));\n\ - }\n\n\n\ - extern void\n\ - %s_set_free(%s_set *set)\n\ - {\n\ - \ free(set);\n\ - }\n\n\n\ - const char *\n\ - %s_to_string(enum %s val)\n\ - {\n\ - \ return lookup_table[val];\n\ - }\n\n\n\ - extern enum %s\n\ - %s_from_string(xen_session *session, const char *str)\n\ - {\n\ - \ (void)session;\n\ - \ return ENUM_LOOKUP(str, lookup_table);\n\ - }\n\n\n\ - const abstract_type %s_abstract_type_ =\n\ - \ {\n\ - \ .XEN_API_TYPE = ENUM,\n\ - \ .enum_marshaller =\n\ - \ (const char *(*)(int))&%s_to_string,\n\ - \ .enum_demarshaller =\n\ - \ (int (*)(xen_session *, const char *))&%s_from_string\n\ - \ };\n\n\n" - Licence.bsd_two_clause (hash_include "internal") (hash_include name) - (hash_include (name ^ "_internal")) - (enum_lookup_entries (contents @ [("undefined", "")])) - tn tn tn tn tn tn tn tn tn tn tn tn tn ; - - if name <> "event_operation" then - print - "const abstract_type %s_set_abstract_type_ =\n\ - \ {\n\ - \ .XEN_API_TYPE = SET,\n\ - \ .child = &%s_abstract_type_\n\ - \ };\n\n\n" - tn tn - | _ -> - () - -and enum_lookup_entries contents = joined ",\n" enum_lookup_entry contents - -and enum_lookup_entry = function n, _ -> sprintf " \"%s\"" n - -and write_enum_internal_decl x out_chan = - match x with - | Enum (name, _) -> - let print format = fprintf out_chan format in - let protect = protector (sprintf "%s_internal" name) in - let tn = typename name in - - let set_abstract_type = - if name = "event_operations" then - "" - else - sprintf "extern const abstract_type %s_set_abstract_type_;\n" tn + if not (List.mem name !all_headers) then + all_headers := name :: !all_headers ; + let json = + `O + [ + ("enum_name", `String name) + ; ("enum_name_upper", `String (String.uppercase_ascii name)) + ; ("event_operations", `Bool (name = "event_operation")) + ; ( "enum_values" + , `A + (List.map + (fun (n, c) -> + `O + [ + ("enum_value", `String n) + ; ( "enum_value_doc" + , `String (Helper.comment true ~indent:4 c) + ) + ; ( "enum_value_upper" + , `String (replace_dashes (String.uppercase_ascii n)) + ) + ] + ) + contents + ) + ) + ] in - - print - "%s\n\n\n\ - %s\n\n\n\ - #ifndef %s\n\ - #define %s\n\n\n\ - %s\n\n\n\ - extern const abstract_type %s_abstract_type_;\n\ - %s\n\n\ - #endif\n" - Licence.bsd_two_clause - (Helper.comment false - (sprintf - "Declarations of the abstract types used during demarshalling of \ - enum %s. Internal to this library -- do not use from outside." - tn - ) + render_file + ( "xen_enum_internal.h.mustache" + , sprintf "include/xen_%s_internal.h" name ) - protect protect (hash_include "internal") tn set_abstract_type + json templates_dir destdir ; + render_file + ("xen_enum.h.mustache", sprintf "include/xen/api/xen_%s.h" name) + json templates_dir destdir ; + render_file + ("xen_enum.c.mustache", sprintf "src/xen_%s.c" name) + json templates_dir destdir | _ -> () -and write_map_decl name l r out_chan = - let print format = fprintf out_chan format in - let tn = typename name in - let protect = protector name in - let needed = ref StringSet.empty in - let alloc_com = - Helper.comment true (sprintf "Allocate a %s of the given size." tn) - in - - print_h_header out_chan protect ; - print - "\n\ - %s%s%s\n\n\n\ - typedef struct %s_contents\n\ - {\n\ - \ %skey;\n\ - \ %sval;\n\ - } %s_contents;\n\n\n\ - typedef struct %s\n\ - {\n\ - \ size_t size;\n\ - \ %s_contents contents[];\n\ - } %s;\n\n\ - %s\n\ - extern %s *\n\ - %s_alloc(size_t size);\n\n\ - %s\n\n" - (hash_include "common") (hash_include_enum l) (hash_include_enum r) tn - (c_type_of_ty needed false l) - (c_type_of_ty needed true r) - tn tn tn tn alloc_com tn tn - (decl_free tn "*map" true "map") ; - print_h_footer out_chan - -and write_map_impl name l r out_chan = - let print format = fprintf out_chan format in - let tn = typename name in - let l_free_impl = free_impl "map->contents[i].key" false l in - let r_free_impl = free_impl "map->contents[i].val" true r in - let needed = ref StringSet.empty in - find_needed'' needed l ; - find_needed'' needed r ; - needed := StringSet.add "internal" !needed ; - needed := StringSet.add name !needed ; - ( match r with - | Set String -> - needed := StringSet.add "string_set" !needed - | _ -> - () - ) ; - - print - "%s\n\n\n\ - %s\n\n\n\ - %s *\n\ - %s_alloc(size_t size)\n\ - {\n\ - \ %s *result = calloc(1, sizeof(%s) +\n\ - \ %s size * sizeof(struct %s_contents));\n\ - \ result->size = size;\n\ - \ return result;\n\ - }\n\n\n\ - void\n\ - %s_free(%s *map)\n\ - {\n" - Licence.bsd_two_clause (hash_includes !needed) tn tn tn tn - (String.make (String.length tn) ' ') - tn tn tn ; - - if String.compare l_free_impl "" != 0 || String.compare r_free_impl "" != 0 - then - print - " if (map == NULL)\n\ - \ {\n\ - \ return;\n\ - \ }\n\n\ - \ size_t n = map->size;\n\ - \ for (size_t i = 0; i < n; i++)\n\ - \ {\n\ - \ %s\n\ - \ %s\n\ - \ }\n\n" - l_free_impl r_free_impl ; - - print " free(map);\n}\n" ; - - match (l, r) with - | Enum (_, _), _ -> - gen_enum_map_abstract_type print l r - | _, Enum (_, _) -> - gen_enum_map_abstract_type print l r - | _ -> - () - -and gen_enum_map_abstract_type print l r = - let tn = mapname l r in - print - "\n\n\ - static const struct_member %s_struct_members[] =\n\ - \ {\n\ - \ { .type = &%s,\n\ - \ .offset = offsetof(xen_%s_contents, key) },\n\ - \ { .type = &%s,\n\ - \ .offset = offsetof(xen_%s_contents, val) },\n\ - \ };\n\n\ - const abstract_type %s_abstract_type_ =\n\ - \ {\n\ - \ .XEN_API_TYPE = MAP,\n\ - \ .struct_size = sizeof(%s_struct_members),\n\ - \ .member_count =\n\ - \ sizeof(%s_struct_members) / sizeof(struct_member),\n\ - \ .members = %s_struct_members\n\ - \ };\n" - tn (abstract_type false l) tn (abstract_type false r) tn tn tn tn tn - -and write_enum_map_internal_decl name l r out_chan = - let print format = fprintf out_chan format in - let protect = protector (sprintf "%s_internal" name) in - - print_h_header out_chan protect ; - print "\nextern const abstract_type %s_abstract_type_;\n\n" (mapname l r) ; - print_h_footer out_chan - -and hash_include_enum = function - | Enum (x, _) -> - "\n" ^ hash_include x - | _ -> - "" - -and gen_failure_h () = - let protect = protector "api_failure" in - let out_chan = - open_out (Filename.concat destdir "include/xen/api/xen_api_failure.h") +and render_enum_map l r = + let x = mapname l r in + let json = + `O + [ + ("map_upper", `String (String.uppercase_ascii x)) + ; ("map_lower", `String (String.lowercase_ascii x)) + ] in - finally - (fun () -> - print_h_header out_chan protect ; - gen_failure_enum out_chan ; - gen_failure_funcs out_chan ; - print_h_footer out_chan + render_file + ( "xen_enum_map_internal.h.mustache" + , sprintf "include/xen_%s_internal.h" (String.lowercase_ascii x) ) - ~always:(fun () -> close_out out_chan) - -and gen_failure_enum out_chan = - let print format = fprintf out_chan format in - print "\nenum xen_api_failure\n{\n%s\n};\n\n\n" - (String.concat ",\n\n" (failure_enum_entries ())) - -and failure_enum_entries () = - let r = Hashtbl.fold failure_enum_entry Datamodel.errors [] in - let r = List.sort (fun (x, _) (y, _) -> String.compare y x) r in - let r = - failure_enum_entry "UNDEFINED" - { - err_doc= "Unknown to this version of the bindings." - ; err_params= [] - ; err_name= "UNDEFINED" - } - r + json templates_dir destdir + +and render_map_decl l r = + let headers = ref StringSet.empty in + let add_enum_header = function + | Enum (x, _) -> + headers := StringSet.add x !headers + | _ -> + () + in + add_enum_header l ; + add_enum_header r ; + let x = mapname l r in + let json = + `O + [ + ("key_type_lower", `String (c_type_of_ty headers false l)) + ; ("val_type_lower", `String (c_type_of_ty headers true r)) + ; ("map_upper", `String (String.uppercase_ascii x)) + ; ("map_lower", `String (String.lowercase_ascii x)) + ; ( "headers" + , `A + (List.map + (fun x -> `O [("header", `String x)]) + ("common" :: StringSet.elements !headers + |> List.map String.lowercase_ascii + |> List.sort String.compare + |> List.filter (fun x -> + not (Astring.String.is_suffix ~affix:"internal" x) + ) + ) + ) + ) + ] in - List.map (fun (_, y) -> y) (List.rev r) - -and failure_enum_entry name err acc = - ( name - , sprintf "%s\n %s" - (Helper.comment true ~indent:4 err.Datamodel_types.err_doc) - (failure_enum name) - ) - :: acc - -and gen_failure_funcs out_chan = - let print format = fprintf out_chan format in - print - "%s\n\ - extern const char *\n\ - xen_api_failure_to_string(enum xen_api_failure val);\n\n\n\ - %s\n\ - extern enum xen_api_failure\n\ - xen_api_failure_from_string(const char *str);\n\n" - (Helper.comment true - "Return the name corresponding to the given code. This string must not \ - be modified or freed." - ) - (Helper.comment true - "Return the correct code for the given string, or UNDEFINED if the \ - given string does not match a known code." - ) - -and gen_failure_c () = - let out_chan = open_out (Filename.concat destdir "src/xen_api_failure.c") in - let print format = fprintf out_chan format in - finally - (fun () -> - print - "%s\n\n\ - #include \"xen_internal.h\"\n\ - #include \n\n\n\ - /*\n\ - \ * Maintain this in the same order as the enum declaration!\n\ - \ */\n\ - static const char *lookup_table[] =\n\ - {\n\ - \ %s\n\ - };\n\n\n\ - const char *\n\ - xen_api_failure_to_string(enum xen_api_failure val)\n\ - {\n\ - \ return lookup_table[val];\n\ - }\n\n\n\ - extern enum xen_api_failure\n\ - xen_api_failure_from_string(const char *str)\n\ - {\n\ - \ return ENUM_LOOKUP(str, lookup_table);\n\ - }\n\n\n" - Licence.bsd_two_clause - (String.concat ",\n " (failure_lookup_entries ())) + if not (List.mem x !all_headers) then all_headers := x :: !all_headers ; + render_file + ( "map.h.mustache" + , sprintf "include/xen/api/xen_%s.h" (String.lowercase_ascii x) ) - ~always:(fun () -> close_out out_chan) - -and failure_lookup_entries () = - List.sort String.compare - (Hashtbl.fold failure_lookup_entry Datamodel.errors []) + json templates_dir destdir -and failure_lookup_entry name _ acc = sprintf "\"%s\"" name :: acc +and render_map_impl l r = + let x = mapname l r in + let headers = ref StringSet.empty in + headers := StringSet.add x !headers ; + find_needed headers l ; + find_needed headers r ; -and failure_enum name = "XEN_API_FAILURE_" ^ String.uppercase_ascii name - -and write_impl {name= classname; contents; messages; _} out_chan = - let is_event = classname = "event" in - let print format = fprintf out_chan format in - let needed = ref StringSet.empty in - let tn = typename classname in - let record_tn = record_typename classname in - let record_opt_tn = record_opt_typename classname in - let msgs = - impl_messages needed classname - (List.filter - (fun x -> not (classname = "event" && x.msg_name = "from")) - messages - ) - in - let record_free_handle = - if classname = "event" then "" else " free(record->handle);\n" - in - let record_free_impls = - joined "\n " (record_free_impl "record->") contents - in - let filtered_record_fields = - let not_obj_uuid x = - match x with Field r when r.field_name = "obj_uuid" -> false | _ -> true - in - if is_event then List.filter not_obj_uuid contents else contents - in - let record_fields = - joined ",\n " - (abstract_record_field classname "" "") - filtered_record_fields + let l_free_impl = free_impl "map->contents[i].key" false l in + let r_free_impl = free_impl "map->contents[i].val" true r in + let is_enum_map = + match (l, r) with Enum (_, _), _ | _, Enum (_, _) -> true | _ -> false in - let needed = ref StringSet.empty in - find_needed needed messages ; - needed := StringSet.add "internal" !needed ; - needed := StringSet.add classname !needed ; - - let getAllRecordsExists = - List.exists (fun x -> x.msg_name = "get_all_records") messages + let json = + `O + [ + ("abstract_type_key", `String (abstract_type false l)) + ; ("abstract_type_val", `String (abstract_type false r)) + ; ("map_upper", `String (String.uppercase_ascii x)) + ; ("map_lower", `String (String.lowercase_ascii x)) + ; ( "headers" + , `A + (List.map + (fun x -> `O [("header", `String x)]) + ("common" :: StringSet.elements !headers + |> List.map String.lowercase_ascii + |> List.sort String.compare + |> List.filter (fun x -> + not (Astring.String.is_suffix ~affix:"internal" x) + ) + ) + ) + ) + ; ( "internal_headers" + , `A + (List.map + (fun x -> `O [("header", `String x)]) + ("internal" :: StringSet.elements !headers + |> List.map String.lowercase_ascii + |> List.sort String.compare + |> List.filter (fun x -> + Astring.String.is_suffix ~affix:"internal" x + ) + ) + ) + ) + ; ("can_free_key", `Bool (String.compare l_free_impl "" != 0)) + ; ("can_free_val", `Bool (String.compare r_free_impl "" != 0)) + ; ( "can_free" + , `Bool + (String.compare l_free_impl "" != 0 + || String.compare r_free_impl "" != 0 + ) + ) + ; ("free_key", `String l_free_impl) + ; ("free_val", `String r_free_impl) + ; ("enum_map", `Bool is_enum_map) + ] in - let mappingName = sprintf "%s_%s" tn record_tn in - - let free_block = - String.concat "\n" - (( if is_event then - [] - else - [sprintf "XEN_FREE(%s)" tn; sprintf "XEN_SET_ALLOC_FREE(%s)" tn] - ) - @ [ - sprintf "XEN_ALLOC(%s)" record_tn - ; sprintf "XEN_SET_ALLOC_FREE(%s)" record_tn - ] - @ - if is_event then - [] - else - [ - sprintf "XEN_ALLOC(%s)" record_opt_tn - ; sprintf "XEN_RECORD_OPT_FREE(%s)" tn - ; sprintf "XEN_SET_ALLOC_FREE(%s)" record_opt_tn - ] + if not (List.mem x !all_headers) then all_headers := x :: !all_headers ; + render_file + ("map.c.mustache", sprintf "src/xen_%s.c" (String.lowercase_ascii x)) + json templates_dir destdir + +and gen_failure () = + let errors = + Hashtbl.fold + (fun _ x acc -> + (x.Datamodel_types.err_name, x.Datamodel_types.err_doc) :: acc ) + Datamodel.errors [] in + let errors = List.sort (fun (x, _) (y, _) -> String.compare x y) errors in + let json = + `O + [ + ( "api_errors" + , `A + (List.map + (fun (x, y) -> + `O + [ + ("api_error", `String (String.uppercase_ascii x)) + ; ("api_error_doc", `String (Helper.comment true ~indent:4 y)) + ] + ) + errors + ) + ) + ] + in + render_file + ("xen_api_failure.h.mustache", "include/xen/api/xen_api_failure.h") + json templates_dir destdir ; + render_file + ("xen_api_failure.c.mustache", "src/xen_api_failure.c") + json templates_dir destdir - print "%s\n\n\n#include \n#include \n\n%s\n\n\n%s\n\n\n" - Licence.bsd_two_clause (hash_includes !needed) free_block ; - - print - "static const struct_member %s_struct_members[] =\n\ - \ {\n\ - \ %s\n\ - \ };\n\n\ - const abstract_type %s_abstract_type_ =\n\ - \ {\n\ - \ .XEN_API_TYPE = STRUCT,\n\ - \ .struct_size = sizeof(%s),\n\ - \ .member_count =\n\ - \ sizeof(%s_struct_members) / sizeof(struct_member),\n\ - \ .members = %s_struct_members\n\ - \ };\n\n\n" - record_tn record_fields record_tn record_tn record_tn record_tn ; - - print - "const abstract_type %s_set_abstract_type_ =\n\ - \ {\n\ - \ .XEN_API_TYPE = SET,\n\ - \ .child = &%s_abstract_type_\n\ - \ };\n\n\n" - record_tn record_tn ; - - if getAllRecordsExists then - print - "static const struct struct_member %s_members[] =\n\ - {\n\ - \ {\n\ - \ .type = &abstract_type_string,\n\ - \ .offset = offsetof(%s_map_contents, key)\n\ - \ },\n\ - \ {\n\ - \ .type = &%s_abstract_type_,\n\ - \ .offset = offsetof(%s_map_contents, val)\n\ - \ }\n\ - };\n\n\ - const abstract_type abstract_type_string_%s_map =\n\ - {\n\ - \ .XEN_API_TYPE = MAP,\n\ - \ .struct_size = sizeof(%s_map_contents),\n\ - \ .members = %s_members\n\ - };\n\n\n" - mappingName mappingName record_tn mappingName record_tn mappingName - mappingName ; - - print - "void\n\ - %s_free(%s *record)\n\ - {\n\ - \ if (record == NULL)\n\ - \ {\n\ - \ return;\n\ - \ }\n\ - %s %s\n\ - \ free(record);\n\ - }\n\n\n" - record_tn record_tn record_free_handle record_free_impls ; - - print "%s\n" msgs - -and find_needed needed messages = List.iter (find_needed' needed) messages - -and find_needed' needed message = - List.iter (fun p -> find_needed'' needed p.param_type) message.msg_params ; - match message.msg_result with - | Some (x, _) -> - find_needed'' needed x - | None -> - () - -and find_needed'' needed = function +and find_needed needed = function | SecretString | String | Int | Float | Bool | DateTime -> () | Enum (n, _) -> @@ -1227,13 +729,7 @@ and find_needed'' needed = function | Record n -> needed := StringSet.add n !needed | Option x -> - find_needed'' needed x - -and record_free_impl prefix = function - | Field fr -> - free_impl (prefix ^ fieldname fr.field_name) true fr.ty - | Namespace (p, c) -> - joined "\n " (record_free_impl (prefix ^ fieldname p ^ "_")) c + find_needed needed x and free_impl val_name record = function | SecretString | String -> @@ -1303,7 +799,7 @@ and c_type_of_ty needed record = function | Enum (name, _) as x -> needed := StringSet.add name !needed ; enums := TypeSet.add x !enums ; - c_type_of_enum name + sprintf "enum %s " (typename name) | Set (Ref name) -> needed := StringSet.add (name ^ "_decl") !needed ; if record then @@ -1356,23 +852,13 @@ and c_type_of_ty needed record = function | Option (Enum (name, _) as x) -> needed := StringSet.add name !needed ; enums := TypeSet.add x !enums ; - c_type_of_enum name ^ " *" + sprintf "enum %s *" (typename name) | Option n -> c_type_of_ty needed record n | x -> eprintf "%s" (Types.to_string x) ; assert false -and c_type_of_enum name = sprintf "enum %s " (typename name) - -and initialiser_of_ty = function - | SecretString | String | Ref _ | Set _ | Map _ | Record _ -> - " *result = NULL;\n" - | _ -> - "" - -and mapname l r = sprintf "%s_%s_map" (name_of_ty l) (name_of_ty r) - and name_of_ty = function | SecretString | String -> "string" @@ -1398,43 +884,14 @@ and name_of_ty = function eprintf "%s" (Types.to_string x) ; assert false -and decl_filename name = - let dir = - if Astring.String.is_suffix ~affix:"internal" name then "" else "xen/api/" - in - sprintf "%sxen_%s.h" dir (String.lowercase_ascii name) - -and predecl_filename name = - sprintf "xen/api/xen_%s_decl.h" (String.lowercase_ascii name) - -and internal_decl_filename name = - sprintf "xen_%s_internal.h" (String.lowercase_ascii name) - -and impl_filename name = sprintf "xen_%s.c" (String.lowercase_ascii name) - -and internal_impl_filename name = - sprintf "xen_%s_internal.c" (String.lowercase_ascii name) - -and protector classname = sprintf "XEN_%s_H" (String.uppercase_ascii classname) +and mapname l r = sprintf "%s_%s_map" (name_of_ty l) (name_of_ty r) and typename classname = sprintf "xen_%s" (String.lowercase_ascii classname) -and variablename classname = sprintf "%s" (String.lowercase_ascii classname) - and record_typename classname = sprintf "%s_record" (typename classname) and record_opt_typename classname = sprintf "%s_record_opt" (typename classname) -and messagename classname name = - sprintf "xen_%s_%s" - (String.lowercase_ascii classname) - (String.lowercase_ascii name) - -and messagename_async classname name = - sprintf "xen_%s_%s_async" - (String.lowercase_ascii classname) - (String.lowercase_ascii name) - and keyword_map name = let keywords = [("class", "XEN_CLAZZ"); ("public", "pubblic")] in if List.mem_assoc name keywords then List.assoc name keywords else name @@ -1443,14 +900,6 @@ and paramname name = keyword_map (String.lowercase_ascii name) and fieldname name = keyword_map (String.lowercase_ascii name) -and print_h_header out_chan protect = - let print format = fprintf out_chan format in - print "%s\n\n" Licence.bsd_two_clause ; - print "#ifndef %s\n" protect ; - print "#define %s\n\n" protect - -and print_h_footer out_chan = fprintf out_chan "\n#endif\n" - and populate_version () = List.iter (fun x -> render_file x json_releases templates_dir destdir) @@ -1460,4 +909,4 @@ and populate_version () = ; ("xen_api_version.c.mustache", "src/xen_api_version.c") ] -let _ = main () ; populate_version () +let _ = main () ; gen_failure () ; populate_version () diff --git a/ocaml/sdk-gen/c/gen_c_binding.mli b/ocaml/sdk-gen/c/gen_c_binding.mli new file mode 100644 index 00000000000..c8b99626f9c --- /dev/null +++ b/ocaml/sdk-gen/c/gen_c_binding.mli @@ -0,0 +1 @@ +(* Empty .mli to ensure unused functions are picked up during check*) diff --git a/ocaml/sdk-gen/c/helper.mli b/ocaml/sdk-gen/c/helper.mli new file mode 100644 index 00000000000..ea32b78f207 --- /dev/null +++ b/ocaml/sdk-gen/c/helper.mli @@ -0,0 +1,13 @@ +val formatted_wrap : Format.formatter -> string -> unit +(** Recursively formats the input string + based on spaces and new lines, ensuring proper indentation. + + @param formatter The formatter to output the formatted string. + @param s The input string to be formatted. *) + +val comment : bool -> ?indent:int -> string -> string +(** Formats a comment block with optional indentation. + @param indent Optional indentation level. + @param doc Include an extra '*' for documentation. + @param s String content of the comment. + @return Formatted comment block. *) diff --git a/ocaml/sdk-gen/c/templates/Makefile.mustache b/ocaml/sdk-gen/c/templates/Makefile.mustache index 384ffcb174d..ac78e5ca1e6 100644 --- a/ocaml/sdk-gen/c/templates/Makefile.mustache +++ b/ocaml/sdk-gen/c/templates/Makefile.mustache @@ -29,7 +29,9 @@ DESTDIR=/usr/local -ifeq ($(CYGWIN), 1) +UNAME_S := $(shell uname -s) + +ifeq ($(findstring CYGWIN,$(UNAME_S)),CYGWIN) CYGWIN_LIBXML = -L/bin -lxml2-2 POS_FLAG = -U__STRICT_ANSI__ else @@ -80,7 +82,7 @@ install: build $(INSTALL_DATA) libxenserver.so.{{API_VERSION_MAJOR}}.{{API_VERSION_MINOR}} $(DESTDIR)/lib ln -sf libxenserver.so.{{API_VERSION_MAJOR}}.{{API_VERSION_MINOR}} $(DESTDIR)/lib/libxenserver.so.{{API_VERSION_MAJOR}} ln -sf libxenserver.so.{{API_VERSION_MAJOR}} $(DESTDIR)/lib/libxenserver.so -ifeq ($(CYGWIN), 1) +ifeq ($(findstring CYGWIN,$(UNAME_S)),CYGWIN) ln -sf libxenserver.so $(DESTDIR)/lib/libxenserver.dll endif $(INSTALL_DATA) libxenserver.a $(DESTDIR)/lib @@ -95,3 +97,4 @@ clean: .PHONY: clean build install .DEFAULT_GOAL := build + diff --git a/ocaml/sdk-gen/c/templates/class.c.mustache b/ocaml/sdk-gen/c/templates/class.c.mustache new file mode 100644 index 00000000000..55f6da267ae --- /dev/null +++ b/ocaml/sdk-gen/c/templates/class.c.mustache @@ -0,0 +1,192 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#include +#include + +{{#internal_headers}} +#include "xen_{{header}}.h" +{{/internal_headers}} +{{#headers}} +#include +{{/headers}} + + +{{^is_event}} +XEN_FREE(xen_{{{class_lower}}}) +XEN_SET_ALLOC_FREE(xen_{{{class_lower}}}) +{{/is_event}} +XEN_ALLOC(xen_{{{class_lower}}}_record) +XEN_SET_ALLOC_FREE(xen_{{{class_lower}}}_record) +{{^is_event}} +XEN_ALLOC(xen_{{{class_lower}}}_record_opt) +XEN_RECORD_OPT_FREE(xen_{{{class_lower}}}) +XEN_SET_ALLOC_FREE(xen_{{{class_lower}}}_record_opt) +{{/is_event}} + + +static const struct_member xen_{{{class_lower}}}_record_struct_members[] = + { +{{#fields}} + { .key = "{{{field_name}}}", + .type = &{{{abstract_field_type}}}, + .offset = offsetof(xen_{{{class_lower}}}_record, {{{field_name_lower}}}) }{{^is_last}},{{/is_last}} +{{/fields}} + }; + + +const abstract_type xen_{{{class_lower}}}_record_abstract_type_ = + { + .XEN_API_TYPE = STRUCT, + .struct_size = sizeof(xen_{{{class_lower}}}_record), + .member_count = + sizeof(xen_{{{class_lower}}}_record_struct_members) / sizeof(struct_member), + .members = xen_{{{class_lower}}}_record_struct_members + }; + + +const abstract_type xen_{{{class_lower}}}_record_set_abstract_type_ = + { + .XEN_API_TYPE = SET, + .child = &xen_{{{class_lower}}}_record_abstract_type_ + }; +{{#has_all_records}} + + +static const struct struct_member xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_members[] = +{ + { + .type = &abstract_type_string, + .offset = offsetof(xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_map_contents, key) + }, + { + .type = &xen_{{{class_lower}}}_record_abstract_type_, + .offset = offsetof(xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_map_contents, val) + } +}; + + +const abstract_type abstract_type_string_xen_{{{class_lower}}}_record_map = +{ + .XEN_API_TYPE = MAP, + .struct_size = sizeof(xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_map_contents), + .members = xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_members +}; +{{/has_all_records}} + + +void +xen_{{{class_lower}}}_record_free(xen_{{{class_lower}}}_record *record) +{ + if (record == NULL) + return; + +{{^is_event}} + free(record->handle); +{{/is_event}} +{{#fields}} +{{#can_free}} + {{{free_record_field}}} +{{/can_free}} +{{/fields}} + free(record); +} +{{#messages}} + + +bool +xen_{{{class_lower}}}_{{{msg_name_lower}}}(xen_session *session{{#sync_params}}, {{{param_type}}}{{{param_name}}}{{/sync_params}}) +{ +{{#has_params}} + abstract_value param_values[] = + { +{{#msg_params}} + { .type = &{{{abstract_param_type}}}, + .u.{{{abstract_member}}}_val = {{{abstract_member_conv}}} }{{^is_last}},{{/is_last}} +{{/msg_params}} + }; +{{/has_params}} +{{#has_result}} + + abstract_type result_type = {{{abstract_result_type}}}; +{{/has_result}} + +{{#init_result}} + *result = NULL; +{{/init_result}} +{{#has_result}} +{{#has_params}} + XEN_CALL_("{{{class_name}}}.{{{msg_name}}}"); +{{/has_params}} +{{^has_params}} + xen_call_(session, "{{{class_name}}}.{{{msg_name}}}", NULL, 0, &result_type, result); +{{/has_params}} +{{/has_result}} +{{^has_result}} + xen_call_(session, "{{{class_name}}}.{{{msg_name}}}", {{#has_params}}param_values{{/has_params}}{{^has_params}}NULL{{/has_params}}, {{param_count}}, NULL, NULL); +{{/has_result}} +{{#is_result_record}} + + if (session->ok) + (*result)->handle = xen_strdup_((*result)->uuid); + +{{/is_result_record}} + return session->ok; +} +{{#is_async}} + + +bool +xen_{{{class_lower}}}_{{{msg_name_lower}}}_async(xen_session *session{{#async_params}}, {{{param_type}}}{{{param_name}}}{{/async_params}}) +{ +{{#has_params}} + abstract_value param_values[] = + { +{{#msg_params}} + { .type = &{{{abstract_param_type}}}, + .u.{{{abstract_member}}}_val = {{{abstract_member_conv}}} }{{^is_last}},{{/is_last}} +{{/msg_params}} + }; +{{/has_params}} + + abstract_type result_type = abstract_type_string; + + *result = NULL; +{{#has_params}} + XEN_CALL_("Async.{{{class_name}}}.{{{msg_name}}}"); +{{/has_params}} +{{^has_params}} + xen_call_(session, "Async.{{{class_name}}}.{{{msg_name}}}", NULL, 0, &result_type, result); +{{/has_params}} + return session->ok; +} +{{/is_async}} +{{/messages}} + diff --git a/ocaml/sdk-gen/c/templates/class.h.mustache b/ocaml/sdk-gen/c/templates/class.h.mustache new file mode 100644 index 00000000000..98dd1f37446 --- /dev/null +++ b/ocaml/sdk-gen/c/templates/class.h.mustache @@ -0,0 +1,179 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#ifndef XEN_{{{class_upper}}}_H +#define XEN_{{{class_upper}}}_H + +{{#headers}} +#include +{{/headers}} + + +{{{class_doc}}} + + +{{^is_event}} +/** + * Free the given xen_{{{class_lower}}}. The given handle must have been + * allocated by this library. + */ +extern void +xen_{{{class_lower}}}_free(xen_{{{class_lower}}} {{{class_lower}}}); + + +typedef struct xen_{{{class_lower}}}_set +{ + size_t size; + xen_{{{class_lower}}} *contents[]; +} xen_{{{class_lower}}}_set; + +/** + * Allocate a xen_{{{class_lower}}}_set of the given size. + */ +extern xen_{{{class_lower}}}_set * +xen_{{{class_lower}}}_set_alloc(size_t size); + +/** + * Free the given xen_{{{class_lower}}}_set. The given set must have been + * allocated by this library. + */ +extern void +xen_{{{class_lower}}}_set_free(xen_{{{class_lower}}}_set *set); + + +{{/is_event}} +typedef struct xen_{{{class_lower}}}_record +{ +{{^is_event}} + xen_{{{class_lower}}} handle; +{{/is_event}} +{{#fields}} + {{{field_type}}}{{{field_name_lower}}}; +{{/fields}} +} xen_{{{class_lower}}}_record; + +/** + * Allocate a xen_{{{class_lower}}}_record. + */ +extern xen_{{{class_lower}}}_record * +xen_{{{class_lower}}}_record_alloc(void); + +/** + * Free the given xen_{{{class_lower}}}_record, and all referenced values. + * The given record must have been allocated by this library. + */ +extern void +xen_{{{class_lower}}}_record_free(xen_{{{class_lower}}}_record *record); + + +{{^is_event}} +typedef struct xen_{{{class_lower}}}_record_opt +{ + bool is_record; + union + { + xen_{{{class_lower}}} handle; + xen_{{{class_lower}}}_record *record; + } u; +} xen_{{{class_lower}}}_record_opt; + +/** + * Allocate a xen_{{{class_lower}}}_record_opt. + */ +extern xen_{{{class_lower}}}_record_opt * +xen_{{{class_lower}}}_record_opt_alloc(void); + +/** + * Free the given xen_{{{class_lower}}}_record_opt, and all referenced values. + * The given record_opt must have been allocated by this library. + */ +extern void +xen_{{{class_lower}}}_record_opt_free(xen_{{{class_lower}}}_record_opt *record_opt); + + +{{/is_event}} +typedef struct xen_{{{class_lower}}}_record_set +{ + size_t size; + xen_{{{class_lower}}}_record *contents[]; +} xen_{{{class_lower}}}_record_set; + +/** + * Allocate a xen_{{{class_lower}}}_record_set of the given size. + */ +extern xen_{{{class_lower}}}_record_set * +xen_{{{class_lower}}}_record_set_alloc(size_t size); + +/** + * Free the given xen_{{{class_lower}}}_record_set, and all referenced values. + * The given set must have been allocated by this library. + */ +extern void +xen_{{{class_lower}}}_record_set_free(xen_{{{class_lower}}}_record_set *set); + + +{{^is_event}} +typedef struct xen_{{{class_lower}}}_record_opt_set +{ + size_t size; + xen_{{{class_lower}}}_record_opt *contents[]; +} xen_{{{class_lower}}}_record_opt_set; + +/** + * Allocate a xen_{{{class_lower}}}_record_opt_set of the given size. + */ +extern xen_{{{class_lower}}}_record_opt_set * +xen_{{{class_lower}}}_record_opt_set_alloc(size_t size); + +/** + * Free the given xen_{{{class_lower}}}_record_opt_set, and all referenced + * values. The given set must have been allocated by this library. + */ +extern void +xen_{{{class_lower}}}_record_opt_set_free(xen_{{{class_lower}}}_record_opt_set *set); + + +{{/is_event}} +{{#messages}} +{{{msg_doc}}} +extern bool +xen_{{{class_lower}}}_{{{msg_name_lower}}}(xen_session *session{{#sync_params}}, {{{param_type}}}{{{param_name}}}{{/sync_params}}); + + +{{#is_async}} +{{{msg_doc}}} +extern bool +xen_{{{class_lower}}}_{{{msg_name_lower}}}_async(xen_session *session{{#async_params}}, {{{param_type}}}{{{param_name}}}{{/async_params}}); + + +{{/is_async}} +{{/messages}} +#endif + diff --git a/ocaml/sdk-gen/c/templates/class_decl.h.mustache b/ocaml/sdk-gen/c/templates/class_decl.h.mustache new file mode 100644 index 00000000000..521d3d49d40 --- /dev/null +++ b/ocaml/sdk-gen/c/templates/class_decl.h.mustache @@ -0,0 +1,47 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#ifndef XEN_{{{class_upper}}}_DECL_H +#define XEN_{{{class_upper}}}_DECL_H + +{{^is_event}} +typedef void *xen_{{{class_lower}}}; + +struct xen_{{{class_lower}}}_set; +{{/is_event}} +struct xen_{{{class_lower}}}_record; +struct xen_{{{class_lower}}}_record_set; +{{^is_event}} +struct xen_{{{class_lower}}}_record_opt; +struct xen_{{{class_lower}}}_record_opt_set; +{{/is_event}} + +#endif + diff --git a/ocaml/sdk-gen/c/templates/map.c.mustache b/ocaml/sdk-gen/c/templates/map.c.mustache new file mode 100644 index 00000000000..0b944b35ad3 --- /dev/null +++ b/ocaml/sdk-gen/c/templates/map.c.mustache @@ -0,0 +1,92 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +{{#internal_headers}} +#include "xen_{{{header}}}.h" +{{/internal_headers}} +{{#headers}} +#include +{{/headers}} + + +xen_{{{map_lower}}} * +xen_{{{map_lower}}}_alloc(size_t size) +{ + xen_{{{map_lower}}} *result = + calloc(1, sizeof(xen_{{{map_lower}}}) + + size * sizeof(struct xen_{{{map_lower}}}_contents)); + result->size = size; + return result; +} + + +void +xen_{{{map_lower}}}_free(xen_{{{map_lower}}} *map) +{ +{{#can_free}} + if (map == NULL) + return; + + size_t n = map->size; + for (size_t i = 0; i < n; i++) + { +{{#can_free_key}} + {{{free_key}}} +{{/can_free_key}} +{{#can_free_val}} + {{{free_val}}} +{{/can_free_val}} + } + +{{/can_free}} + free(map); +} +{{#enum_map}} + + +static const struct_member {{{map_lower}}}_struct_members[] = + { + { .type = &{{{abstract_type_key}}}, + .offset = offsetof(xen_{{{map_lower}}}_contents, key) }, + { .type = &{{{abstract_type_val}}}, + .offset = offsetof(xen_{{{map_lower}}}_contents, val) }, + }; + + +const abstract_type {{{map_lower}}}_abstract_type_ = + { + .XEN_API_TYPE = MAP, + .struct_size = sizeof({{{map_lower}}}_struct_members), + .member_count = + sizeof({{{map_lower}}}_struct_members) / sizeof(struct_member), + .members = {{{map_lower}}}_struct_members + }; +{{/enum_map}} + diff --git a/ocaml/sdk-gen/c/templates/map.h.mustache b/ocaml/sdk-gen/c/templates/map.h.mustache new file mode 100644 index 00000000000..aa7c96bf512 --- /dev/null +++ b/ocaml/sdk-gen/c/templates/map.h.mustache @@ -0,0 +1,68 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#ifndef XEN_{{{map_upper}}}_H +#define XEN_{{{map_upper}}}_H + + +{{#headers}} +#include +{{/headers}} + + +typedef struct xen_{{{map_lower}}}_contents +{ + {{{key_type_lower}}}key; + {{{val_type_lower}}}val; +} xen_{{{map_lower}}}_contents; + + +typedef struct xen_{{{map_lower}}} +{ + size_t size; + xen_{{{map_lower}}}_contents contents[]; +} xen_{{{map_lower}}}; + +/** + * Allocate a xen_{{{map_lower}}} of the given size. + */ +extern xen_{{{map_lower}}} * +xen_{{{map_lower}}}_alloc(size_t size); + +/** + * Free the given xen_{{{map_lower}}} + * and all referenced values. The map must have been allocated by this library. + */ +extern void +xen_{{{map_lower}}}_free(xen_{{{map_lower}}} *map); + + +#endif + diff --git a/ocaml/sdk-gen/c/templates/xen_all.h.mustache b/ocaml/sdk-gen/c/templates/xen_all.h.mustache index 9d9bef9143e..fb86a54f4ef 100644 --- a/ocaml/sdk-gen/c/templates/xen_all.h.mustache +++ b/ocaml/sdk-gen/c/templates/xen_all.h.mustache @@ -27,7 +27,6 @@ * OF THE POSSIBILITY OF SUCH DAMAGE. */ -/* This file is autogenerated */ #ifndef XEN_API_XEN_ALL_H #define XEN_API_XEN_ALL_H @@ -37,9 +36,10 @@ #include #include {{#api_headers}} -#include <{{api_header}}> +#include {{/api_headers}} #include #include #endif + diff --git a/ocaml/sdk-gen/c/templates/xen_api_failure.c.mustache b/ocaml/sdk-gen/c/templates/xen_api_failure.c.mustache new file mode 100644 index 00000000000..f35926bfce1 --- /dev/null +++ b/ocaml/sdk-gen/c/templates/xen_api_failure.c.mustache @@ -0,0 +1,58 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#include "xen_internal.h" +#include + + +/* + * Maintain this in the same order as the enum declaration! + */ +static const char *lookup_table[] = +{ +{{#api_errors}} + "{{api_error}}", +{{/api_errors}} +}; + + +const char * +xen_api_failure_to_string(enum xen_api_failure val) +{ + return lookup_table[val]; +} + + +extern enum xen_api_failure +xen_api_failure_from_string(const char *str) +{ + return ENUM_LOOKUP(str, lookup_table); +} + diff --git a/ocaml/sdk-gen/c/templates/xen_api_failure.h.mustache b/ocaml/sdk-gen/c/templates/xen_api_failure.h.mustache new file mode 100644 index 00000000000..3094d7a51ea --- /dev/null +++ b/ocaml/sdk-gen/c/templates/xen_api_failure.h.mustache @@ -0,0 +1,66 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#ifndef XEN_API_FAILURE_H +#define XEN_API_FAILURE_H + + +enum xen_api_failure +{ +{{#api_errors}} +{{{api_error_doc}}} + XEN_API_FAILURE_{{api_error}}, + +{{/api_errors}} + /** + * Unknown to this SDK version. + */ + XEN_API_FAILURE_UNDEFINED +}; + + +/** + * Return the name corresponding to the given code. This string must + * not be modified or freed. + */ +extern const char * +xen_api_failure_to_string(enum xen_api_failure val); + + +/** + * Return the correct code for the given string, or UNDEFINED if the + * given string does not match a known code. + */ +extern enum xen_api_failure +xen_api_failure_from_string(const char *str); + + +#endif + diff --git a/ocaml/sdk-gen/c/templates/xen_api_version.c.mustache b/ocaml/sdk-gen/c/templates/xen_api_version.c.mustache index 0a13575d334..94b0c894b47 100644 --- a/ocaml/sdk-gen/c/templates/xen_api_version.c.mustache +++ b/ocaml/sdk-gen/c/templates/xen_api_version.c.mustache @@ -27,6 +27,7 @@ * OF THE POSSIBILITY OF SUCH DAMAGE. */ + #include "xen/api/xen_api_version.h" const char * @@ -53,3 +54,4 @@ xen_api_version_from_int(int64_t major_version, int64_t minor_version) {{/releases}} return xen_api_unknown_version; } + diff --git a/ocaml/sdk-gen/c/templates/xen_api_version.h.mustache b/ocaml/sdk-gen/c/templates/xen_api_version.h.mustache index 5f55ec79291..09115486aa6 100644 --- a/ocaml/sdk-gen/c/templates/xen_api_version.h.mustache +++ b/ocaml/sdk-gen/c/templates/xen_api_version.h.mustache @@ -27,6 +27,7 @@ * OF THE POSSIBILITY OF SUCH DAMAGE. */ + #ifndef XEN_API_VERSION_H #define XEN_API_VERSION_H @@ -48,3 +49,4 @@ extern xen_api_version xen_api_version_from_int(int64_t major_version, int64_t minor_version); #endif + diff --git a/ocaml/sdk-gen/c/templates/xen_enum.c.mustache b/ocaml/sdk-gen/c/templates/xen_enum.c.mustache new file mode 100644 index 00000000000..90b1d200868 --- /dev/null +++ b/ocaml/sdk-gen/c/templates/xen_enum.c.mustache @@ -0,0 +1,99 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#include + +#include "xen_internal.h" +#include +#include "xen_{{{enum_name}}}_internal.h" + + +/* + * Maintain this in the same order as the enum declaration! + */ +static const char *lookup_table[] = +{ +{{#enum_values}} + "{{{enum_value}}}", +{{/enum_values}} + "undefined" +}; + + +extern xen_{{{enum_name}}}_set * +xen_{{{enum_name}}}_set_alloc(size_t size) +{ + return calloc(1, sizeof(xen_{{{enum_name}}}_set) + + size * sizeof(enum xen_{{{enum_name}}})); +} + + +extern void +xen_{{{enum_name}}}_set_free(xen_{{{enum_name}}}_set *set) +{ + free(set); +} + + +const char * +xen_{{{enum_name}}}_to_string(enum xen_{{{enum_name}}} val) +{ + return lookup_table[val]; +} + + +extern enum xen_{{{enum_name}}} +xen_{{{enum_name}}}_from_string(xen_session *session, const char *str) +{ + (void)session; + return ENUM_LOOKUP(str, lookup_table); +} + + +const abstract_type xen_{{{enum_name}}}_abstract_type_ = + { + .XEN_API_TYPE = ENUM, + .enum_marshaller = + (const char *(*)(int))&xen_{{{enum_name}}}_to_string, + .enum_demarshaller = + (int (*)(xen_session *, const char *))&xen_{{{enum_name}}}_from_string + }; + + +{{^event_operations}} +const abstract_type xen_{{{enum_name}}}_set_abstract_type_ = + { + .XEN_API_TYPE = SET, + .child = &xen_{{{enum_name}}}_abstract_type_ + }; + + +{{/event_operations}} + diff --git a/ocaml/sdk-gen/c/templates/xen_enum.h.mustache b/ocaml/sdk-gen/c/templates/xen_enum.h.mustache new file mode 100644 index 00000000000..3a944a71438 --- /dev/null +++ b/ocaml/sdk-gen/c/templates/xen_enum.h.mustache @@ -0,0 +1,90 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#ifndef XEN_{{{enum_name_upper}}}_H +#define XEN_{{{enum_name_upper}}}_H + + +#include + + +enum xen_{{{enum_name}}} +{ +{{#enum_values}} +{{{enum_value_doc}}} + XEN_{{{enum_name_upper}}}_{{{enum_value_upper}}}, + +{{/enum_values}} + /** + * Unknown to this SDK version. + */ + XEN_{{{enum_name_upper}}}_UNDEFINED +}; + + +typedef struct xen_{{{enum_name}}}_set +{ + size_t size; + enum xen_{{{enum_name}}} contents[]; +} xen_{{{enum_name}}}_set; + +/** + * Allocate a xen_{{{enum_name}}}_set of the given size. + */ +extern xen_{{{enum_name}}}_set * +xen_{{{enum_name}}}_set_alloc(size_t size); + +/** + * Free the given xen_{{{enum_name}}}_set. The given set must + * have been allocated by this library. + */ +extern void +xen_{{{enum_name}}}_set_free(xen_{{{enum_name}}}_set *set); + + +/** + * Return the name corresponding to the given code. This string must + * not be modified or freed. + */ +extern const char * +xen_{{{enum_name}}}_to_string(enum xen_{{{enum_name}}} val); + + +/** + * Return the correct code for the given string, or set the session + * object to failure and return an undefined value if the given string does + * not match a known code. + */ +extern enum xen_{{{enum_name}}} +xen_{{{enum_name}}}_from_string(xen_session *session, const char *str); + + +#endif + diff --git a/ocaml/sdk-gen/c/templates/xen_enum_internal.h.mustache b/ocaml/sdk-gen/c/templates/xen_enum_internal.h.mustache new file mode 100644 index 00000000000..f3945be9738 --- /dev/null +++ b/ocaml/sdk-gen/c/templates/xen_enum_internal.h.mustache @@ -0,0 +1,49 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +/* + * Declarations of the abstract types used during demarshalling of enum + * xen_{{{enum_name}}}. + */ + + +#ifndef XEN_{{{enum_name_upper}}}_INTERNAL_H +#define XEN_{{{enum_name_upper}}}_INTERNAL_H + + +#include "xen_internal.h" + + +extern const abstract_type xen_{{{enum_name}}}_abstract_type_; +extern const abstract_type xen_{{{enum_name}}}_set_abstract_type_; + + +#endif + diff --git a/ocaml/sdk-gen/c/templates/xen_enum_map_internal.h.mustache b/ocaml/sdk-gen/c/templates/xen_enum_map_internal.h.mustache new file mode 100644 index 00000000000..6d595ad16fc --- /dev/null +++ b/ocaml/sdk-gen/c/templates/xen_enum_map_internal.h.mustache @@ -0,0 +1,39 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +#ifndef XEN_{{{map_upper}}}_INTERNAL_H +#define XEN_{{{map_upper}}}_INTERNAL_H + + +extern const abstract_type {{{map_lower}}}_abstract_type_; + + +#endif + diff --git a/ocaml/sdk-gen/c/templates/xen_internal.mustache b/ocaml/sdk-gen/c/templates/xen_internal.mustache index 934ae5047e0..621617511ce 100644 --- a/ocaml/sdk-gen/c/templates/xen_internal.mustache +++ b/ocaml/sdk-gen/c/templates/xen_internal.mustache @@ -27,6 +27,7 @@ * OF THE POSSIBILITY OF SUCH DAMAGE. */ + #ifndef XEN_INTERNAL_H #define XEN_INTERNAL_H @@ -208,3 +209,4 @@ void type__ ## _record_opt_free(type__ ## _record_opt *opt) { \ #endif + diff --git a/ocaml/sdk-gen/common/CommonFunctions.ml b/ocaml/sdk-gen/common/CommonFunctions.ml index 2d046933bf1..12ef3420d31 100644 --- a/ocaml/sdk-gen/common/CommonFunctions.ml +++ b/ocaml/sdk-gen/common/CommonFunctions.ml @@ -11,13 +11,6 @@ type wireProtocol = XmlRpc | JsonRpc type rpm_version = {major: int; minor: int; micro: int} -let finally f ~(always : unit -> unit) = - match f () with - | result -> - always () ; result - | exception e -> - always () ; raise e - let parse_to_rpm_version_option inputStr = try Scanf.sscanf inputStr "%d.%d.%d" (fun x y z -> @@ -27,21 +20,18 @@ let parse_to_rpm_version_option inputStr = let string_of_file filename = let in_channel = open_in filename in - finally + Fun.protect (fun () -> let rec read_lines acc = try read_lines (input_line in_channel :: acc) with End_of_file -> acc in read_lines [] |> List.rev |> String.concat "\n" ) - ~always:(fun () -> close_in in_channel) + ~finally:(fun () -> close_in in_channel) let with_output filename f = let io = open_out filename in - finally (fun () -> f io) ~always:(fun () -> close_out io) - -let joined sep f l = - l |> List.map f |> List.filter (fun x -> x <> "") |> String.concat sep + Fun.protect (fun () -> f io) ~finally:(fun () -> close_out io) let escape_xml s = s @@ -132,6 +122,9 @@ let get_prototyped_release lifecycle = let get_published_release lifecycle = lifecycle_matcher Lifecycle.Published lifecycle +let get_deprecated_release lifecycle = + lifecycle_matcher Lifecycle.Published lifecycle + let get_release_branding codename = try let found = @@ -272,9 +265,9 @@ and render_template template_file json output_file = let templ = string_of_file template_file |> Mustache.of_string in let rendered = Mustache.render templ json in let out_chan = open_out output_file in - finally + Fun.protect (fun () -> output_string out_chan rendered) - ~always:(fun () -> close_out out_chan) + ~finally:(fun () -> close_out out_chan) let render_file (infile, outfile) json templates_dir dest_dir = let input_path = Filename.concat templates_dir infile in diff --git a/ocaml/sdk-gen/common/CommonFunctions.mli b/ocaml/sdk-gen/common/CommonFunctions.mli new file mode 100644 index 00000000000..9a88b5cd5bd --- /dev/null +++ b/ocaml/sdk-gen/common/CommonFunctions.mli @@ -0,0 +1,131 @@ +(** Exception for unknown wire protocol. *) +exception Unknown_wire_protocol + +(** Type representing supported protocols. *) +type wireProtocol = XmlRpc | JsonRpc + +val get_deprecated_release : + (Datamodel_types.Lifecycle.change * string * 'a) list -> string +(** [get_deprecated_release codename] Gets the non-branded release name for a lifecycle if it's deprecated + @param lifecycle The lifecycle transitions to check. + @return The non-branded release name for a lifecycle if it's deprecated, empty if not deprecated *) + +val get_release_branding : string -> string +(** [get_release_branding codename] Gets the branding for a release codename. + @param codename Release codename to lookup. + @return Branding for the release codename, or the original codename if not found. *) + +val is_setter : Datamodel_types.message -> bool +(** [is_setter message] Checks if a message is a setter based on its name. + @param message Message to check. + @return [true] if the message is a setter, [false] otherwise. *) + +val is_getter : Datamodel_types.message -> bool +(** [is_getter message] Checks if a message is a getter based on its name. + @param message Message to check. + @return [true] if the message is a getter, [false] otherwise. *) + +val get_deprecated_info_message : Datamodel_types.message -> string +(** [get_deprecated_info_message message] Returns a deprecated information message + based on the internal_deprecated_since version in the input message. + @param message Message containing version information. + @return Deprecated information message or an empty string if not deprecated. *) + +val is_adder : Datamodel_types.message -> bool +(** [is_adder message] Checks if a message is an adder based on its name. + @param message Message to check. + @return [true] if the message is an adder, [false] otherwise. *) + +val get_published_info_class : Datamodel_types.obj -> string +(** [get_published_info_class cls] Returns information about the first publication + of a class based on its lifecycle transitions. + @param cls Class to retrieve publication information for. + @return Information string with the first published version. *) + +val is_method_static : Datamodel_types.message -> bool +(** [is_method_static message] Checks if a method is static based on its parameters. + @param message Message to check. + @return [true] if the method is static, [false] otherwise. *) + +val escape_xml : string -> string +(** [escape_xml s] Escapes XML special characters in a string. + @param s String to escape. + @return String with XML special characters escaped. *) + +val get_published_info_message : + Datamodel_types.message -> Datamodel_types.obj -> string +(** Gets information about the publication status of a message. + @param message - Message to check. + @param cls - Class containing the message. + @return Information about the publication status. *) + +val is_remover : Datamodel_types.message -> bool +(** [is_remover message] Checks if a message is a remover based on its name. + @param message Message to check. + @return [true] if the message is a remover, [false] otherwise. *) + +val get_minimum_allowed_role : Datamodel_types.message -> string +(** [msg message] Get the minimum RBAC role required to run the procedure of the input message. + This function ignores internal roles. + If no matching role is found, the string "Not Applicable" is returned + @param message Input message. + @return string the name of the RBAC role if a matching one is found, "Not Applicable" otherwise. *) + +val gen_param_groups : + Datamodel_types.message + -> Datamodel_types.param list + -> Datamodel_types.param list list +(** Generates parameter groups based on a message and its parameters. + @param message - Message containing the parameters. + @param params - List of parameters. + @return List of parameter groups. *) + +val get_published_info_param : + Datamodel_types.message -> Datamodel_types.param -> string +(** Gets information about the publication status of a parameter. + @param message - Message containing the parameter. + @param param - Parameter to check. + @return Information about the publication status. *) + +val get_published_info_field : + Datamodel_types.field -> Datamodel_types.obj -> string +(** Gets information about the publication status of a field within a class. + @param field - Field to check. + @param cls - Class containing the field. + @return Information about the publication status. *) + +val string_of_file : string -> string +(** [string_of_file filename] Reads the content of a file into a string. + @param filename Name of the file to read. + @return String containing the file content. *) + +val is_constructor : Datamodel_types.message -> bool +(** [is_constructor message] Checks if a message is a constructor. + @param message Message to check. + @return [true] if the message is a constructor, [false] otherwise. *) + +val with_output : string -> (out_channel -> 'a) -> 'a +(** [with_output filename f] Opens a file for writing and executes a function with the output channel. + @param filename Name of the file to open. + @param f Function to execute with the output channel. *) + +val is_destructor : Datamodel_types.message -> bool +(** [is_destructor message] Checks if a message is a destructor. + @param message Message to check. + @return [true] if the message is a destructor, [false] otherwise. *) + +val is_real_constructor : Datamodel_types.message -> bool +(** [is_real_constructor message] Checks if a message is a real constructor. + @param message Message to check. + @return [true] if the message is a real constructor, [false] otherwise. *) + +val render_file : string * string -> Mustache.Json.t -> string -> string -> unit +(** [render_file (infile, outfile) json templates_dir dest_dir] Renders a file using a JSON data model and templates. + @param infile Input file name. + @param outfile Output file name. + @param json JSON data model. + @param templates_dir Directory containing templates. + @param dest_dir Directory for the rendered output. *) + +val json_releases : Mustache.Json.t +(** JSON structure representing release information. *) diff --git a/ocaml/sdk-gen/common/dune b/ocaml/sdk-gen/common/dune index 2278becc3e0..7cda0194598 100644 --- a/ocaml/sdk-gen/common/dune +++ b/ocaml/sdk-gen/common/dune @@ -6,5 +6,6 @@ xapi-datamodel mustache ) + (modules_without_implementation license) ) diff --git a/ocaml/sdk-gen/common/license.mli b/ocaml/sdk-gen/common/license.mli new file mode 100644 index 00000000000..092b79357a6 --- /dev/null +++ b/ocaml/sdk-gen/common/license.mli @@ -0,0 +1,2 @@ +(* Content of BSD 2 License *) +val bsd_two_clause : string diff --git a/ocaml/sdk-gen/csharp/autogen/src/Session.cs b/ocaml/sdk-gen/csharp/autogen/src/Session.cs index a2aef1d672e..4a84b5bcd0c 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/Session.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/Session.cs @@ -333,6 +333,11 @@ public Dictionary RequestHeaders #endregion + public string[] GetSystemMethods() + { + return JsonRpcClient.system_list_methods(); + } + public static Session get_record(Session session, string _session) { Session newSession = new Session(session.Url) { opaque_ref = _session }; diff --git a/ocaml/sdk-gen/csharp/templates/XenServer.csproj.mustache b/ocaml/sdk-gen/csharp/autogen/src/XenServer.csproj similarity index 100% rename from ocaml/sdk-gen/csharp/templates/XenServer.csproj.mustache rename to ocaml/sdk-gen/csharp/autogen/src/XenServer.csproj diff --git a/ocaml/sdk-gen/csharp/friendly_error_names.mli b/ocaml/sdk-gen/csharp/friendly_error_names.mli new file mode 100644 index 00000000000..c8b99626f9c --- /dev/null +++ b/ocaml/sdk-gen/csharp/friendly_error_names.mli @@ -0,0 +1 @@ +(* Empty .mli to ensure unused functions are picked up during check*) diff --git a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml index 2d7f254fad9..21483260f5b 100644 --- a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml +++ b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml @@ -89,18 +89,6 @@ let rec main () = ("HTTP_actions.mustache", "HTTP_actions.cs") (gen_http_actions ()) templdir destdir ; gen_relations () ; - let sorted_members = List.sort String.compare !api_members in - let json = - `O - [ - ( "api_members" - , `A (List.map (fun x -> `O [("api_member", `String x)]) sorted_members) - ) - ] - in - render_file - ("XenServer.csproj.mustache", "XenServer.csproj") - json templdir destdir ; render_file ("ApiVersion.mustache", "ApiVersion.cs") json_releases templdir destdir @@ -109,37 +97,42 @@ let rec main () = and relations = Hashtbl.create 10 and gen_relations () = - let out_chan = open_out (Filename.concat destdir "Relation.cs") in - let print format = fprintf out_chan format in List.iter process_relations (relations_of_api api) ; - print - "%s\n\n\ - using System;\n\ - using System.Collections.Generic;\n\n\ - namespace XenAPI\n\ - {\n\ - \ public partial class Relation\n\ - \ {\n\ - \ public readonly String field;\n\ - \ public readonly String manyType;\n\ - \ public readonly String manyField;\n\n\ - \ public Relation(String field, String manyType, String manyField)\n\ - \ {\n\ - \ this.field = field;\n\ - \ this.manyField = manyField;\n\ - \ this.manyType = manyType;\n\ - \ }\n\n\ - \ public static Dictionary GetRelations()\n\ - \ {\n\ - \ Dictionary relations = new Dictionary();\n\n" - Licence.bsd_two_clause ; - Hashtbl.iter (gen_relations_by_type out_chan) relations ; - print "\n return relations;\n }\n }\n}\n" - -and string_ends str en = - let len = String.length en in - String.sub str (String.length str - len) len = en + let typelist = + List.rev (Hashtbl.fold (fun k v acc -> (k, v) :: acc) relations []) + in + let json = + `O + [ + ( "types" + , `A + (List.map + (fun (k, v) -> + `O + [ + ("type", `String (exposed_class_name k)) + ; ( "relations" + , `A + (List.map + (fun (x, y, z) -> + `O + [ + ("field", `String x) + ; ("manyType", `String y) + ; ("manyField", `String z) + ] + ) + v + ) + ) + ] + ) + typelist + ) + ) + ] + in + render_file ("Relation.mustache", "Relation.cs") json templdir destdir and process_relations ((oneClass, oneField), (manyClass, manyField)) = let value = @@ -148,20 +141,6 @@ and process_relations ((oneClass, oneField), (manyClass, manyField)) = in Hashtbl.replace relations manyClass value -and gen_relations_by_type out_chan manyClass relations = - let print format = fprintf out_chan format in - print " relations.Add(typeof(%s), new Relation[] {\n" - (exposed_class_name manyClass) ; - - List.iter (gen_relation out_chan) relations ; - - print " });\n\n" - -and gen_relation out_chan (manyField, oneClass, oneField) = - let print format = fprintf out_chan format in - print " new Relation(\"%s\", \"%s\", \"%s\"),\n" manyField - oneClass oneField - (* ------------------- category: http_actions *) and gen_http_actions () = (* Each action has: @@ -244,9 +223,9 @@ and gen_class_file cls = let out_chan = open_out (Filename.concat destdir (exposed_class_name cls.name) ^ ".cs") in - finally + Fun.protect (fun () -> gen_class out_chan cls) - ~always:(fun () -> close_out out_chan) + ~finally:(fun () -> close_out out_chan) and gen_class out_chan cls = let print format = fprintf out_chan format in @@ -451,16 +430,6 @@ and get_constructor_body' content elements = | Namespace (_, c) :: others -> get_constructor_body' (c @ others) elements -and gen_constructor_line out_chan content = - let print format = fprintf out_chan format in - - match content with - | Field fr -> - print " %s = %s;\n" (full_name fr) - (convert_from_proxy ("proxy." ^ full_name fr) fr.ty) - | Namespace (_, c) -> - List.iter (gen_constructor_line out_chan) c - and gen_hashtable_constructor_line out_chan content = let print format = fprintf out_chan format in @@ -560,9 +529,6 @@ and gen_exposed_method cls msg curParams = in sync ^ async -and returns_xenobject msg = - match msg.msg_result with Some (Record _, _) -> true | _ -> false - and get_params_doc msg classname params = let sessionDoc = "\n /// The session" @@ -688,18 +654,6 @@ and gen_save_changes_to_field out_chan exposed_class_name fr = \ }\n" equality exposed_class_name full_name_fr full_name_fr -and ctor_call classname = - let fields = - Datamodel_utils.fields_of_obj (Dm_api.get_obj_by_name api ~objname:classname) - in - let fields2 = - List.filter - (function {DT.qualifier= DT.StaticRO | DT.RW; _} -> true | _ -> false) - fields - in - let args = List.map (fun fr -> "p." ^ full_name fr) fields2 in - String.concat ", " ("session.opaque_ref" :: args) - and gen_exposed_field out_chan cls content = match content with | Field fr -> @@ -868,79 +822,46 @@ and gen_enum' name contents = ("enum", `String name); ("enum_members", `A (List.map enum_member members)) ] -and has_unknown_entry contents = - let rec f = function - | x :: xs -> - if String.lowercase_ascii (fst x) = "unknown" then true else f xs - | [] -> - false - in - f contents - (* ------------------- category: maps *) and gen_maps () = - let out_chan = open_out (Filename.concat destdir "Maps.cs") in - finally (fun () -> gen_maps' out_chan) ~always:(fun () -> close_out out_chan) - -and gen_maps' out_chan = - let print format = fprintf out_chan format in - - print - "%s\n\n\ - using System;\n\ - using System.Collections;\n\ - using System.Collections.Generic;\n\n\ - \ namespace XenAPI\n\ - {\n\ - \ internal class Maps\n\ - \ {" Licence.bsd_two_clause ; - - TypeSet.iter (gen_map_conversion out_chan) !maps ; - - print "\n }\n}\n" - -and gen_map_conversion out_chan = function - | Map (l, r) -> - let print format = fprintf out_chan format in - let el = exposed_type l in - let el_literal = exposed_type_as_literal l in - let er = exposed_type r in - let er_literal = exposed_type_as_literal r in - - print - "\n\ - \ internal static Dictionary<%s, %s> \ - ToDictionary_%s_%s(Hashtable table)\n\ - \ {\n\ - \ Dictionary<%s, %s> result = new Dictionary<%s, %s>();\n\ - \ if (table != null)\n\ - \ {\n\ - \ foreach (string key in table.Keys)\n\ - \ {\n\ - \ try\n\ - \ {\n\ - \ %s k = %s;\n\ - \ %s v = %s;\n\ - \ result[k] = v;\n\ - \ }\n\ - \ catch\n\ - \ {\n\ - \ // continue\n\ - \ }\n\ - \ }\n\ - \ }\n\ - \ return result;\n\ - \ }\n\n" - el er - (sanitise_function_name el_literal) - (sanitise_function_name er_literal) - el er el er el - (simple_convert_from_proxy "key" l) - er - (convert_from_proxy_hashtable_value "table[key]" r) - (***) - | _ -> - assert false + let mapList = List.rev (TypeSet.fold (fun x acc -> x :: acc) !maps []) in + let json = + `O + [ + ( "all_maps" + , `A + (List.map + (function + | Map (l, r) -> + `O + [ + ("map_key", `String (exposed_type l)) + ; ("map_value", `String (exposed_type r)) + ; ( "sanitised_key" + , `String + (sanitise_function_name (exposed_type_as_literal l)) + ) + ; ( "sanitised_value" + , `String + (sanitise_function_name (exposed_type_as_literal r)) + ) + ; ( "proxy_key" + , `String (simple_convert_from_proxy "key" l) + ) + ; ( "proxy_value" + , `String + (convert_from_proxy_hashtable_value "table[key]" r) + ) + ] + | _ -> + `Null + ) + mapList + ) + ) + ] + in + render_file ("Maps.mustache", "Maps.cs") json templdir destdir (* ------------------- category: utility *) and exposed_type_opt = function @@ -1027,7 +948,6 @@ and convert_from_proxy_hashtable_value thing ty = convert_from_proxy thing ty and convert_from_proxy thing ty = - (*function*) match ty with | DateTime -> thing @@ -1320,8 +1240,6 @@ and get_default_value_opt field = List.map (fun x -> String.concat ", " (get_default_value x)) y | VRef y -> if y = "" then ["Helper.NullOpaqueRef"] else [sprintf "\"%s\"" y] - | VCustom (_, y) -> - get_default_value y in match field.default_value with | Some y -> diff --git a/ocaml/sdk-gen/csharp/gen_csharp_binding.mli b/ocaml/sdk-gen/csharp/gen_csharp_binding.mli new file mode 100644 index 00000000000..c8b99626f9c --- /dev/null +++ b/ocaml/sdk-gen/csharp/gen_csharp_binding.mli @@ -0,0 +1 @@ +(* Empty .mli to ensure unused functions are picked up during check*) diff --git a/ocaml/sdk-gen/csharp/templates/JsonRpcClient.mustache b/ocaml/sdk-gen/csharp/templates/JsonRpcClient.mustache index ac3d0ca625c..307e02560f4 100644 --- a/ocaml/sdk-gen/csharp/templates/JsonRpcClient.mustache +++ b/ocaml/sdk-gen/csharp/templates/JsonRpcClient.mustache @@ -38,6 +38,13 @@ namespace XenAPI { public partial class JsonRpcClient { + public string[] system_list_methods() + { + var converters = new List { }; + var serializer = CreateSerializer(converters); + return Rpc("system.listMethods", new JArray(), serializer); + } + public Event event_get_record(string session, string _event) { var converters = new List {}; diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/Marshalling.java b/ocaml/sdk-gen/csharp/templates/Maps.mustache similarity index 52% rename from ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/Marshalling.java rename to ocaml/sdk-gen/csharp/templates/Maps.mustache index cc7177a92ea..b8942e88731 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/Marshalling.java +++ b/ocaml/sdk-gen/csharp/templates/Maps.mustache @@ -1,76 +1,64 @@ -/* - * Copyright (c) Cloud Software Group, Inc. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * - * 1) Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2) Redistributions in binary form must reproduce the above - * copyright notice, this list of conditions and the following - * disclaimer in the documentation and/or other materials - * provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, - * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED - * OF THE POSSIBILITY OF SUCH DAMAGE. - */ - -package com.xensource.xenapi; - -import java.util.*; - -/** - * Marshalls Java types onto the wire. - * Does not cope with records. Use individual record.toMap() - */ -public final class Marshalling { - /** - * Converts Integers to Strings - * and Sets to Lists recursively. - */ - public static Object toXMLRPC(Object o) { - if (o instanceof String || - o instanceof Boolean || - o instanceof Double || - o instanceof Date) { - return o; - } else if (o instanceof Long) { - return o.toString(); - } else if (o instanceof Map) { - Map result = new HashMap(); - Map m = (Map)o; - for (Object k : m.keySet()) - { - result.put(toXMLRPC(k), toXMLRPC(m.get(k))); - } - return result; - } else if (o instanceof Set) { - List result = new ArrayList(); - for (Object e : ((Set)o)) - { - result.add(toXMLRPC(e)); - } - return result; - } else if (o instanceof XenAPIObject) { - return ((XenAPIObject) o).toWireString(); - } else if (o instanceof Enum) { - return o.toString(); - }else if (o == null){ - return ""; - } else { - throw new RuntimeException ("=============don't know how to marshall:({[" + o + "]})"); - } - } -} +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +using System; +using System.Collections; +using System.Collections.Generic; + +namespace XenAPI +{ + internal class Maps + { +{{#all_maps}} + internal static Dictionary<{{{map_key}}}, {{{map_value}}}> ToDictionary_{{{sanitised_key}}}_{{{sanitised_value}}}(Hashtable table) + { + var result = new Dictionary<{{{map_key}}}, {{{map_value}}}>(); + if (table != null) + { + foreach (string key in table.Keys) + { + try + { + {{{map_key}}} k = {{{proxy_key}}}; + {{{map_value}}} v = {{{proxy_value}}}; + result[k] = v; + } + catch + { + // continue + } + } + } + return result; + } + +{{/all_maps}} + } +} diff --git a/ocaml/sdk-gen/csharp/templates/Relation.mustache b/ocaml/sdk-gen/csharp/templates/Relation.mustache new file mode 100644 index 00000000000..69f3cd8c834 --- /dev/null +++ b/ocaml/sdk-gen/csharp/templates/Relation.mustache @@ -0,0 +1,64 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +using System; +using System.Collections.Generic; + +namespace XenAPI +{ + public partial class Relation + { + public readonly String field; + public readonly String manyType; + public readonly String manyField; + + public Relation(String field, String manyType, String manyField) + { + this.field = field; + this.manyField = manyField; + this.manyType = manyType; + } + + public static Dictionary GetRelations() + { + Dictionary relations = new Dictionary(); +{{#types}} + + relations.Add(typeof({{type}}), new Relation[] { + {{#relations}} + new Relation("{{field}}", "{{manyType}}", "{{manyField}}"), + {{/relations}} + }); +{{/types}} + + return relations; + } + } +} diff --git a/ocaml/sdk-gen/java/autogen/xen-api/pom.xml b/ocaml/sdk-gen/java/autogen/xen-api/pom.xml index 471568f1179..66e1b633db2 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/pom.xml +++ b/ocaml/sdk-gen/java/autogen/xen-api/pom.xml @@ -1,6 +1,6 @@ + xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" + xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd"> 4.0.0 com.xenserver xen-api @@ -8,16 +8,16 @@ jar XenServer Java SDK Mavenized build of the XenServer SDK for Java. - https://www.citrix.com/community/citrix-developer/citrix-hypervisor-developer + https://docs.xenserver.com/en-us/xenserver/8/developer Cloud Software Group, Inc. https://www.cloud.com - BSD 2-Clause License - http://opensource.org/licenses/BSD-2-Clause - repo + BSD 2-Clause License + http://opensource.org/licenses/BSD-2-Clause + repo @@ -53,29 +53,14 @@ - org.apache.xmlrpc - xmlrpc-client - 3.1.3 + com.fasterxml.jackson.core + jackson-databind + 2.16.1 - org.apache.xmlrpc - xmlrpc-common - 3.1.3 - - - org.apache.ws.commons.util - ws-commons-util - 1.0.2 - - - junit - junit - - - xml-apis - xml-apis - - + org.apache.httpcomponents.client5 + httpclient5 + 5.3 @@ -96,7 +81,7 @@ org.apache.maven.plugins maven-compiler-plugin - 3.11.0 + 3.12.1 11 @@ -111,7 +96,7 @@ org.apache.maven.plugins maven-source-plugin - 3.2.1 + 3.3.0 attach-sources @@ -124,7 +109,7 @@ org.apache.maven.plugins maven-javadoc-plugin - 3.2.0 + 3.6.3 attach-javadocs diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/Connection.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/Connection.java index ef5b137b315..bc8b5c644e4 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/Connection.java +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/Connection.java @@ -29,228 +29,261 @@ package com.xensource.xenapi; -import java.net.URL; -import java.util.Map; -import java.util.TimeZone; - -import org.apache.xmlrpc.XmlRpcException; -import org.apache.xmlrpc.client.XmlRpcClient; -import org.apache.xmlrpc.client.XmlRpcClientConfigImpl; -import org.apache.xmlrpc.client.XmlRpcHttpClientConfig; - +import com.fasterxml.jackson.core.type.TypeReference; import com.xensource.xenapi.Types.BadServerResponse; import com.xensource.xenapi.Types.XenAPIException; +import org.apache.hc.client5.http.impl.classic.CloseableHttpClient; +import org.apache.hc.core5.util.Timeout; + +import java.io.IOException; +import java.net.URL; +import java.util.concurrent.TimeUnit; /** - * Represents a connection to a XenServer. Creating a new instance of this class initialises a new XmlRpcClient that is - * then used by all method calls: each method call in xenapi takes a Connection as a parameter, composes an XMLRPC + * Represents a connection to a XenServer. Creating a new instance of this class initialises a new JsonRpcClient that is + * then used by all method calls: each method call in xen-api takes a Connection as a parameter, composes a JSON-RPC * method call, and dispatches it on the Connection's client via the dispatch method. */ -public class Connection -{ - private APIVersion apiVersion; - - /** - * Default reply timeout for xml-rpc calls in seconds - */ - protected static final int DEFAULT_REPLY_TIMEOUT = 600; +public class Connection { + public final JsonRpcClient client; + private APIVersion apiVersion; /** - * Default connection timeout for xml-rpc calls in seconds + * The opaque reference to the session used by this connection */ - protected static final int DEFAULT_CONNECTION_TIMEOUT = 5; + private String sessionReference; /** - * Updated when Session.login_with_password() is called. + * Creates a connection to a particular server using a custom implementation of the JsonRpcClient. + *

+ * Note this constructor does NOT call Session.loginWithPassword; the programmer is responsible for calling it, + * passing the Connection as a parameter. No attempt to connect to the server is made until login is called. + *

+ * When this constructor is used, a call to dispose() will do nothing. The programmer is responsible for manually + * logging out the Session. + * + * @param jsonRpcClient The JsonRpcClient used to connect to the JSON-RPC backed. */ - public APIVersion getAPIVersion() - { - return apiVersion; + public Connection(JsonRpcClient jsonRpcClient) { + this.client = jsonRpcClient; } /** - * The opaque reference to the session used by this connection - */ - private String sessionReference; - - /** - * As seen by the xmlrpc library. From our point of view it's a server. + * Creates a connection to a particular server using a given url. This object can then be passed + * in to any other API calls. + *

+ * Note this constructor does NOT call Session.loginWithPassword; the programmer is responsible for calling it, + * passing the Connection as a parameter. No attempt to connect to the server is made until login is called. + *

+ * When this constructor is used, a call to dispose() will do nothing. The programmer is responsible for manually + * logging out the Session. + * + * @param httpClient The HttpClient used to make calls, this will be used by the underlying {@link #client} for handling requests + * @param url The URL of the server to connect to. Should be of the form http(s)://host-url/jsonrpc or http(s)://host-url. + * @param requestTimeout The reply timeout for JSON-RPC calls in seconds + * @deprecated This constructor is deprecated. To set the {@code requestTimeout} please {@link #setRequestTimeout(int)}. You may also use the {@link com.xensource.xenapi.JsonRpcClient#setRequestTimeout(int)} + * method of this object's {@link #client}. This option is only advisable if you are managing your own {@link com.xensource.xenapi.JsonRpcClient} as the underlying + * {@link #client} for this object. */ - private final XmlRpcClient client; + @Deprecated + public Connection(CloseableHttpClient httpClient, URL url, int requestTimeout) { + this.client = new JsonRpcClient(httpClient, url); + this.client.setRequestTimeout(requestTimeout); + } /** * Creates a connection to a particular server using a given url. This object can then be passed * in to any other API calls. - * + *

* Note this constructor does NOT call Session.loginWithPassword; the programmer is responsible for calling it, * passing the Connection as a parameter. No attempt to connect to the server is made until login is called. - * + *

* When this constructor is used, a call to dispose() will do nothing. The programmer is responsible for manually * logging out the Session. - * - * This constructor uses the default values of the reply and connection timeouts for the xmlrpc calls + *

+ * This constructor uses the default values of the reply and connection timeouts for the JSON-RPC calls * (600 seconds and 5 seconds respectively). * - * @param url The URL of the server to connect to + * @param url The URL of the server to connect to. Should be of the form http(s)://host-url/jsonrpc or http(s)://host-url. */ - public Connection(URL url) - { - this.client = getClientFromURL(url, DEFAULT_REPLY_TIMEOUT, DEFAULT_CONNECTION_TIMEOUT); + public Connection(URL url) { + this.client = new JsonRpcClient(url); } /** * Creates a connection to a particular server using a given url. This object can then be passed * in to any other API calls. - * + *

* Note this constructor does NOT call Session.loginWithPassword; the programmer is responsible for calling it, * passing the Connection as a parameter. No attempt to connect to the server is made until login is called. - * + *

* When this constructor is used, a call to dispose() will do nothing. The programmer is responsible for manually * logging out the Session. * - * @param url The URL of the server to connect to - * @param replyTimeout The reply timeout for xml-rpc calls in seconds - * @param connTimeout The connection timeout for xml-rpc calls in seconds + * @param url The URL of the server to connect to. Should be of the form http(s)://host-url/jsonrpc or http(s)://host-url. + * @param requestTimeout The reply timeout for JSON-RPC calls in seconds + * @param connectionTimeout The connection timeout for JSON-RPC calls in seconds + * @deprecated This constructor is deprecated. To set {@code requestTimeout} or {@code connectionTimeout} please use {@link #setRequestTimeout(int)} or {@link #setConnectionTimeout(int)} respectively. + * You may also use the {@link com.xensource.xenapi.JsonRpcClient#setRequestTimeout(int)} method of this object's {@link #client}. + * This option is only advisable if you are managing your own {@link com.xensource.xenapi.JsonRpcClient} as the underlying + * {@link #client} for this object. */ - public Connection(URL url, int replyTimeout, int connTimeout) - { - this.client = getClientFromURL(url, replyTimeout, connTimeout); + @Deprecated + public Connection(URL url, int requestTimeout, int connectionTimeout) { + this.client = new JsonRpcClient(url); + this.client.setRequestTimeout(requestTimeout); + this.client.setConnectionTimeout(connectionTimeout); } - /** * Creates a connection to a particular server using a given url. This object can then be passed * in to any other API calls. - * - * This constructor uses the default values of the reply and connection timeouts for the xmlrpc calls + *

+ * Note this constructor does NOT call Session.loginWithPassword; the programmer is responsible for calling it, + * passing the Connection as a parameter. No attempt to connect to the server is made until login is called. + *

+ * When this constructor is used, a call to dispose() will do nothing. The programmer is responsible for manually + * logging out the Session. + *

+ * This constructor uses the default values of the reply and connection timeouts for the JSON-RPC calls * (600 seconds and 5 seconds respectively). * - * @param url The URL of the server to connect to + * @param url The URL of the server to connect to. Should be of the form http(s)://host-url/jsonrpc or http(s)://host-url. * @param sessionReference A reference to a logged-in Session. Any method calls on this - * Connection will use it. This constructor does not call Session.loginWithPassword, and dispose() on the resulting - * Connection object does not call Session.logout. The programmer is responsible for ensuring the Session is logged - * in and out correctly. + * Connection will use it. This constructor does not call Session.loginWithPassword, and dispose() on the resulting + * Connection object does not call Session.logout. The programmer is responsible for ensuring the Session is logged + * in and out correctly. */ - public Connection(URL url, String sessionReference) - { - this.client = getClientFromURL(url, DEFAULT_REPLY_TIMEOUT, DEFAULT_CONNECTION_TIMEOUT); + public Connection(URL url, String sessionReference) { + this.client = new JsonRpcClient(url); this.sessionReference = sessionReference; } /** * Creates a connection to a particular server using a given url. This object can then be passed * in to any other API calls. + *

+ * Note this constructor does NOT call Session.loginWithPassword; the programmer is responsible for calling it, + * passing the Connection as a parameter. No attempt to connect to the server is made until login is called. + *

+ * When this constructor is used, a call to dispose() will do nothing. The programmer is responsible for manually + * logging out the Session. * - * @param url The URL of the server to connect to - * @param sessionReference A reference to a logged-in Session. Any method calls on this Connection will use it. - * This constructor does not call Session.loginWithPassword, and dispose() on the resulting - * Connection object does not call Session.logout. The programmer is responsible for - * ensuring the Session is logged in and out correctly. - * @param replyTimeout The reply timeout for xml-rpc calls in seconds - * @param connTimeout The connection timeout for xml-rpc calls in seconds + * @param url The URL of the server to connect to. Should be of the form http(s)://host-url/jsonrpc or http(s)://host-url. + * @param sessionReference A reference to a logged-in Session. Any method calls on this Connection will use it. + * This constructor does not call Session.loginWithPassword, and dispose() on the resulting + * Connection object does not call Session.logout. The programmer is responsible for + * ensuring the Session is logged in and out correctly. + * @param requestTimeout The reply timeout for JSON-RPC calls in seconds + * @param connectionTimeout The connection timeout for JSON-RPC calls in seconds + * @deprecated This constructor is deprecated. To set {@code requestTimeout} or {@code connectionTimeout} please use {@link #setRequestTimeout(int)} or {@link #setConnectionTimeout(int)} respectively. + * You may also use the {@link com.xensource.xenapi.JsonRpcClient#setRequestTimeout(int)} method of this object's {@link #client}. + * This option is only advisable if you are managing your own {@link com.xensource.xenapi.JsonRpcClient} as the underlying + * {@link #client} for this object. */ - public Connection(URL url, String sessionReference, int replyTimeout, int connTimeout) - { - this.client = getClientFromURL(url, replyTimeout, connTimeout); + @Deprecated + public Connection(URL url, String sessionReference, int requestTimeout, int connectionTimeout) { + this.client = new JsonRpcClient(url); + this.client.setRequestTimeout(requestTimeout); + this.client.setConnectionTimeout(connectionTimeout); this.sessionReference = sessionReference; } - private XmlRpcClientConfigImpl config = new XmlRpcClientConfigImpl(); + /** + * Set the timeout in seconds for every request made by this object's {@link #client}. + * If not set the value defaults to {@value JsonRpcClient#DEFAULT_REQUEST_TIMEOUT}. + * You may also pass your own {@link JsonRpcClient} in the constructor for more control. + * + * @param requestTimeout the timeout value in seconds + * @throws NullPointerException if the {@link #client} is null + * @see org.apache.hc.client5.http.config.RequestConfig.Builder#setConnectionRequestTimeout(long, TimeUnit) + */ + public void setRequestTimeout(int requestTimeout) throws NullPointerException { + this.client.setRequestTimeout(requestTimeout); + } - public XmlRpcClientConfigImpl getConfig() - { - return config; + /** + * Set the connection timeout in seconds for its {@link #client}'s {@link org.apache.hc.client5.http.impl.io.PoolingHttpClientConnectionManager}. + * If not set the value defaults to {@value JsonRpcClient#DEFAULT_CONNECTION_TIMEOUT}. + * You may also pass your own {@link JsonRpcClient} in the constructor for more control. + * + * @param connectionTimeout the client's connection timeout in seconds. + * @throws NullPointerException if the {@link #client} is null + * @see org.apache.hc.client5.http.config.ConnectionConfig.Builder#setConnectTimeout(Timeout) + */ + public void setConnectionTimeout(int connectionTimeout) { + this.client.setConnectionTimeout(connectionTimeout); + } + + /** + * Updated when Session.login_with_password() is called. + */ + public APIVersion getAPIVersion() { + return apiVersion; } - private XmlRpcClient getClientFromURL(URL url, int replyWait, int connWait) - { - config.setTimeZone(TimeZone.getTimeZone("UTC")); - config.setServerURL(url); - config.setReplyTimeout(replyWait * 1000); - config.setConnectionTimeout(connWait * 1000); - XmlRpcClient client = new XmlRpcClient(); - client.setConfig(config); - return client; + private void setAPIVersion() throws IOException { + apiVersion = APIVersion.UNKNOWN; + try { + var pools = Pool.getAllRecords(this); + var pool = pools.values().stream().findFirst(); + if (pool.isPresent()) { + var host = pool.get().master.getRecord(this); + apiVersion = APIVersion.fromMajorMinor(host.APIVersionMajor, host.APIVersionMinor); + } + } catch (BadServerResponse exn) { + // ignore, we default to UNKNOWN + } } /* * Because the binding calls are constructing their own parameter lists, they need to be able to get to * the session reference directly. This is all rather ugly and needs redone - * Changed to public to allow easier integration with HTTP-level streaming interface, - * see CA-15447 + * CA-15447: Changed to public in order to allow easier integration with HTTP-level streaming interface, */ - public String getSessionReference() - { + public String getSessionReference() { return this.sessionReference; } /** - * The (auto-generated parts of) the bindings dispatch XMLRPC calls on this Connection's client through this method. + * Send a method call to xapi's backend. You need to provide the type of the data returned by a successful response. + * + * @param methodCall The JSON-RPC xapi method call. e.g.: session.login_with_password + * @param methodParameters The methodParameters of the method call + * @param responseTypeReference The type of the response, wrapped with a TypeReference + * @param The type of the response's payload. For instance, a map of opaque references to VM objects is expected when calling VM.get_all_records + * @return The result of the call with the type specified under T. + * @throws XenAPIException if the call failed. + * @throws IOException if an I/O error occurs when sending or receiving, includes cases when the request's payload or the response's payload cannot be written or read as valid JSON. */ - protected Map dispatch(String method_call, Object[] method_params) throws XmlRpcException, XenAPIException - { - Map response = (Map) client.execute(method_call, method_params); - - if (method_call.equals("session.login_with_password") && - response.get("Status").equals("Success")) - { - Session session = Types.toSession(response.get("Value")); + public T dispatch(String methodCall, Object[] methodParameters, TypeReference responseTypeReference) throws XenAPIException, IOException { + var result = client.sendRequest(methodCall, methodParameters, responseTypeReference); + if (result.error != null) { + Types.checkError(result.error); + } else if (methodCall.equals("session.login_with_password")) { + var session = ((Session) result.result); + sessionReference = session.ref; + setAPIVersion(); + } else if (methodCall.equals("session.slave_local_login_with_password")) { + var session = ((Session) result.result); sessionReference = session.ref; - setAPIVersion(session); - } - else if (method_call.equals("session.slave_local_login_with_password") && - response.get("Status").equals("Success")) - { - sessionReference = Types.toSession(response.get("Value")).ref; apiVersion = APIVersion.latest(); } - else if (method_call.equals("session.logout")) - { - // Work around a bug in XenServer 5.0 and below. - // session.login_with_password should have rejected us with - // HOST_IS_SLAVE, but instead we don't find out until later. - // We don't want to leak the session, so we need to log out - // this session from the master instead. - if (response.get("Status").equals("Failure")) - { - Object[] error = (Object[]) response.get("ErrorDescription"); - if (error.length == 2 && error[0].equals("HOST_IS_SLAVE")) - { - try - { - XmlRpcHttpClientConfig clientConfig = (XmlRpcHttpClientConfig)client.getClientConfig(); - URL client_url = clientConfig.getServerURL(); - URL masterUrl = new URL(client_url.getProtocol(), (String)error[1], client_url.getPort(), client_url.getFile()); - Connection tmp_conn = new Connection(masterUrl, sessionReference, clientConfig.getReplyTimeout(), clientConfig.getConnectionTimeout()); - - Session.logout(tmp_conn); - } - catch (Exception ex) - { - // Ignore - } - } - } - - this.sessionReference = null; - } - - return Types.checkResponse(response); + return result.result; } - - private void setAPIVersion(Session session) throws XenAPIException, XmlRpcException - { - try - { - long major = session.getThisHost(this).getAPIVersionMajor(this); - long minor = session.getThisHost(this).getAPIVersionMinor(this); - apiVersion = APIVersion.fromMajorMinor(major, minor); - } - catch (BadServerResponse exn) - { - apiVersion = APIVersion.UNKNOWN; - } + /** + * Send a method call to xapi's backend. To be used with methods without a return type + * + * @param methodCall the JSON-RPC xapi method call. e.g.: session.login_with_password + * @param methodParameters the methodParameters of the method call + * @throws XenAPIException if the call failed. + * @throws IOException if an I/O error occurs when sending or receiving, includes cases when the request's payload or the response's payload cannot be written or read as valid JSON. + */ + public void dispatch(String methodCall, Object[] methodParameters) throws XenAPIException, IOException { + var typeReference = new TypeReference() { + }; + this.dispatch(methodCall, methodParameters, typeReference); } } diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/CustomDateDeserializer.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/CustomDateDeserializer.java new file mode 100644 index 00000000000..a0e9bff1a3d --- /dev/null +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/CustomDateDeserializer.java @@ -0,0 +1,94 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package com.xensource.xenapi; + +import com.fasterxml.jackson.core.JsonParser; +import com.fasterxml.jackson.databind.DeserializationContext; +import com.fasterxml.jackson.databind.deser.std.StdDeserializer; + +import java.io.IOException; +import java.text.ParseException; +import java.text.SimpleDateFormat; +import java.util.Date; + +/** + * {@link CustomDateDeserializer} is a Jackson JSON deserializer for parsing {@link Date} objects + * from custom date formats used in Xen-API responses. + */ +public class CustomDateDeserializer extends StdDeserializer { + + /** + * Array of {@link SimpleDateFormat} objects representing the custom date formats + * used in XenServer API responses. + */ + private final SimpleDateFormat[] dateFormatters + = new SimpleDateFormat[]{ + new SimpleDateFormat("yyyyMMdd'T'HH:mm:ss'Z'"), + new SimpleDateFormat("ss.SSS") + }; + + /** + * Constructs a {@link CustomDateDeserializer} instance. + */ + public CustomDateDeserializer() { + this(null); + } + + /** + * Constructs a {@link CustomDateDeserializer} instance with the specified value type. + * + * @param t The value type to handle (can be null, handled by superclass) + */ + public CustomDateDeserializer(Class t) { + super(t); + } + + /** + * Deserializes a {@link Date} object from the given JSON parser. + * + * @param jsonParser The JSON parser containing the date value to deserialize + * @param deserializationContext The deserialization context + * @return The deserialized {@link Date} object + * @throws IOException if an I/O error occurs during deserialization + */ + @Override + public Date deserialize(JsonParser jsonParser, DeserializationContext deserializationContext) throws IOException { + + for (SimpleDateFormat formatter : dateFormatters) { + try { + return formatter.parse(jsonParser.getText()); + } catch (ParseException e) { + // ignore + } + } + + throw new IOException("Failed to deserialize a Date value."); + } +} diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/EventBatch.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/EventBatch.java index 2734ca18840..e70823f2638 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/EventBatch.java +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/EventBatch.java @@ -30,6 +30,7 @@ package com.xensource.xenapi; import java.util.Set; +import com.fasterxml.jackson.annotation.JsonProperty; /** * Class used to map the output of Event.from(). @@ -46,6 +47,7 @@ public class EventBatch /** * The number of valid objects of all types in the database. */ + @JsonProperty("valid_ref_counts") public Object validRefCounts; /** diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java new file mode 100644 index 00000000000..38ba22db148 --- /dev/null +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java @@ -0,0 +1,233 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package com.xensource.xenapi; + +import com.fasterxml.jackson.core.JsonProcessingException; +import com.fasterxml.jackson.core.type.TypeReference; +import com.fasterxml.jackson.databind.ObjectMapper; +import com.fasterxml.jackson.databind.module.SimpleModule; +import org.apache.hc.client5.http.classic.methods.HttpPost; +import org.apache.hc.client5.http.config.ConnectionConfig; +import org.apache.hc.client5.http.config.RequestConfig; +import org.apache.hc.client5.http.cookie.StandardCookieSpec; +import org.apache.hc.client5.http.impl.classic.CloseableHttpClient; +import org.apache.hc.client5.http.impl.classic.HttpClients; +import org.apache.hc.client5.http.impl.io.PoolingHttpClientConnectionManager; +import org.apache.hc.core5.http.ContentType; +import org.apache.hc.core5.http.io.entity.StringEntity; +import org.apache.hc.core5.util.Timeout; + +import java.io.IOException; +import java.net.URL; +import java.util.Date; +import java.util.concurrent.TimeUnit; + +/** + * Provides a JSON-RPC v2.0 client for making remote procedure calls to xapi's backend URL. + *
+ * This class enables the communication to the JSON-RPC backend. The client utilizes the HttpClient class for + * sending HTTP POST requests with JSON payloads and the ObjectMapper class from the Jackson library for + * serialization and deserialization of JSON data. + *
+ * The client can be customised by passing it as a parameter to corresponding constructor, enabling custom + * handling of requests. + *
+ *
+ * By default, the timeout for requests is set to {@value #DEFAULT_REQUEST_TIMEOUT}. The default timeout for connecting to the + * JSON-RPC backend is set to {@value #DEFAULT_CONNECTION_TIMEOUT} seconds. The maximum number of concurrent connections handled + * by the underlying {@link PoolingHttpClientConnectionManager} is {@value #MAX_CONCURRENT_CONNECTIONS}. + * + * @see CloseableHttpClient CloseableHttpClient is used to make requests and connect to the backend + * @see ObjectMapper ObjectMapper is used to marshall requests and responses + */ +public class JsonRpcClient { + private static final int DEFAULT_REQUEST_TIMEOUT = 600; + private static final int DEFAULT_CONNECTION_TIMEOUT = 5; + + private static final int MAX_CONCURRENT_CONNECTIONS = 10; + + private static final String JSON_BACKEND_PATH = "/jsonrpc"; + + private final CloseableHttpClient httpClient; + private final String jsonRpcBackendUrl; + private final ObjectMapper objectMapper; + private final RequestConfig defaultRequestConfig = RequestConfig.custom() + .setCookieSpec(StandardCookieSpec.IGNORE) + .build(); + private int requestTimeout; + private PoolingHttpClientConnectionManager connectionManager; + + //region Constructors + + /** + * Create a JsonRpcClient with default settings. + * + * @param jsonRpcBackendUrl the URL of the JSON-RPC backend. Usually of the form https://<address>. + * @see JsonRpcClient JsonRpcClient for more info on using this class + */ + public JsonRpcClient(URL jsonRpcBackendUrl) { + var connectionConfig = ConnectionConfig + .custom() + .setConnectTimeout(DEFAULT_CONNECTION_TIMEOUT, TimeUnit.SECONDS) + .build(); + + this.connectionManager = new PoolingHttpClientConnectionManager(); + connectionManager.setDefaultConnectionConfig(connectionConfig); + connectionManager.setMaxTotal(MAX_CONCURRENT_CONNECTIONS); + + this.httpClient = HttpClients + .custom() + .setConnectionManager(connectionManager) + .build(); + this.jsonRpcBackendUrl = formatBackendUrl(jsonRpcBackendUrl); + this.requestTimeout = DEFAULT_REQUEST_TIMEOUT; + this.objectMapper = new ObjectMapper(); + initializeObjectMapperConfiguration(); + } + + /** + * Initialize a JsonRpcClient using a custom CloseableHttpClient instance. + * + * @param client the custom HttpClient to use for all requests + * @param jsonRpcBackendUrl the URL of the JSON-RPC backend. Usually of the form https://<address>. + * @see CloseableHttpClient CloseableHttpClient the client that will be used for dispatching requests + * @see JsonRpcClient JsonRpcClient for more info on using this class + */ + public JsonRpcClient(CloseableHttpClient client, URL jsonRpcBackendUrl) { + httpClient = client; + this.jsonRpcBackendUrl = formatBackendUrl(jsonRpcBackendUrl); + this.objectMapper = new ObjectMapper(); + initializeObjectMapperConfiguration(); + } + + //endregion + + //region Public Setters + + /** + * Set the timeout in seconds for every request made by this client. + * If not set the value defaults to {@value #DEFAULT_REQUEST_TIMEOUT}. + * + * @param requestTimeout the timeout value in seconds + * @see org.apache.hc.client5.http.config.RequestConfig.Builder#setConnectionRequestTimeout(long, TimeUnit) + */ + public void setRequestTimeout(int requestTimeout) { + this.requestTimeout = requestTimeout; + } + + /** + * Set the connection timeout in seconds for this client's {@link org.apache.hc.client5.http.impl.io.PoolingHttpClientConnectionManager}. + * If not set the value defaults to {@value #DEFAULT_CONNECTION_TIMEOUT}. + * + * @param connectionTimeout the client's connection timeout in seconds. + * @see org.apache.hc.client5.http.config.ConnectionConfig.Builder#setConnectTimeout(Timeout) + */ + public void setConnectionTimeout(int connectionTimeout) { + connectionManager.setDefaultConnectionConfig(ConnectionConfig + .custom() + .setConnectTimeout(connectionTimeout, TimeUnit.SECONDS) + .build() + ); + } + + /** + * Set the maximum number of connections that this client's {@link org.apache.hc.client5.http.impl.io.PoolingHttpClientConnectionManager} will keep open. + * If not set the value defaults to {@value #MAX_CONCURRENT_CONNECTIONS}. + * + * @param maxConcurrentConnections the maximum number of connections managed by the connection manager + * @see org.apache.hc.core5.pool.ConnPoolControl#setMaxTotal(int) + */ + public void setMaxConcurrentConnections(int maxConcurrentConnections) { + connectionManager.setMaxTotal(maxConcurrentConnections); + } + //endregion + + /** + * Send a method call to xapi's backend. You need to provide the type of the data returned by a successful response. + * + * @param methodCall the JSON-RPC xapi method call. e.g.: session.login_with_password + * @param methodParameters the parameters of the method call + * @param responseTypeReference the type of the response, wrapped with a TypeReference + * @param The type of the response's payload. For instance, a map of opaque references to VM objects is expected when calling VM.get_all_records + * @return a {@link JsonRpcResponse} object. If its error field is empty, the response was successful. + * @throws JsonProcessingException if the request's payload or the response's payload cannot be written or read as valid JSON + * @throws IOException if an I/O error occurs when sending or receiving + */ + protected JsonRpcResponse sendRequest(String methodCall, Object[] methodParameters, TypeReference responseTypeReference) throws IOException { + var requestBody = objectMapper + .writeValueAsString(new JsonRpcRequest(methodCall, methodParameters)); + + var requestEntity = new StringEntity(requestBody, ContentType.APPLICATION_JSON); + + var requestConfig = RequestConfig.copy(defaultRequestConfig) + .setConnectionRequestTimeout(this.requestTimeout, TimeUnit.SECONDS) + .build(); + + var request = new HttpPost(this.jsonRpcBackendUrl); + request.setConfig(requestConfig); + request.setEntity(requestEntity); + + return httpClient.execute(request, response -> { + try (response) { + var typeFactory = objectMapper.getTypeFactory(); + var responseObjectType = typeFactory.constructType(responseTypeReference.getType()); + var type = typeFactory.constructParametricType(JsonRpcResponse.class, responseObjectType); + + var responseContent = response.getEntity().getContent(); + return objectMapper.readValue(responseContent, type); + } + }); + } + + /** + * Helper method to initialize jackson's ObjectMapper. + */ + private void initializeObjectMapperConfiguration() { + var dateHandlerModule = new SimpleModule("DateHandler"); + dateHandlerModule.addDeserializer(Date.class, new CustomDateDeserializer()); + this.objectMapper.registerModule(dateHandlerModule); + } + + /** + * Format input URL to the form protocol://host/jsonrpc + * + * @param url the input URL to format + * @return a string version of a valid xen-api backend URL + */ + private String formatBackendUrl(URL url) { + // We only replace it when it's empty. + // If the user purposely set the path + // we use the given value even if incorrect + if (url.getPath().isEmpty()) { + return url.getProtocol() + "://" + url.getHost() + JSON_BACKEND_PATH; + } + return url.toString(); + } +} diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcRequest.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcRequest.java new file mode 100644 index 00000000000..fa49528c205 --- /dev/null +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcRequest.java @@ -0,0 +1,66 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package com.xensource.xenapi; + +import com.fasterxml.jackson.annotation.JsonProperty; +import com.fasterxml.jackson.core.JsonProcessingException; +import com.fasterxml.jackson.databind.ObjectMapper; +import com.fasterxml.jackson.databind.SerializationFeature; + +/** + * Represents the payload of a request sent to a + * JSON-RPC v2.0 backend. + */ +public class JsonRpcRequest { + @JsonProperty("jsonrpc") + public String jsonRpc; + public int id; + public String method; + @JsonProperty("params") + public Object[] parameters; + + public JsonRpcRequest(String method, Object[] parameters) { + this.method = method; + this.parameters = parameters; + this.jsonRpc = "2.0"; + this.id = 1; + } + + @Override + public String toString() { + try { + var mapper = new ObjectMapper(); + mapper.enable(SerializationFeature.INDENT_OUTPUT); + return mapper.writeValueAsString(this); + } catch (JsonProcessingException ex) { + return "Error while processing object. Could not serialize as JSON."; + } + } +} diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcResponse.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcResponse.java new file mode 100644 index 00000000000..11e2c152474 --- /dev/null +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcResponse.java @@ -0,0 +1,59 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package com.xensource.xenapi; + +import com.fasterxml.jackson.annotation.JsonProperty; +import com.fasterxml.jackson.core.JsonProcessingException; +import com.fasterxml.jackson.databind.ObjectMapper; +import com.fasterxml.jackson.databind.SerializationFeature; + +/** + * Represents the payload of responses returned from a + * JSON-RPC v2.0 backend. + * @param The type of the response's result + */ +public class JsonRpcResponse { + @JsonProperty("jsonrpc") + public String jsonRpc; + public int id; + public T result; + public JsonRpcResponseError error; + + @Override + public String toString() { + try { + var mapper = new ObjectMapper(); + mapper.enable(SerializationFeature.INDENT_OUTPUT); + return mapper.writeValueAsString(this); + } catch (JsonProcessingException ex) { + return "Error while processing object. Could not serialize as JSON"; + } + } +} diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcResponseError.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcResponseError.java new file mode 100644 index 00000000000..80cbabcb582 --- /dev/null +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcResponseError.java @@ -0,0 +1,54 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +package com.xensource.xenapi; + +import com.fasterxml.jackson.core.JsonProcessingException; +import com.fasterxml.jackson.databind.ObjectMapper; +import com.fasterxml.jackson.databind.SerializationFeature; + +/** + * Represents the structure of an error returned by a + * JSON-RPC v2.0 backend. Does not apply to JSON-RPC v1.0. + */ +public class JsonRpcResponseError { + public int code; + public String message; + public String[] data; + + public String toString() { + try { + var mapper = new ObjectMapper(); + mapper.enable(SerializationFeature.INDENT_OUTPUT); + return mapper.writeValueAsString(this); + } catch (JsonProcessingException ex) { + return "Error while processing object. Could not serialize as JSON."; + } + } +} diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/resources/README.txt b/ocaml/sdk-gen/java/autogen/xen-api/src/main/resources/README.txt index ea1bf8c490e..632b8af5728 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/src/main/resources/README.txt +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/resources/README.txt @@ -39,5 +39,6 @@ https://discussions.citrix.com/forum/101-hypervisor-formerly-xenserver/ Dependencies ------------ -XenServerJava is dependent upon Apache XML-RPC by the Apache Software Foundation, -licensed under the Apache Software License 2.0. +XenServerJava is dependent upon: +- The jackson-databind (https://github.com/FasterXML/jackson-databind) package by the Jackson Project (https://github.com/FasterXML/jackson), licensed under the Apache Software License 2.0. +- The Apache HttpClient (https://hc.apache.org/httpcomponents-client/) package by the Apache Software Foundation (https://www.apache.org/), licensed under the Apache Software License 2.0. \ No newline at end of file diff --git a/ocaml/sdk-gen/java/main.ml b/ocaml/sdk-gen/java/main.ml index 8efaafed4f3..3edcf1ea3a2 100644 --- a/ocaml/sdk-gen/java/main.ml +++ b/ocaml/sdk-gen/java/main.ml @@ -157,8 +157,6 @@ let rec get_java_type ty = let switch_enum = Enum ("XenAPIObjects", List.map (fun x -> (x.name, x.description)) classes) -let _ = get_java_type switch_enum - (*Helper function for get_marshall_function*) let rec get_marshall_function_rec = function | SecretString | String -> @@ -189,6 +187,8 @@ let rec get_marshall_function_rec = function (*get_marshall_function (Set(Map(Float,Bool)));; -> "toSetOfMapOfDoubleBoolean"*) let get_marshall_function ty = "to" ^ get_marshall_function_rec ty +let _ = get_java_type switch_enum + (* Generate the methods *) let get_java_type_or_void = function @@ -204,14 +204,20 @@ let get_java_type_or_void = function (* it has a self parameter or not.*) (*Similar functions for deprecation of methods*) -let get_method_deprecated message = - message.msg_release.internal_deprecated_since <> None -let get_method_deprecated_string message = - if get_method_deprecated message then - "@Deprecated" - else - "" +let get_method_deprecated_release_name message = + match message.msg_release.internal_deprecated_since with + | Some version -> + Some (get_release_branding version) + | None -> + None + +let get_method_deprecated_annotation message = + match get_method_deprecated_release_name message with + | Some version -> + {|@Deprecated(since = "|} ^ version ^ {|")|} + | None -> + "" let get_method_param {param_type= ty; param_name= name; _} = let ty = get_java_type ty in @@ -240,27 +246,10 @@ let get_method_params_for_xml message params = else "this.ref" :: List.map f params -let gen_method_return_cast message = - match message.msg_result with - | None -> - sprintf "" - | Some (ty, _) -> - sprintf " Types.%s(result)" (get_marshall_function ty) - -let gen_method_return file cls message = - if - String.lowercase_ascii cls.name = "event" - && String.lowercase_ascii message.msg_name = "from" - then - fprintf file " return Types.toEventBatch(result);\n" - else - fprintf file " return%s;\n" (gen_method_return_cast message) - let rec range = function 0 -> [] | i -> range (i - 1) @ [i] (* Here is the main method generating function.*) let gen_method file cls message params async_version = - let deprecated_string = get_method_deprecated_string message in let return_type = if String.lowercase_ascii cls.name = "event" @@ -278,9 +267,10 @@ let gen_method file cls message params async_version = ( "BadServerResponse" , "Thrown if the response from the server contains an invalid status." ) - ; ("XenAPIException", "Thrown if the call failed.") - ; ( "XmlRpcException" - , "Thrown if the result of an asynchronous call could not be parsed." + ; ("XenAPIException", "if the call failed.") + ; ( "IOException" + , "if an error occurs during a send or receive. This includes cases \ + where a payload is invalid JSON." ) ] in @@ -291,7 +281,14 @@ let gen_method file cls message params async_version = fprintf file " * Minimum allowed role: %s\n" (get_minimum_allowed_role message) ; if not (publishInfo = "") then fprintf file " * %s\n" publishInfo ; - if get_method_deprecated message then fprintf file " * @deprecated\n" ; + let deprecated_info = + match get_method_deprecated_release_name message with + | Some version -> + " * @deprecated since " ^ version ^ "\n" + | None -> + "" + in + fprintf file "%s" deprecated_info ; fprintf file " *\n" ; fprintf file " * @param c The connection the call is made on\n" ; @@ -328,13 +325,20 @@ let gen_method file cls message params async_version = ) message.msg_errors ; - fprintf file " */\n" ; + fprintf file " */\n" ; + let deprecated_string = + match get_method_deprecated_annotation message with + | "" -> + "" + | other -> + " " ^ other ^ "\n" + in if async_version then - fprintf file " %s public %sTask %sAsync(%s) throws\n" deprecated_string + fprintf file "%s public %sTask %sAsync(%s) throws\n" deprecated_string method_static method_name paramString else - fprintf file " %s public %s%s %s(%s) throws\n" deprecated_string + fprintf file "%s public %s%s %s(%s) throws\n" deprecated_string method_static return_type method_name paramString ; let all_errors = @@ -346,14 +350,14 @@ let gen_method file cls message params async_version = fprintf file " %s {\n" (String.concat ",\n " all_errors) ; if async_version then - fprintf file " String method_call = \"Async.%s.%s\";\n" + fprintf file " String methodCall = \"Async.%s.%s\";\n" message.msg_obj_name message.msg_name else - fprintf file " String method_call = \"%s.%s\";\n" - message.msg_obj_name message.msg_name ; + fprintf file " String methodCall = \"%s.%s\";\n" message.msg_obj_name + message.msg_name ; if message.msg_session then - fprintf file " String session = c.getSessionReference();\n" + fprintf file " String sessionReference = c.getSessionReference();\n" else () ; @@ -366,43 +370,35 @@ let gen_method file cls message params async_version = List.iter (fun {param_name= s; _} -> let name = camel_case s in - fprintf file " Map %s_map = %s.toMap();\n" name - name + fprintf file " var %s_map = %s.toMap();\n" name name ) record_params ; - fprintf file " Object[] method_params = {" ; + fprintf file " Object[] methodParameters = {" ; let methodParamsList = if message.msg_session then - "session" :: get_method_params_for_xml message params + "sessionReference" :: get_method_params_for_xml message params else get_method_params_for_xml message params in - output_string file - (String.concat ", " - (List.map - (fun s -> sprintf "Marshalling.toXMLRPC(%s)" s) - methodParamsList - ) - ) ; + output_string file (String.concat ", " methodParamsList) ; fprintf file "};\n" ; - fprintf file - " Map response = c.dispatch(method_call, method_params);\n" ; - ( if async_version then ( - fprintf file " Object result = response.get(\"Value\");\n" ; - fprintf file " return Types.toTask(result);\n" - ) else - match message.msg_result with - | None -> - fprintf file "" - | Some _ -> - fprintf file " Object result = response.get(\"Value\");\n" ; - gen_method_return file cls message - ) ; + if message.msg_result != None || async_version then + fprintf file " var typeReference = new TypeReference<%s>(){};\n" + (if async_version then "Task" else return_type) ; + + let last_statement = + match message.msg_result with + | None when not async_version -> + " c.dispatch(methodCall, methodParameters);\n" + | _ -> + " return c.dispatch(methodCall, methodParameters, typeReference);\n" + in + fprintf file "%s" last_statement ; fprintf file " }\n\n" @@ -430,15 +426,20 @@ let gen_method_and_asynchronous_counterpart file cls message = let gen_record_field file prefix field cls = let ty = get_java_type field.ty in - let name = - camel_case (String.concat "_" (List.rev (field.field_name :: prefix))) - in + let full_name = String.concat "_" (List.rev (field.field_name :: prefix)) in + let name = camel_case full_name in let publishInfo = get_published_info_field field cls in fprintf file " /**\n" ; fprintf file " * %s\n" (escape_xml field.field_description) ; if not (publishInfo = "") then fprintf file " * %s\n" publishInfo ; fprintf file " */\n" ; - fprintf file " public %s %s;\n" ty name + fprintf file " @JsonProperty(\"%s\")\n" full_name ; + + if field.lifecycle.state = Lifecycle.Deprecated_s then + fprintf file " @Deprecated(since = \"%s\")\n" + (get_release_branding (get_deprecated_release field.lifecycle.transitions)) ; + + fprintf file " public %s %s;\n\n" ty name let rec gen_record_namespace file prefix (name, contents) cls = List.iter (gen_record_contents file (name :: prefix) cls) contents @@ -471,7 +472,7 @@ and gen_record_tostring_contents file prefix = function let field_default = function | SecretString | String -> - "\"\"" + {|""|} | Int -> "0" | Float -> @@ -489,7 +490,7 @@ let field_default = function | Map (t1, t2) -> sprintf "new HashMap<%s, %s>()" (get_java_type t1) (get_java_type t2) | Ref ty -> - sprintf "new %s(\"OpaqueRef:NULL\")" (class_case ty) + sprintf {|new %s("OpaqueRef:NULL")|} (class_case ty) | Record _ -> assert false | Option _ -> @@ -536,7 +537,7 @@ let gen_record file cls = fprintf file " * Convert a %s.Record to a Map\n" cls.name ; fprintf file " */\n" ; fprintf file " public Map toMap() {\n" ; - fprintf file " Map map = new HashMap<>();\n" ; + fprintf file " var map = new HashMap();\n" ; List.iter (gen_record_tomap_contents file []) contents ; if cls.name = "event" then @@ -570,17 +571,18 @@ let gen_class cls folder = let publishInfo = get_published_info_class cls in print_license file ; fprintf file - "package com.xensource.xenapi;\n\n\ - import com.xensource.xenapi.Types.BadServerResponse;\n\ - import com.xensource.xenapi.Types.XenAPIException;\n\n\ - import java.io.PrintWriter;\n\ - import java.io.StringWriter;\n\ - import java.util.Date;\n\ - import java.util.HashMap;\n\ - import java.util.LinkedHashSet;\n\ - import java.util.Map;\n\ - import java.util.Set;\n\n\ - import org.apache.xmlrpc.XmlRpcException;\n\n" ; + {|package com.xensource.xenapi; +import com.fasterxml.jackson.annotation.JsonProperty; +import com.fasterxml.jackson.annotation.JsonValue; +import com.fasterxml.jackson.core.type.TypeReference; +import com.xensource.xenapi.Types.BadServerResponse; +import com.xensource.xenapi.Types.XenAPIException; +import java.io.PrintWriter; +import java.io.StringWriter; +import java.util.*; +import java.io.IOException; + +|} ; fprintf file "/**\n" ; fprintf file " * %s\n" cls.description ; if not (publishInfo = "") then fprintf file " * %s\n" publishInfo ; @@ -591,7 +593,10 @@ let gen_class cls folder = if class_is_empty cls then fprintf file - "\n public String toWireString() {\n return null;\n }\n\n" + " @JsonValue\n\ + \ public String toWireString() {\n\ + \ return null;\n\ + \ }\n\n" else ( fprintf file " /**\n" ; fprintf file " * The XenAPI reference (OpaqueRef) to this object.\n" ; @@ -607,6 +612,7 @@ let gen_class cls folder = fprintf file " * @return The XenAPI reference (OpaqueRef) to this object.\n" ; fprintf file " */\n" ; + fprintf file " @JsonValue\n" ; fprintf file " public String toWireString() {\n" ; fprintf file " return this.ref;\n" ; fprintf file " }\n\n" @@ -648,6 +654,7 @@ let gen_class cls folder = fprintf file "}" ; close_out file +(**?*) (* Generate Marshalling Class *) (*This generates the special case code for marshalling the snapshot field in an Event.Record*) @@ -700,9 +707,22 @@ and gen_marshall_record_contents file prefix = function (* that's been registered as a marshall-needing type*) let generate_reference_task_result_func file clstr = + fprintf file + {| /** + * Attempt to convert the {@link Task}'s result to a {@link %s} object. + * Will return null if the method cannot fetch a valid value from the {@link Task} object. + * @param task The task from which to fetch the result. + * @param connection The connection + * @return the instantiated object if a valid value was found, null otherwise. + * @throws BadServerResponse Thrown if the response from the server contains an invalid status. + * @throws XenAPIException if the call failed. + * @throws IOException if an error occurs during a send or receive. This includes cases where a payload is invalid JSON. + */ +|} + clstr ; fprintf file " public static %s to%s(Task task, Connection connection) throws \ - XenAPIException, BadServerResponse, XmlRpcException, BadAsyncResult{\n" + IOException {\n" clstr clstr ; fprintf file " return Types.to%s(parseResult(task.getResult(connection)));\n" @@ -764,14 +784,12 @@ let rec gen_marshall_body file = function let ty_name' = get_java_type ty' in let marshall_fn = get_marshall_function ty in let marshall_fn' = get_marshall_function ty' in - fprintf file " Map map = (Map)object;\n" ; - fprintf file " Map<%s,%s> result = new HashMap<>();\n" ty_name + fprintf file " var map = (Map)object;\n" ; + fprintf file " var result = new HashMap<%s,%s>();\n" ty_name ty_name' ; - fprintf file " Set entries = map.entrySet();\n" ; - fprintf file " for(Map.Entry entry: entries) {\n" ; - fprintf file " %s key = %s(entry.getKey());\n" ty_name - marshall_fn ; - fprintf file " %s value = %s(entry.getValue());\n" ty_name' + fprintf file " for(var entry: map.entrySet()) {\n" ; + fprintf file " var key = %s(entry.getKey());\n" marshall_fn ; + fprintf file " var value = %s(entry.getValue());\n" marshall_fn' ; fprintf file " result.put(key, value);\n" ; fprintf file " }\n" ; @@ -799,7 +817,27 @@ let rec gen_marshall_func file ty = gen_marshall_func file ty | _ -> let type_string = get_java_type ty in + fprintf file + {| /** + * Converts an {@link Object} to a {@link %s} object. + *
+ * This method takes an {@link Object} as input and attempts to convert it into a {@link %s} object. + * If the input object is null, the method returns null. Otherwise, it creates a new {@link %s} + * object using the input object's {@link String} representation. + *
+ * @param object The {@link Object} to be converted to a {@link %s} object. + * @return A {@link %s} object created from the input {@link Object}'s {@link String} representation, + * or null if the input object is null. + * @deprecated this method will not be publicly exposed in future releases of this package. + */ + @Deprecated +|} + type_string type_string type_string type_string type_string ; let fn_name = get_marshall_function ty in + + if match ty with Map _ | Record _ -> true | _ -> false then + fprintf file " @SuppressWarnings(\"unchecked\")\n" ; + fprintf file " public static %s %s(Object object) {\n" type_string fn_name ; fprintf file " if (object == null) {\n" ; @@ -807,6 +845,7 @@ let rec gen_marshall_func file ty = fprintf file " }\n" ; gen_marshall_body file ty ; fprintf file " }\n\n" +(***) let gen_enum file name ls = let name = class_case name in @@ -821,13 +860,17 @@ let gen_enum file name ls = let final_description = global_replace (regexp_string "\n") "\n * " escaped_description in - " /**\n" - ^ " * " - ^ final_description - ^ "\n" - ^ " */\n" - ^ " " - ^ enum_of_wire name + let comment = + String.concat "\n" + [" /**"; " * " ^ final_description; " */"] + in + let json_property = + if name != "UNRECOGNIZED" then + {|@JsonProperty("|} ^ name ^ {|")|} + else + "@JsonEnumDefaultValue" + in + comment ^ "\n " ^ json_property ^ "\n " ^ enum_of_wire name in fprintf file "%s" (String.concat ",\n" (List.map to_member_declaration ls)) ; fprintf file ";\n" ; @@ -888,165 +931,126 @@ let gen_method_error_throw file name error = ) in - fprintf file " if (ErrorDescription[0].equals(\"%s\"))\n" name ; - fprintf file " {\n" ; + fprintf file " if (errorName.equals(\"%s\")){\n" name ; (* Prepare the parameters to the Exception constructor *) List.iter (fun i -> fprintf file - " String p%i = ErrorDescription.length > %i ? \ - ErrorDescription[%i] : \"\";\n" + " String p%i = errorData.length > %i ? errorData[%i] : \"\";\n" i i i ) (range (List.length error.err_params)) ; - fprintf file " throw new Types.%s(%s);\n" class_name paramsStr ; - fprintf file " }\n" + fprintf file " throw new Types.%s(%s);\n" class_name paramsStr ; + fprintf file " }\n" let gen_types_class folder = let class_name = "Types" in let file = open_out (Filename.concat folder class_name ^ ".java") in print_license file ; fprintf file - "package com.xensource.xenapi;\n\n\ - import java.util.Date;\n\ - import java.util.Map;\n\ - import java.util.HashMap;\n\ - import java.util.Set;\n\ - import java.util.LinkedHashSet;\n\ - import java.io.IOException;\n\n\ - import java.util.regex.Pattern;\n\ - import java.util.regex.Matcher;\n\n\ - import org.apache.xmlrpc.XmlRpcException;\n\n\ - /**\n\ - \ * This class holds vital marshalling functions, enum types and exceptions.\n\ - \ *\n\ - \ * @author Cloud Software Group, Inc.\n\ - \ */\n\ - public class Types\n\ - {\n\ - \ /**\n\ - \ * Interface for all Record classes\n\ - \ */\n\ - \ public interface Record\n\ - \ {\n\ - \ /**\n\ - \ * Convert a Record to a Map\n\ - \ */\n\ - \ Map toMap();\n\ - \ }\n\n\ - \ /**\n\ - \ * Helper method.\n\ - \ */\n\ - \ private static String[] ObjectArrayToStringArray(Object[] objArray)\n\ - \ {\n\ - \ String[] result = new String[objArray.length];\n\ - \ for (int i = 0; i < objArray.length; i++)\n\ - \ {\n\ - \ result[i] = (String) objArray[i];\n\ - \ }\n\ - \ return result;\n\ - \ }\n\n\ - \ /**\n\ - \ * Base class for all XenAPI Exceptions\n\ - \ */\n\ - \ public static class XenAPIException extends IOException {\n\ - \ public final String shortDescription;\n\ - \ public final String[] errorDescription;\n\n\ - \ XenAPIException(String shortDescription)\n\ - \ {\n\ - \ this.shortDescription = shortDescription;\n\ - \ this.errorDescription = null;\n\ - \ }\n\n\ - \ XenAPIException(String[] errorDescription)\n\ - \ {\n\ - \ this.errorDescription = errorDescription;\n\n\ - \ if (errorDescription.length > 0)\n\ - \ {\n\ - \ shortDescription = errorDescription[0];\n\ - \ } else\n\ - \ {\n\ - \ shortDescription = \"\";\n\ - \ }\n\ - \ }\n\n\ - \ public String toString()\n\ - \ {\n\ - \ if (errorDescription == null)\n\ - \ {\n\ - \ return shortDescription;\n\ - \ } else if (errorDescription.length == 0)\n\ - \ {\n\ - \ return \"\";\n\ - \ }\n\ - \ StringBuilder sb = new StringBuilder();\n\ - \ for (int i = 0; i < errorDescription.length - 1; i++)\n\ - \ {\n\ - \ sb.append(errorDescription[i]);\n\ - \ }\n\ - \ sb.append(errorDescription[errorDescription.length - 1]);\n\n\ - \ return sb.toString();\n\ - \ }\n\ - \ }\n\ - \ /**\n\ - \ * Thrown if the response from the server contains an invalid status.\n\ - \ */\n\ - \ public static class BadServerResponse extends XenAPIException\n\ - \ {\n\ - \ public BadServerResponse(Map response)\n\ - \ {\n\ - \ super(ObjectArrayToStringArray((Object[]) \ - response.get(\"ErrorDescription\")));\n\ - \ }\n\ - \ }\n\n\ - \ public static class BadAsyncResult extends XenAPIException\n\ - \ {\n\ - \ public final String result;\n\n\ - \ public BadAsyncResult(String result)\n\ - \ {\n\ - \ super(result);\n\ - \ this.result = result;\n\ - \ }\n\ - \ }\n\n\ - \ private static String parseResult(String result) throws BadAsyncResult\n\ - \ {\n\ - \ Pattern pattern = Pattern.compile(\"(.*)\");\n\ - \ Matcher matcher = pattern.matcher(result);\n\ - \ if (!matcher.find() || matcher.groupCount() != 1) {\n\ - \ throw new Types.BadAsyncResult(\"Can't interpret: \" + result);\n\ - \ }\n\n\ - \ return matcher.group(1);\n\ - \ }\n\ - \ " ; + {|package com.xensource.xenapi; +import java.util.*; +import com.fasterxml.jackson.annotation.JsonEnumDefaultValue; +import com.fasterxml.jackson.annotation.JsonProperty; +import java.io.IOException; +import java.util.regex.Matcher; +import java.util.regex.Pattern; + +/** + * This class holds enum types and exceptions. + */ +public class Types +{ + /** + * Interface for all Record classes + */ + public interface Record + { + /** + * Convert a Record to a Map + */ + Map toMap(); + } + /** + * Base class for all XenAPI Exceptions + */ + public static class XenAPIException extends IOException { + public final String shortDescription; + public final String[] errorDescription; + XenAPIException(String shortDescription) + { + this.shortDescription = shortDescription; + this.errorDescription = null; + } + XenAPIException(String[] errorDescription) + { + this.errorDescription = errorDescription; + if (errorDescription.length > 0) + { + shortDescription = errorDescription[0]; + } else + { + shortDescription = ""; + } + } + public String toString() + { + if (errorDescription == null) + { + return shortDescription; + } else if (errorDescription.length == 0) + { + return ""; + } + StringBuilder sb = new StringBuilder(); + for (int i = 0; i < errorDescription.length - 1; i++) + { + sb.append(errorDescription[i]); + } + sb.append(errorDescription[errorDescription.length - 1]); + return sb.toString(); + } + } + + /** + * Thrown if the response from the server contains an invalid status. + */ + public static class BadServerResponse extends XenAPIException + { + public BadServerResponse(JsonRpcResponseError responseError) + { + super(String.valueOf(responseError)); + } + } +|} ; fprintf file - " /**\n\ - \ * Checks the provided server response was successful. If the call \ - failed, throws a XenAPIException. If the server\n\ - \ * returned an invalid response, throws a BadServerResponse. \ - Otherwise, returns the server response as passed in.\n\ - \ */\n\ - \ static Map checkResponse(Map response) throws XenAPIException, \ - BadServerResponse\n\ - \ {\n\ - \ if (response.get(\"Status\").equals(\"Success\"))\n\ - \ {\n\ - \ return response;\n\ - \ }\n\n\ - \ if (response.get(\"Status\").equals(\"Failure\"))\n\ - \ {\n\ - \ String[] ErrorDescription = \ - ObjectArrayToStringArray((Object[]) response.get(\"ErrorDescription\"));\n\n" ; + {| /** + * Checks the provided server response was successful. If the call + * failed, throws a XenAPIException. If the server + * returned an invalid response, throws a BadServerResponse. + * Otherwise, returns the server response as passed in. + */ + public static void checkError(JsonRpcResponseError response) throws XenAPIException, BadServerResponse + { + var errorData = response.data; + if(errorData.length == 0){ + throw new BadServerResponse(response); + } + var errorName = response.message; +|} ; Hashtbl.iter (gen_method_error_throw file) Datamodel.errors ; fprintf file - "\n\ - \ // An unknown error occurred\n\ - \ throw new Types.XenAPIException(ErrorDescription);\n\ - \ }\n\n\ - \ throw new BadServerResponse(response);\n\ - \ }\n\n" ; + {| + // An unknown error occurred + throw new Types.XenAPIException(errorData); +} + +|} ; gen_enums file ; fprintf file "\n" ; @@ -1056,19 +1060,43 @@ let gen_types_class folder = fprintf file "\n" ; TypeSet.iter (gen_task_result_func file) !types ; fprintf file - "\n\ - \ public static EventBatch toEventBatch(Object object) {\n\ - \ if (object == null) {\n\ - \ return null;\n\ - \ }\n\n\ - \ Map map = (Map) object;\n\ - \ EventBatch batch = new EventBatch();\n\ - \ batch.token = toString(map.get(\"token\"));\n\ - \ batch.validRefCounts = map.get(\"valid_ref_counts\");\n\ - \ batch.events = toSetOfEventRecord(map.get(\"events\"));\n\ - \ return batch;\n\ - \ }" ; - fprintf file "}\n" + {| + + public static class BadAsyncResult extends XenAPIException + { + public final String result; + + public BadAsyncResult(String result) + { + super(result); + this.result = result; + } + } + + private static String parseResult(String result) throws BadAsyncResult + { + Pattern pattern = Pattern.compile("(.*)"); + Matcher matcher = pattern.matcher(result); + if (!matcher.find() || matcher.groupCount() != 1) { + throw new Types.BadAsyncResult("Can't interpret: " + result); + } + + return matcher.group(1); + } + + public static EventBatch toEventBatch(Object object) { + if (object == null) { + return null; + } + Map map = (Map) object; + EventBatch batch = new EventBatch(); + batch.token = toString(map.get("token")); + batch.validRefCounts = map.get("valid_ref_counts"); + batch.events = toSetOfEventRecord(map.get("events")); + return batch; + } +} +|} (* Now run it *) diff --git a/ocaml/sdk-gen/java/main.mli b/ocaml/sdk-gen/java/main.mli new file mode 100644 index 00000000000..c8b99626f9c --- /dev/null +++ b/ocaml/sdk-gen/java/main.mli @@ -0,0 +1 @@ +(* Empty .mli to ensure unused functions are picked up during check*) diff --git a/ocaml/sdk-gen/powershell/autogen/Initialize-Environment.ps1 b/ocaml/sdk-gen/powershell/autogen/Initialize-Environment.ps1 index d418745ee39..c0d7b30dce3 100644 --- a/ocaml/sdk-gen/powershell/autogen/Initialize-Environment.ps1 +++ b/ocaml/sdk-gen/powershell/autogen/Initialize-Environment.ps1 @@ -46,4 +46,6 @@ if (Test-Path $perUserXsProfile) { Remove-Item variable:systemWideXsProfile Remove-Item variable:perUserXsProfile +$global:KnownServerCertificatesFilePath = Join-Path -Path (Split-Path $PROFILE) -ChildPath "XenServer_Known_Certificates.xml" + $XenServer_Environment_Initialized = $true diff --git a/ocaml/sdk-gen/powershell/autogen/README.md b/ocaml/sdk-gen/powershell/autogen/README.md index cbe06791bad..abbb3b0b1e7 100644 --- a/ocaml/sdk-gen/powershell/autogen/README.md +++ b/ocaml/sdk-gen/powershell/autogen/README.md @@ -51,9 +51,9 @@ The XenServer PowerShell Module is dependent upon the following libraries: This archive contains the following folders that are relevant to PowerShell users: -- `XenServerPowerShell\XenServerPSModule`: this is the XenServer PowerShell +- `XenServerPowerShell\PowerShell_7\XenServerPSModule`: this is the XenServer PowerShell Module -- `XenServerPowerShell\src`: contains the C# source code for the XenServer +- `XenServerPowerShell\PowerShell_7\src`: contains the C# source code for the XenServer cmdlets shipped as a Visual Studio project. ## Getting Started diff --git a/ocaml/sdk-gen/powershell/autogen/README_51.md b/ocaml/sdk-gen/powershell/autogen/README_51.md index 8088982ff47..4d5b19e26be 100644 --- a/ocaml/sdk-gen/powershell/autogen/README_51.md +++ b/ocaml/sdk-gen/powershell/autogen/README_51.md @@ -51,9 +51,9 @@ The XenServer PowerShell Module is dependent upon the following libraries: This archive contains the following folders that are relevant to PowerShell users: -- `XenServerPowerShell\XenServerPSModule`: this is the XenServer PowerShell +- `XenServerPowerShell\PowerShell_51\XenServerPSModule`: this is the XenServer PowerShell Module -- `XenServerPowerShell\src`: contains the C# source code for the XenServer +- `XenServerPowerShell\PowerShell_51\src`: contains the C# source code for the XenServer cmdlets shipped as a Visual Studio project. ## Getting Started diff --git a/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs b/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs index d01a03098cb..8f29ecde1f5 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs @@ -42,8 +42,10 @@ namespace Citrix.XenServer class CommonCmdletFunctions { private const string SessionsVariable = "global:Citrix.XenServer.Sessions"; + private const string DefaultSessionVariable = "global:XenServer_Default_Session"; - private static string CertificatePath = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments), @"WindowsPowerShell\XenServer_Known_Certificates.xml"); + + private const string KnownServerCertificatesFilePathVariable = "global:KnownServerCertificatesFilePath"; static CommonCmdletFunctions() { @@ -68,8 +70,7 @@ internal static void SetAllSessions(PSCmdlet cmdlet, Dictionary internal static Session GetDefaultXenSession(PSCmdlet cmdlet) { - object obj = cmdlet.SessionState.PSVariable.GetValue(DefaultSessionVariable); - return obj as Session; + return cmdlet.SessionState.PSVariable.GetValue(DefaultSessionVariable) as Session; } internal static void SetDefaultXenSession(PSCmdlet cmdlet, Session session) @@ -77,19 +78,28 @@ internal static void SetDefaultXenSession(PSCmdlet cmdlet, Session session) cmdlet.SessionState.PSVariable.Set(DefaultSessionVariable, session); } + internal static string GetKnownServerCertificatesFilePathVariable(PSCmdlet cmdlet) + { + var knownCertificatesFilePathObject = cmdlet.SessionState.PSVariable.GetValue(KnownServerCertificatesFilePathVariable); + if (knownCertificatesFilePathObject is PSObject psObject) + return psObject.BaseObject as string; + return knownCertificatesFilePathObject?.ToString() ?? string.Empty; + } + internal static string GetUrl(string hostname, int port) { return string.Format("{0}://{1}:{2}", port == 80 ? "http" : "https", hostname, port); } - public static Dictionary LoadCertificates() + public static Dictionary LoadCertificates(PSCmdlet cmdlet) { Dictionary certificates = new Dictionary(); + var knownServerCertificatesFilePath = GetKnownServerCertificatesFilePathVariable(cmdlet); - if (File.Exists(CertificatePath)) + if (File.Exists(knownServerCertificatesFilePath)) { XmlDocument doc = new XmlDocument(); - doc.Load(CertificatePath); + doc.Load(knownServerCertificatesFilePath); foreach (XmlNode node in doc.GetElementsByTagName("certificate")) { @@ -104,9 +114,10 @@ public static Dictionary LoadCertificates() return certificates; } - public static void SaveCertificates(Dictionary certificates) + public static void SaveCertificates(PSCmdlet cmdlet, Dictionary certificates) { - string dirName = Path.GetDirectoryName(CertificatePath); + var knownServerCertificatesFilePath = GetKnownServerCertificatesFilePathVariable(cmdlet); + string dirName = Path.GetDirectoryName(knownServerCertificatesFilePath); if (!Directory.Exists(dirName)) Directory.CreateDirectory(dirName); @@ -129,7 +140,7 @@ public static void SaveCertificates(Dictionary certificates) } doc.AppendChild(node); - doc.Save(CertificatePath); + doc.Save(knownServerCertificatesFilePath); } public static string FingerprintPrettyString(string fingerprint) diff --git a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs index 0ec80444a85..c1155f7a2a3 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs @@ -253,9 +253,9 @@ protected override void ProcessRecord() private void AddCertificate(string hostname, string fingerprint) { - var certificates = CommonCmdletFunctions.LoadCertificates(); + var certificates = CommonCmdletFunctions.LoadCertificates(this); certificates[hostname] = fingerprint; - CommonCmdletFunctions.SaveCertificates(certificates); + CommonCmdletFunctions.SaveCertificates(this, certificates); } private bool ValidateServerCertificate(object sender, X509Certificate certificate, X509Chain chain, SslPolicyErrors sslPolicyErrors) @@ -274,7 +274,7 @@ private bool ValidateServerCertificate(object sender, X509Certificate certificat bool trusted = VerifyInAllStores(new X509Certificate2(certificate)); - var certificates = CommonCmdletFunctions.LoadCertificates(); + var certificates = CommonCmdletFunctions.LoadCertificates(this); if (certificates.ContainsKey(hostname)) { @@ -292,7 +292,7 @@ private bool ValidateServerCertificate(object sender, X509Certificate certificat } certificates[hostname] = fingerprint; - CommonCmdletFunctions.SaveCertificates(certificates); + CommonCmdletFunctions.SaveCertificates(this, certificates); return true; } } diff --git a/ocaml/sdk-gen/powershell/autogen/src/XenServerPowerShell.csproj b/ocaml/sdk-gen/powershell/autogen/src/XenServerPowerShell.csproj index 85ea0dc72b4..23fff01346e 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/XenServerPowerShell.csproj +++ b/ocaml/sdk-gen/powershell/autogen/src/XenServerPowerShell.csproj @@ -6,7 +6,7 @@ True - + true diff --git a/ocaml/sdk-gen/powershell/common_functions.ml b/ocaml/sdk-gen/powershell/common_functions.ml index d81f9f687db..edff4bf5c70 100644 --- a/ocaml/sdk-gen/powershell/common_functions.ml +++ b/ocaml/sdk-gen/powershell/common_functions.ml @@ -8,7 +8,7 @@ open Datamodel_types open CommonFunctions module DU = Datamodel_utils -let rec pascal_case_ s = +let rec pascal_case_rec s = let ss = Astring.String.cuts ~sep:"_" ~empty:true s |> List.map String.capitalize_ascii @@ -30,7 +30,7 @@ let rec pascal_case_ s = h' ^ String.concat "" tl and pascal_case s = - let str = pascal_case_ s in + let str = pascal_case_rec s in if String.starts_with ~prefix:"set" (String.lowercase_ascii str) || String.starts_with ~prefix:"get" (String.lowercase_ascii str) @@ -59,9 +59,6 @@ and ocaml_class_to_csharp_local_var classname = else String.lowercase_ascii (exposed_class_name classname) -and ocaml_field_to_csharp_local_var field = - String.lowercase_ascii (full_name field) - and ocaml_field_to_csharp_property field = ocaml_class_to_csharp_property (full_name field) @@ -86,39 +83,10 @@ and exposed_class_name classname = and qualified_class_name classname = "XenAPI." ^ exposed_class_name classname -and type_default ty = - match ty with - | Int -> - "" - | SecretString | String -> - "" - | Float -> - "" - | Bool -> - "" - | Enum _ -> - "" - | Record _ -> - "" - | Ref _ -> - "" - | Map (_, _) -> - " = new Hashtable()" - | Set String -> - " = new string[0]" - | _ -> - sprintf " = new %s()" (exposed_type ty) - and escaped = function "params" -> "paramz" | s -> s and full_name field = escaped (String.concat "_" field.full_name) -and exposed_type_opt = function - | Some (typ, _) -> - exposed_type typ - | None -> - "void" - and exposed_type = function | SecretString | String -> "string" @@ -176,7 +144,7 @@ and is_invoke message = && (not (is_constructor message)) && not (is_destructor message) -(* Some adders/removers are just prefixed by Add or RemoveFrom +(* Some adders/removers are just prefixed by Add or Remove and some are prefixed by AddTo or RemoveFrom *) and cut_msg_name message_name fn_type = let name_len = String.length message_name in @@ -197,7 +165,6 @@ and cut_msg_name message_name fn_type = else message_name -(* True if an object has a uuid (and therefore should have a get_by_uuid message *) and has_uuid x = let all_fields = DU.fields_of_obj x in List.filter (fun fld -> fld.full_name = ["uuid"]) all_fields <> [] @@ -230,7 +197,7 @@ and get_http_action_stem name = let parts = Astring.String.cuts ~sep:"_" name in let filtered = List.filter trim_http_action_stem parts in let trimmed = String.concat "_" filtered in - match trimmed with "" -> pascal_case_ "vm" | _ -> pascal_case_ trimmed + match trimmed with "" -> pascal_case_rec "vm" | _ -> pascal_case_rec trimmed and trim_http_action_stem x = match x with diff --git a/ocaml/sdk-gen/powershell/common_functions.mli b/ocaml/sdk-gen/powershell/common_functions.mli new file mode 100644 index 00000000000..b13bd53aea2 --- /dev/null +++ b/ocaml/sdk-gen/powershell/common_functions.mli @@ -0,0 +1,98 @@ +val get_http_action_stem : string -> string +(** Gets the HTTP action stem based on the name. + @param name - Name to analyze. + @return HTTP action stem. *) + +val get_http_action_verb : string -> Datamodel.http_meth -> string +(** Gets the HTTP action verb based on the name and method. + @param name - Name to analyze. + @param meth - HTTP method. + @return HTTP action verb. *) + +val get_common_verb_category : string -> string +(** Gets the common verb category based on the HTTP action verb. + @param verb - HTTP action verb. + @return Common verb category. *) + +val pascal_case_rec : string -> string +(** Recursively converts a string to PascalCase. + @param s - String to convert. + @return PascalCase formatted string. *) + +val qualified_class_name : string -> string +(** Gets the qualified class name by prepending "XenAPI." to the exposed class name. + @param classname - Class name. + @return Qualified class name. *) + +val ocaml_class_to_csharp_local_var : string -> string +(** Converts an OCaml class name to a C# local variable. + @param classname - OCaml class name. + @return C# local variable name. *) + +val ocaml_class_to_csharp_property : string -> string +(** Converts an OCaml class name to a C# property name. + @param classname - OCaml class name. + @return C# property name. *) + +val ocaml_class_to_csharp_class : string -> string +(** Converts an OCaml class name to a C# class name. + @param classname - OCaml class name. + @return C# class name. *) + +val is_invoke : Datamodel_types.message -> bool +(** Checks if a message is an invoke operation. + @param message - Message to check. + @return true if it's an invoke operation, false otherwise. *) + +val has_uuid : Datamodel_types.obj -> bool +(** Checks if an object has a UUID field, and therefore should have a get_by_uuid message. + @param x - Object to check. + @return true if the object has a UUID field, false otherwise. *) + +val has_name : Datamodel_types.obj -> bool +(** Checks if an object has a name field. + @param x - Object to check. + @return true if the object has a name field, false otherwise. *) + +val full_name : Datamodel_types.field -> string +(** Gets the full name of a field as a single string with underscores escaped. + @param field - Field to extract the full name from. + @return Full name with underscores escaped. *) + +val obj_internal_type : Datamodel_types.ty -> string +(** Gets the internal type representation of an object. + @param x - Object to determine the internal type for. + @return Internal type representation as a string. *) + +val ocaml_field_to_csharp_property : Datamodel_types.field -> string +(** Converts an OCaml field to its corresponding C# property name. + @param field - OCaml field. + @return C# property name. *) + +val exposed_type : Datamodel_types.ty -> string +(** Converts an exposed type from OCaml to its corresponding C# type. + @param ty - OCaml type. + @return Corresponding C# type. *) + +val pascal_case : string -> string +(** Converts a string to PascalCase. + @param s - Input string. + @return PascalCase formatted string. *) + +val exposed_class_name : string -> string +(** Converts an OCaml class name to a corresponding exposed class name in C#. + @param classname - OCaml class name. + @return Exposed class name in C#. *) + +val cut_msg_name : string -> string -> string +(** Extracts the base name from an OCaml message name by removing the specified prefix. + Some adders/removers are just prefixed by Add or Remove and some are prefixed by + AddTo or RemoveFrom. + @param message_name - OCaml message name. + @param fn_type - Prefix to remove ("Add" or "Remove"). + @return Base name after removing the specified prefix. *) + +val lower_and_underscore_first : string -> string +(** Converts a string to lowercase and adds an underscore at the beginning. + @param s - Input string. + @return String in lowercase with an underscore at the beginning. *) diff --git a/ocaml/sdk-gen/powershell/gen_powershell_binding.ml b/ocaml/sdk-gen/powershell/gen_powershell_binding.ml index 2e1fb55e5fb..b455d010486 100644 --- a/ocaml/sdk-gen/powershell/gen_powershell_binding.ml +++ b/ocaml/sdk-gen/powershell/gen_powershell_binding.ml @@ -69,17 +69,38 @@ let generated x = not (List.mem x.name ["blob"; "session"; "debug"; "event"; "vtpm"]) let rec main () = - gen_xenref_converters classes ; + let json = + `O + [ + ( "all_classes" + , `A + (List.map + (fun x -> + `O + [ + ("exposed_name", `String (exposed_class_name x.name)) + ; ( "var_name" + , `String (ocaml_class_to_csharp_local_var x.name) + ) + ] + ) + classes + ) + ) + ] + in + render_file + ("ConvertTo-XenRef.mustache", "ConvertTo-XenRef.cs") + json templdir destdir ; + + http_actions + |> List.filter (fun (_, (_, _, sdk, _, _, _)) -> sdk) + |> List.iter gen_http_action ; + let cmdlets = classes |> List.filter generated |> List.map gen_cmdlets |> List.concat in - let http_cmdlets = - http_actions - |> List.filter (fun (_, (_, _, sdk, _, _, _)) -> sdk) - |> List.map gen_http_action - in - let all_cmdlets = cmdlets @ http_cmdlets in - List.iter (fun x -> write_file x.filename x.content) all_cmdlets + List.iter (fun x -> write_file x.filename x.content) cmdlets (****************) (* Http actions *) @@ -89,196 +110,58 @@ and gen_http_action action = let commonVerb = get_http_action_verb name meth in let verbCategory = get_common_verb_category commonVerb in let stem = get_http_action_stem name in - let content = - sprintf - "%s\n\n\ - using System;\n\ - using System.Collections;\n\ - using System.Collections.Generic;\n\ - using System.Management.Automation;\n\ - using XenAPI;\n\n\ - namespace Citrix.XenServer.Commands\n\ - {\n\ - \ [Cmdlet(%s.%s, \"Xen%s\"%s)]\n\ - \ [OutputType(typeof(void))]\n\ - \ public class %sXen%sCommand : XenServerHttpCmdlet\n\ - \ {\n\ - \ #region Cmdlet Parameters\n\ - %s%s\n\ - \ #endregion\n\n\ - \ #region Cmdlet Methods\n\n\ - \ protected override void ProcessRecord()\n\ - \ {\n\ - \ GetSession();\n\ - %s\n\ - \ RunApiCall(() => %s);\n\ - \ }\n\n\ - \ #endregion\n\ - \ }\n\ - }\n" - Licence.bsd_two_clause verbCategory commonVerb stem - (gen_should_process_http_decl meth) - commonVerb stem - (gen_progress_tracker meth) - (gen_arg_params args) - (gen_should_process_http meth uri) - (gen_http_action_call action) + let arg_name = function + | String_query_arg x | Int64_query_arg x -> + pascal_case_rec x + | Bool_query_arg x -> + if String.lowercase_ascii x = "host" then + "IsHost" + else + pascal_case_rec x + | Varargs_query_arg -> + "Args" in - {filename= sprintf "%s-Xen%s.cs" commonVerb stem; content} - -and gen_should_process_http_decl meth = - match meth with - | Put -> - ", SupportsShouldProcess = true" - | Get -> - ", SupportsShouldProcess = false" - | _ -> - assert false - -and gen_should_process_http meth uri = - match meth with - | Put -> - sprintf - "\n if (!ShouldProcess(\"%s\"))\n return;\n" - uri - | _ -> - "" - -and gen_progress_tracker meth = - match meth with - | Get -> - "\n\ - \ [Parameter]\n\ - \ public HTTP.DataCopiedDelegate DataCopiedDelegate { get; set; }\n" - | Put -> - "\n\ - \ [Parameter]\n\ - \ public HTTP.UpdateProgressDelegate ProgressDelegate { get; set; }\n" - | _ -> - assert false - -and gen_arg_params args = - match args with - | [] -> - "" - | hd :: tl -> - sprintf "%s%s" (gen_arg_param hd) (gen_arg_params tl) - -and gen_arg_param = function - | String_query_arg x -> - sprintf - "\n [Parameter%s]\n public string %s { get; set; }\n" - ( if String.lowercase_ascii x = "uuid" then - "(ValueFromPipelineByPropertyName = true)" - else - "" + let arg_type = function + | String_query_arg _ -> + "string" + | Int64_query_arg _ -> + "long?" + | Bool_query_arg _ -> + "bool?" + | Varargs_query_arg -> + "string[]" + in + let json = + `O + [ + ("verb_category", `String verbCategory) + ; ("common_verb", `String commonVerb) + ; ("stem", `String stem) + ; ("isPut", `Bool (meth == Put)) + ; ("isGet", `Bool (meth == Get)) + ; ("uri", `String uri) + ; ("action_name", `String name) + ; ( "args" + , `A + (List.map + (fun x -> + `O + [ + ("arg_type", `String (arg_type x)) + ; ("arg_name", `String (arg_name x)) + ; ( "from_pipeline" + , `Bool (String.lowercase_ascii (arg_name x) = "uuid") + ) + ] + ) + args + ) ) - (pascal_case_ x) - | Int64_query_arg x -> - sprintf "\n [Parameter]\n public long? %s { get; set; }\n" - (pascal_case_ x) - | Bool_query_arg x -> - let y = if x = "host" then "is_host" else x in - sprintf "\n [Parameter]\n public bool? %s { get; set; }\n" - (pascal_case_ y) - | Varargs_query_arg -> - sprintf - "\n\ - \ ///

\n\ - \ /// Alternate names and values\n\ - \ ///\n\ - \ [Parameter]\n\ - \ public string[] Args { get; set; }\n" - -and gen_http_action_call (name, (meth, _, _, args, _, _)) = - let progressTracker = - match meth with - | Get -> - "DataCopiedDelegate" - | Put -> - "ProgressDelegate" - | _ -> - assert false + ] in - sprintf - "XenAPI.HTTP_actions.%s(%s,\n\ - \ CancellingDelegate, TimeoutMs, XenHost, Proxy, Path, \ - TaskRef,\n\ - \ session.opaque_ref%s)" name progressTracker - (gen_call_arg_params args) - -and gen_call_arg_params args = - match args with - | [] -> - "" - | hd :: tl -> - sprintf "%s%s" (gen_call_arg_param hd) (gen_call_arg_params tl) - -and gen_call_arg_param = function - | String_query_arg x -> - sprintf ", %s" (pascal_case_ x) - | Int64_query_arg x -> - sprintf ", %s" (pascal_case_ x) - | Bool_query_arg x -> - let y = if x = "host" then "is_host" else x in - sprintf ", %s" (pascal_case_ y) - | Varargs_query_arg -> - sprintf ", Args" - -(***********************************) -(* Utility cmdlet ConvertTo-XenRef *) -(***********************************) -and gen_xenref_converters classes = - write_file "ConvertTo-XenRef.cs" (gen_body_xenref_converters classes) - -and gen_body_xenref_converters classes = - sprintf - "%s\n\n\ - using System;\n\ - using System.Collections;\n\ - using System.Collections.Generic;\n\ - using System.Management.Automation;\n\ - using XenAPI;\n\n\ - namespace Citrix.XenServer.Commands\n\ - {\n\ - \ [Cmdlet(VerbsData.ConvertTo, \"XenRef\")]\n\ - \ [OutputType(typeof(IXenObject))]\n\ - \ public class ConvertToXenRefCommand : PSCmdlet\n\ - \ {\n\ - \ #region Cmdlet Parameters\n\n\ - \ [Parameter(Mandatory = true, ValueFromPipeline = true, Position = \ - 0)]\n\ - \ public IXenObject XenObject { get; set; }\n\n\ - \ #endregion\n\n\ - \ #region Cmdlet Methods\n\n\ - \ protected override void ProcessRecord()\n\ - \ {%s\n\ - \ }\n\n\ - \ #endregion\n\n\ - \ }\n\ - }\n" - Licence.bsd_two_clause (print_converters classes) - -and print_converters classes = - match classes with - | [] -> - "" - | hd :: tl -> - sprintf - "\n\ - \ %s %s = XenObject as %s;\n\ - \ if (%s != null)\n\ - \ {\n\ - \ WriteObject(new XenRef<%s>(%s));\n\ - \ return;\n\ - \ }%s" - (qualified_class_name hd.name) - (ocaml_class_to_csharp_local_var hd.name) - (qualified_class_name hd.name) - (ocaml_class_to_csharp_local_var hd.name) - (qualified_class_name hd.name) - (ocaml_class_to_csharp_local_var hd.name) - (print_converters tl) + render_file + ("HttpAction.mustache", sprintf "%s-Xen%s.cs" commonVerb stem) + json templdir destdir (*************************) (* Autogenerated cmdlets *) @@ -554,15 +437,6 @@ and print_methods_constructor message obj classname = (gen_shouldprocess "New" message classname) (gen_csharp_api_call message classname "New" "passthru") -and create_param_parse param paramName = - match param.param_type with - | Ref _ -> - sprintf "\n string %s = %s.opaque_ref;\n" - (String.lowercase_ascii param.param_name) - paramName - | _ -> - "" - and gen_make_record obj classname = sprintf "\n\ @@ -1147,37 +1021,6 @@ and print_cmdlet_methods_dynamic classname messages enum commonVerb = enum (cut_message_name hd) (cut_message_name hd) localVar (print_cmdlet_methods_dynamic classname tl enum commonVerb) -and print_async_param_getter classname asyncMessages = - let properties = - List.map - (fun x -> - sprintf " case Xen%sProperty.%s:" - (ocaml_class_to_csharp_class classname) - x - ) - asyncMessages - in - match asyncMessages with - | [] -> - "" - | _ -> - sprintf - "\n\ - \ protected override bool GenerateAsyncParam\n\ - \ {\n\ - \ get\n\ - \ {\n\ - \ switch (XenProperty)\n\ - \ {\n\ - %s\n\ - \ return true;\n\ - \ default:\n\ - \ return false;\n\ - \ }\n\ - \ }\n\ - \ }\n" - (String.concat "\n" properties) - (**************************************) (* Common to more than one generators *) (**************************************) diff --git a/ocaml/sdk-gen/powershell/gen_powershell_binding.mli b/ocaml/sdk-gen/powershell/gen_powershell_binding.mli new file mode 100644 index 00000000000..c8b99626f9c --- /dev/null +++ b/ocaml/sdk-gen/powershell/gen_powershell_binding.mli @@ -0,0 +1 @@ +(* Empty .mli to ensure unused functions are picked up during check*) diff --git a/ocaml/sdk-gen/powershell/templates/ConvertTo-XenRef.mustache b/ocaml/sdk-gen/powershell/templates/ConvertTo-XenRef.mustache new file mode 100644 index 00000000000..669704fa3d1 --- /dev/null +++ b/ocaml/sdk-gen/powershell/templates/ConvertTo-XenRef.mustache @@ -0,0 +1,63 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +using System.Management.Automation; +using XenAPI; + +namespace Citrix.XenServer.Commands +{ + [Cmdlet(VerbsData.ConvertTo, "XenRef")] + [OutputType(typeof(IXenObject))] + public class ConvertToXenRefCommand : PSCmdlet + { + #region Cmdlet Parameters + + [Parameter(Mandatory = true, ValueFromPipeline = true, Position = 0, + HelpMessage = "The API object to convert")] + public IXenObject XenObject { get; set; } + + #endregion + + #region Cmdlet Methods + + protected override void ProcessRecord() + { +{{#all_classes}} + if (XenObject is {{exposed_name}} {{var_name}}) + { + WriteObject(new XenRef<{{exposed_name}}>({{var_name}})); + return; + } +{{/all_classes}} + } + + #endregion + } +} diff --git a/ocaml/sdk-gen/powershell/templates/HttpAction.mustache b/ocaml/sdk-gen/powershell/templates/HttpAction.mustache new file mode 100644 index 00000000000..e346a68b8fe --- /dev/null +++ b/ocaml/sdk-gen/powershell/templates/HttpAction.mustache @@ -0,0 +1,80 @@ +/* + * Copyright (c) Cloud Software Group, Inc. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1) Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2) Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +using System; +using System.Collections; +using System.Collections.Generic; +using System.Management.Automation; +using XenAPI; + +namespace Citrix.XenServer.Commands +{ + [Cmdlet({{verb_category}}.{{common_verb}}, "Xen{{stem}}", SupportsShouldProcess = {{#isPut}}true{{/isPut}}{{#isGet}}false{{/isGet}})] + [OutputType(typeof(void))] + public class {{common_verb}}Xen{{stem}}Command : XenServerHttpCmdlet + { + #region Cmdlet Parameters +{{#isPut}} + + [Parameter] + public HTTP.UpdateProgressDelegate ProgressDelegate { get; set; } +{{/isPut}} +{{#isGet}} + + [Parameter] + public HTTP.DataCopiedDelegate DataCopiedDelegate { get; set; } +{{/isGet}} +{{#args}} + + [Parameter{{#from_pipeline}}(ValueFromPipelineByPropertyName = true){{/from_pipeline}}] + public {{arg_type}} {{arg_name}} { get; set; } +{{/args}} + + #endregion + + #region Cmdlet Methods + + protected override void ProcessRecord() + { + GetSession(); +{{#isPut}} + + if (!ShouldProcess("{{uri}}")) + return; +{{/isPut}} + + RunApiCall(() => HTTP_actions.{{action_name}}({{#isPut}}ProgressDelegate{{/isPut}}{{#isGet}}DataCopiedDelegate{{/isGet}}, + CancellingDelegate, TimeoutMs, XenHost, Proxy, Path, TaskRef, + session.opaque_ref{{#args}}, {{arg_name}}{{/args}})); + } + + #endregion + } +} diff --git a/ocaml/sdk-gen/windows-line-endings.sh b/ocaml/sdk-gen/windows-line-endings.sh index 0b11db3ba3a..f61801e1e83 100644 --- a/ocaml/sdk-gen/windows-line-endings.sh +++ b/ocaml/sdk-gen/windows-line-endings.sh @@ -1,18 +1,19 @@ +#!/bin/bash # # Copyright (c) Cloud Software Group, Inc. -# +# # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: -# +# # 1) Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. -# +# # 2) Redistributions in binary form must reproduce the above # copyright notice, this list of conditions and the following # disclaimer in the documentation and/or other materials # provided with the distribution. -# +# # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS diff --git a/ocaml/tests/common/alcotest_comparators.ml b/ocaml/tests/common/alcotest_comparators.ml index 7dce3faa85a..21f596875ea 100644 --- a/ocaml/tests/common/alcotest_comparators.ml +++ b/ocaml/tests/common/alcotest_comparators.ml @@ -31,9 +31,11 @@ let vdi_nbd_server_info_set = let vdi_type : API.vdi_type Alcotest.testable = from_rpc_of_t API.rpc_of_vdi_type -let db_cache_structured_op = from_rpc_of_t Db_cache_types.rpc_of_structured_op_t +let db_cache_structured_op = + from_rpc_of_t Xapi_database.Db_cache_types.rpc_of_structured_op_t -let db_rpc_request = from_rpc_of_t Db_rpc_common_v2.Request.rpc_of_t +let db_rpc_request = + from_rpc_of_t Xapi_database.Db_rpc_common_v2.Request.rpc_of_t let ref () = from_to_string Ref.string_of diff --git a/ocaml/tests/common/dune b/ocaml/tests/common/dune index fdc6fbd9a6c..c578f5f9785 100644 --- a/ocaml/tests/common/dune +++ b/ocaml/tests/common/dune @@ -1,6 +1,7 @@ (library (name tests_common) (modules :standard) + (modes best) (wrapped false) (libraries alcotest diff --git a/ocaml/tests/common/mock.ml b/ocaml/tests/common/mock.ml index e27f3b78e0e..ec6cb44a8a7 100644 --- a/ocaml/tests/common/mock.ml +++ b/ocaml/tests/common/mock.ml @@ -13,6 +13,8 @@ *) module Database = struct + open Xapi_database + let _schema = Datamodel_schema.of_datamodel () let conn = [Parse_db_conf.make "./xapi-db.xml"] diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 93bf4b66ddf..126b522e151 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -1,6 +1,6 @@ (test (name suite_alcotest) - (modes exe) + (modes (best exe)) (package xapi) (modules (:standard \ test_daemon_manager test_vdi_cbt test_event test_clustering @@ -121,6 +121,7 @@ (name test_observer) (package xapi) (modules test_observer) +(modes (best exe)) (libraries alcotest tracing xapi_internal tests_common yojson)) (rule diff --git a/ocaml/tests/test_db_lowlevel.ml b/ocaml/tests/test_db_lowlevel.ml index 7745f8e7cdc..fb3a3ce9da5 100644 --- a/ocaml/tests/test_db_lowlevel.ml +++ b/ocaml/tests/test_db_lowlevel.ml @@ -13,6 +13,7 @@ *) open Test_common +open Xapi_database (* If we delete a record after making a Db.get_all_records call, but before the * call returns, then Db.get_all_records should return successfully (not throw diff --git a/ocaml/tests/test_ha_vm_failover.ml b/ocaml/tests/test_ha_vm_failover.ml index 1c4cf79e6ea..4ab377870ab 100644 --- a/ocaml/tests/test_ha_vm_failover.ml +++ b/ocaml/tests/test_ha_vm_failover.ml @@ -384,7 +384,7 @@ module AssertNewVMPreservesHAPlan = Generic.MakeStateful (struct let load_input __context (pool, _) = setup ~__context pool let extract_output __context (_pool, vm) = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let local_sr = Db.SR.get_refs_where ~__context ~expr:(Eq (Field "shared", Literal "false")) diff --git a/ocaml/tests/test_helpers.ml b/ocaml/tests/test_helpers.ml index c3b86bbff82..42028c0d072 100644 --- a/ocaml/tests/test_helpers.ml +++ b/ocaml/tests/test_helpers.ml @@ -62,7 +62,7 @@ module DetermineGateway = Generic.MakeStateful (struct let management_interface = Option.map (fun device -> - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let pifs = Db.PIF.get_refs_where ~__context ~expr:(Eq (Field "device", Literal device)) diff --git a/ocaml/tests/test_livepatch.ml b/ocaml/tests/test_livepatch.ml index 31b0eef8bfc..b87b657c8fe 100644 --- a/ocaml/tests/test_livepatch.ml +++ b/ocaml/tests/test_livepatch.ml @@ -52,6 +52,38 @@ lp_4.13.4-10.22.xs8-4.13.4-10.23.xs8 | CHECKED |} , None ) + ; ( {| + ID | status +----------------------------------------+------------ +lp_4.13.4-10.22.xs8-4.13.4-10.23.xs8| CHECKED +lp_4.13.4-10.22.xs8-4.13.4-10.23.xs8| APPLIED + |} + , Some ("4.13.4", "10.22.xs8", "4.13.4", "10.23.xs8") + ) + ; ( {| + ID | status +----------------------------------------+------------ + lp_4.13.4-10.22.xs8-4.13.4-10.23.xs8|CHECKED + lp_4.13.4-10.22.xs8-4.13.4-10.23.xs8|APPLIED + |} + , Some ("4.13.4", "10.22.xs8", "4.13.4", "10.23.xs8") + ) + ; ( {| + ID | status +----------------------------------------+------------ +p_4.13.4-10.22.xs8-4.13.4-10.23.xs8 | CHECKED +p_4.13.4-10.22.xs8-4.13.4-10.23.xs8 | APPLIED + |} + , None + ) + ; ( {| + ID | status | metadata +----------------------------------------+------------+--------------- +lp_4.17.3-3.11.gf717213.xs8-4.17.3-3.12.xs8| CHECKED | +lp_4.17.3-3.11.gf717213.xs8-4.17.3-3.13.xs8| APPLIED | + |} + , Some ("4.17.3", "3.11.gf717213.xs8", "4.17.3", "3.13.xs8") + ) ] end) diff --git a/ocaml/tests/test_observer.ml b/ocaml/tests/test_observer.ml index 165bc4afd1b..a6b943741b1 100644 --- a/ocaml/tests/test_observer.ml +++ b/ocaml/tests/test_observer.ml @@ -12,6 +12,7 @@ * GNU Lesser General Public License for more details. *) open Tracing +open Tracing_export module D = Debug.Make (struct let name = "test_observer" end) @@ -38,8 +39,8 @@ let trace_log_dir ?(test_name = "") () = (Printf.sprintf "%s/var/log/dt/zipkinv2/json/" test_name) let () = - Export.Destination.File.set_trace_log_dir (trace_log_dir ()) ; - Export.set_service_name "unit_tests" ; + Destination.File.set_trace_log_dir (trace_log_dir ()) ; + set_service_name "unit_tests" ; set_observe false module Xapi_DB = struct @@ -62,17 +63,15 @@ end module TracerProvider = struct let assert_num_observers ~__context x = - let providers = Tracing.get_tracer_providers () in + let providers = get_tracer_providers () in Alcotest.(check int) (Printf.sprintf "%d provider(s) exists in lib " x) x (List.length providers) let find_provider_exn ~name = - let providers = Tracing.get_tracer_providers () in + let providers = get_tracer_providers () in match - List.find_opt - (fun x -> Tracing.TracerProvider.get_name_label x = name) - providers + List.find_opt (fun x -> TracerProvider.get_name_label x = name) providers with | Some provider -> provider @@ -83,11 +82,11 @@ module TracerProvider = struct let provider = find_provider_exn ~name in Alcotest.(check bool) "Provider disabled" false - (Tracing.TracerProvider.get_enabled provider) + (TracerProvider.get_enabled provider) let assert_mandatory_attributes ~name = let provider = find_provider_exn ~name in - let tags = Tracing.TracerProvider.get_attributes provider in + let tags = TracerProvider.get_attributes provider in List.iter (fun x -> try @@ -106,7 +105,7 @@ module TracerProvider = struct let check_endpoints ~name ~endpoints = let provider = find_provider_exn ~name in let provider_endpoints = - Tracing.TracerProvider.get_endpoints provider + TracerProvider.get_endpoints provider |> List.map (fun endpoint -> match endpoint with | Bugtool -> @@ -338,7 +337,7 @@ let test_file_export_writes () = let test_trace_log_dir = trace_log_dir ~test_name:"test_file_export_writes" () in - Export.Destination.File.set_trace_log_dir test_trace_log_dir ; + Destination.File.set_trace_log_dir test_trace_log_dir ; let __context = Test_common.make_test_database () in let self = test_create ~__context ~enabled:true () in clear_dir ~test_trace_log_dir () ; @@ -347,7 +346,7 @@ let test_file_export_writes () = match span with | Ok x -> ( let _ = Tracer.finish x in - Tracing.Export.Destination.flush_spans () ; + Destination.flush_spans () ; Alcotest.(check bool) "tracing files written to disk when tracing enabled by default" false @@ -365,7 +364,7 @@ let test_file_export_writes () = match span with | Ok x -> let _ = Tracer.finish x in - Tracing.Export.Destination.flush_spans () ; + Destination.flush_spans () ; Alcotest.(check bool) "tracing files not written when tracing disabled" true (is_dir_empty ~test_trace_log_dir) @@ -424,7 +423,7 @@ let test_hashtbl_leaks () = (Tracer.finished_span_hashtbl_is_empty ()) false ; - Tracing.Export.Destination.flush_spans () ; + Destination.flush_spans () ; Alcotest.(check bool) "Span export clears finished_spans hashtable" (Tracer.finished_span_hashtbl_is_empty ()) @@ -515,14 +514,14 @@ let test_attribute_validation () = Alcotest.(check bool) ("Good key, value pair with " ^ key ^ ":" ^ value) true - (Tracing.validate_attribute (key, value)) + (validate_attribute (key, value)) in let test_bad_attribute (key, value) = Alcotest.(check bool) ("Bad key, value pair with " ^ key ^ ":" ^ value) false - (Tracing.validate_attribute (key, value)) + (validate_attribute (key, value)) in List.iter test_good_attribute good_attributes ; diff --git a/ocaml/tests/test_vm_check_operation_error.ml b/ocaml/tests/test_vm_check_operation_error.ml index a91fdcfa229..567ac89f49f 100644 --- a/ocaml/tests/test_vm_check_operation_error.ml +++ b/ocaml/tests/test_vm_check_operation_error.ml @@ -1,54 +1,6 @@ -let all_vm_operations = - [ - `assert_operation_valid - ; `awaiting_memory_live - ; `call_plugin - ; `changing_VCPUs - ; `changing_VCPUs_live - ; `changing_dynamic_range - ; `changing_memory_limits - ; `changing_memory_live - ; `changing_shadow_memory - ; `changing_shadow_memory_live - ; `changing_static_range - ; `changing_NVRAM - ; `checkpoint - ; `clean_reboot - ; `clean_shutdown - ; `clone - ; `copy - ; `create_template - ; `csvm - ; `data_source_op - ; `destroy - ; `export - ; `get_boot_record - ; `hard_reboot - ; `hard_shutdown - ; `import - ; `make_into_template - ; `metadata_export - ; `migrate_send - ; `pause - ; `pool_migrate - ; `power_state_reset - ; `provision - ; `query_services - ; `resume - ; `resume_on - ; `revert - ; `reverting - ; `send_sysrq - ; `send_trigger - ; `shutdown - ; `snapshot - ; `snapshot_with_quiesce - ; `start - ; `start_on - ; `suspend - ; `unpause - ; `update_allowed_operations - ] +let vm_op_to_string = API.vm_operations_to_string + +let pp_vm_op () = Fmt.(str "%a" (of_to_string vm_op_to_string)) let with_test_vm f = let __context = Mock.make_context_with_new_db "Mock context" in @@ -75,7 +27,7 @@ let test_null_vdi () = ~strict:true ) ) - all_vm_operations + API.vm_operations__all ) let test_vm_set_nvram_running () = @@ -155,6 +107,71 @@ let test_sxm_allowed_when_rum () = ) ) +let test_is_allowed_concurrently (expected, (op, current_ops)) = + let ops_to_str ops = + String.concat "," (List.map (fun (_, op) -> vm_op_to_string op) ops) + in + let name = + match current_ops with + | [] -> + vm_op_to_string op + | lst -> + Printf.sprintf "%a when %s" pp_vm_op op (ops_to_str lst) + in + + let test () = + let actual = Xapi_vm_lifecycle.is_allowed_concurrently ~op ~current_ops in + let name = + Printf.sprintf "%a allowed in [%s]" pp_vm_op op (ops_to_str current_ops) + in + Alcotest.(check bool) name expected actual + in + (name, `Quick, test) + +let allowed_specs = + let current_of op = ((), op) in + let allow_hard_shutdown = + List.map + (fun op -> + let allowed = match op with `hard_shutdown -> false | _ -> true in + (allowed, (`hard_shutdown, [current_of op])) + ) + API.vm_operations__all + in + let allow_hard_reboot = + List.map + (fun op -> + let allowed = + match op with `hard_shutdown | `hard_reboot -> false | _ -> true + in + (allowed, (`hard_reboot, [current_of op])) + ) + API.vm_operations__all + in + let allow_clean_shutdown = + List.map + (fun op -> + let allowed = match op with `migrate_send -> true | _ -> false in + (allowed, (`clean_shutdown, [current_of op])) + ) + API.vm_operations__all + in + List.concat + [ + [ + (true, (`snapshot, [])) + ; (true, (`snapshot, [current_of `checkpoint])) + ; (false, (`migrate_send, [current_of `clean_reboot])) + ; (true, (`clean_reboot, [current_of `migrate_send])) + ] + ; allow_hard_shutdown + ; allow_clean_shutdown + ; allow_hard_reboot + ] + +let test_allow_concurrently = + List.map test_is_allowed_concurrently allowed_specs + let test = [ ("test_null_vdi", `Quick, test_null_vdi) @@ -166,3 +183,4 @@ let test = ; ("test_sxm_allowed_when_rum", `Quick, test_sxm_allowed_when_rum) ; ("test_vm_set_nvram when VM is running", `Quick, test_vm_set_nvram_running) ] + @ test_allow_concurrently diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index f8aa043eb5a..72f34e3ace9 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -1756,7 +1756,13 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "vm-export" , { reqd= ["filename"] - ; optn= ["preserve-power-state"; "compress"] + ; optn= + [ + "preserve-power-state" + ; "compress" + ; "metadata" + ; "excluded-device-types" + ] ; help= "Export a VM to ." ; implementation= With_fd Cli_operations.vm_export ; flags= [Standard; Vm_selectors] @@ -1798,7 +1804,13 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "snapshot-export-to-template" , { reqd= ["filename"; "snapshot-uuid"] - ; optn= ["preserve-power-state"] + ; optn= + [ + "preserve-power-state" + ; "compress" + ; "metadata" + ; "excluded-device-types" + ] ; help= "Export a snapshot to ." ; implementation= With_fd Cli_operations.snapshot_export ; flags= [Standard] @@ -1863,7 +1875,7 @@ let rec cmdtable_data : (string * cmd_spec) list = ; ( "template-export" , { reqd= ["filename"; "template-uuid"] - ; optn= [] + ; optn= ["compress"; "metadata"; "excluded-device-types"] ; help= "Export a template to ." ; implementation= With_fd Cli_operations.template_export ; flags= [Standard] @@ -3671,6 +3683,33 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "pci-enable-dom0-access" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Enable PCI access to dom0." + ; implementation= No_fd Cli_operations.pci_enable_dom0_access + ; flags= [] + } + ) + ; ( "pci-disable-dom0-access" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Disable PCI access to dom0." + ; implementation= No_fd Cli_operations.pci_disable_dom0_access + ; flags= [] + } + ) + ; ( "pci-get-dom0-access-status" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Return a PCI device's dom0 access status." + ; implementation= No_fd Cli_operations.get_dom0_access_status + ; flags= [] + } + ) ] let cmdtable : (string, cmd_spec) Hashtbl.t = Hashtbl.create 50 diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index bc0d9ea30bc..3303bd920cb 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -32,26 +32,10 @@ let failwith str = raise (Cli_util.Cli_failure str) exception ExitWithError of int let bool_of_string param string = - let s = String.lowercase_ascii string in - match s with - | "true" -> - true - | "t" -> - true - | "1" -> - true - | "false" -> - false - | "f" -> - false - | "0" -> - false - | _ -> - failwith - ("Failed to parse parameter '" - ^ param - ^ "': expecting 'true' or 'false'" - ) + try Record_util.bool_of_string string + with Record_util.Record_failure msg -> + let msg = Printf.sprintf "Failed to parse parameter '%s': %s" param msg in + raise (Record_util.Record_failure msg) let get_bool_param params ?(default = false) param = List.assoc_opt param params @@ -66,6 +50,24 @@ let get_float_param params param ~default = let get_param params param ~default = Option.value ~default (List.assoc_opt param params) +let get_set_param params ?(default = []) param = + List.assoc_opt param params + |> Option.map (String.split_on_char ',') + |> Option.value ~default + +let get_map_param params ?(default = []) param = + let get_map x = + String.split_on_char ',' x + |> List.filter_map (fun x -> + match String.split_on_char ':' x with + | [k; v] -> + Some (k, v) + | _ -> + None + ) + in + List.assoc_opt param params |> Option.map get_map |> Option.value ~default + (** [get_unique_param param params] is intended to replace [List.assoc_opt] in the cases where a parameter can only exist once, as repeating it might force the CLI to make choices the user didn't foresee. In those cases @@ -1142,7 +1144,7 @@ let gen_cmds rpc session_id = ) ; Client.PGPU.( mk get_all_records_where get_by_uuid pgpu_record "pgpu" [] - ["uuid"; "vendor-name"; "device-name"; "gpu-group-uuid"] + ["uuid"; "pci-uuid"; "vendor-name"; "device-name"; "gpu-group-uuid"] rpc session_id ) ; Client.GPU_group.( @@ -1329,6 +1331,11 @@ let gen_cmds rpc session_id = ] rpc session_id ) + ; Client.PCI.( + mk get_all_records_where get_by_uuid pci_record "pci" [] + ["uuid"; "vendor-name"; "device-name"; "pci-id"] + rpc session_id + ) ] let message_create (_ : printer) rpc session_id params = @@ -1520,16 +1527,15 @@ let pool_management_reconfigure (_ : printer) rpc session_id params = let pool_join printer rpc session_id params = try let force = get_bool_param params "force" in + let master_address = List.assoc "master-address" params in + let master_username = List.assoc "master-username" params in + let master_password = List.assoc "master-password" params in if force then - Client.Pool.join_force ~rpc ~session_id - ~master_address:(List.assoc "master-address" params) - ~master_username:(List.assoc "master-username" params) - ~master_password:(List.assoc "master-password" params) + Client.Pool.join_force ~rpc ~session_id ~master_address ~master_username + ~master_password else - Client.Pool.join ~rpc ~session_id - ~master_address:(List.assoc "master-address" params) - ~master_username:(List.assoc "master-username" params) - ~master_password:(List.assoc "master-password" params) ; + Client.Pool.join ~rpc ~session_id ~master_address ~master_username + ~master_password ; printer (Cli_printer.PList [ @@ -3264,11 +3270,11 @@ let do_vm_op ?(include_control_vms = false) ?(include_template_vms = false) select_vms ~include_control_vms ~include_template_vms rpc session_id params ignore_params in - match List.length vms with - | 0 -> + match vms with + | [] -> failwith "No matching VMs found" - | 1 -> - [op (List.hd vms)] + | [vm] -> + [op vm] | _ -> if multiple && get_bool_param params "multiple" then do_multiple op vms @@ -3310,11 +3316,11 @@ let do_host_op rpc session_id op params ?(multiple = true) ignore_params = let do_sr_op rpc session_id op params ?(multiple = true) ignore_params = let srs = select_srs rpc session_id params ignore_params in - match List.length srs with - | 0 -> + match srs with + | [] -> failwith "No matching hosts found" - | 1 -> - [op (List.hd srs)] + | [sr] -> + [op sr] | _ -> if multiple && get_bool_param params "multiple" then do_multiple op srs @@ -3987,6 +3993,7 @@ let vm_install_real printer rpc session_id template name description params = Client.VM.set_has_vendor_device ~rpc ~session_id ~self:new_vm ~value:want_dev with e when e = licerr -> + (* No longer licensed, this should not happen. CA-371529 *) let msg = Printf.sprintf "Note: the VM template recommends setting has-vendor-device=true \ @@ -5575,12 +5582,7 @@ let vm_import fd _printer rpc session_id params = raise (Cli_util.Cli_failure "No SR specified and Pool default SR is null") in - let _type = - if List.mem_assoc "type" params then - List.assoc "type" params - else - "default" - in + let _type = get_param ~default:"default" params "type" in let full_restore = get_bool_param params "preserve" in let vm_metadata_only = get_bool_param params "metadata" in let force = get_bool_param params "force" in @@ -5806,9 +5808,7 @@ let blob_put fd _printer rpc session_id params = let blob_create printer rpc session_id params = let name = List.assoc "name" params in let mime_type = Listext.assoc_default "mime-type" params "" in - let public = - try bool_of_string "public" (List.assoc "public" params) with _ -> false - in + let public = get_bool_param params "public" in if List.mem_assoc "vm-uuid" params then let uuid = List.assoc "vm-uuid" params in let vm = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in @@ -5860,14 +5860,17 @@ let blob_create printer rpc session_id params = let export_common fd _printer rpc session_id params filename num ?task_uuid compression preserve_power_state vm = - let vm_metadata_only : bool = get_bool_param params "metadata" in - let export_snapshots : bool = - if List.mem_assoc "include-snapshots" params then - bool_of_string "include-snapshots" (List.assoc "include-snapshots" params) + let vm_metadata_only = get_bool_param params "metadata" in + let export_snapshots = get_bool_param params "include-snapshots" in + let uri, extra_args = + if vm_metadata_only then + ( Constants.export_metadata_uri + , Printf.sprintf "&excluded_device_types=%s" + (get_param params ~default:"" "excluded-device-types") + ) else - vm_metadata_only + (Constants.export_uri, "") in - let vm_metadata_only = get_bool_param params "metadata" in let vm_record = vm.record () in let exporttask, task_destroy_fn = match task_uuid with @@ -5884,49 +5887,40 @@ let export_common fd _printer rpc session_id params filename num ?task_uuid (* do not destroy the task that has been received *) (Client.Task.get_by_uuid ~rpc ~session_id ~uuid:task_uuid, fun () -> ()) in - (* Initially mark the task progress as -1.0. The first thing the export handler does it to mark it as zero *) - (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *) - (* not our responsibility any more to mark the task as completed/failed/etc. *) + (* Initially mark the task progress as -1.0. The first thing the export + handler does it to mark it as zero. This is used as a flag to show that + the 'ownership' of the task has been passed to the handler, and it's + not our responsibility any more to mark the task as completed/failed/etc. + *) Client.Task.set_progress ~rpc ~session_id ~self:exporttask ~value:(-1.0) ; finally (fun () -> - let f = if !num > 1 then filename ^ string_of_int !num else filename in + let num = Atomic.fetch_and_add num 1 in + let f = if num > 1 then filename ^ string_of_int num else filename in download_file rpc session_id exporttask fd f (Printf.sprintf - "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b" - ( if vm_metadata_only then - Constants.export_metadata_uri - else - Constants.export_uri - ) - (Ref.string_of session_id) (Ref.string_of exporttask) + "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b%s" + uri (Ref.string_of session_id) (Ref.string_of exporttask) (Ref.string_of (vm.getref ())) Constants.use_compression (Compression_algorithms.to_string compression) - preserve_power_state export_snapshots + preserve_power_state export_snapshots extra_args ) - "Export" ; - num := !num + 1 + "Export" ) (fun () -> task_destroy_fn ()) let get_compression_algorithm params = - if List.mem_assoc "compress" params then - Compression_algorithms.of_string (List.assoc "compress" params) - else - None + Option.bind + (List.assoc_opt "compress" params) + Compression_algorithms.of_string let vm_export fd printer rpc session_id params = let filename = List.assoc "filename" params in let compression = get_compression_algorithm params in let preserve_power_state = get_bool_param params "preserve-power-state" in - let task_uuid = - if List.mem_assoc "task-uuid" params then - Some (List.assoc "task-uuid" params) - else - None - in - let num = ref 1 in + let task_uuid = List.assoc_opt "task-uuid" params in + let num = Atomic.make 1 in let op vm = export_common fd printer rpc session_id params filename num ?task_uuid compression preserve_power_state vm @@ -5939,6 +5933,7 @@ let vm_export fd printer rpc session_id params = ; "compress" ; "preserve-power-state" ; "include-snapshots" + ; "excluded-device-types" ] ) @@ -5946,32 +5941,23 @@ let vm_export_aux obj_type fd printer rpc session_id params = let filename = List.assoc "filename" params in let compression = get_compression_algorithm params in let preserve_power_state = get_bool_param params "preserve-power-state" in - let num = ref 1 in let uuid = List.assoc (obj_type ^ "-uuid") params in - let ref = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in - if - obj_type = "template" - && not (Client.VM.get_is_a_template ~rpc ~session_id ~self:ref) - then - failwith - (Printf.sprintf - "This operation can only be performed on a VM template. %s is not a \ - VM template." - uuid - ) ; - if - obj_type = "snapshot" - && not (Client.VM.get_is_a_snapshot ~rpc ~session_id ~self:ref) - then - failwith - (Printf.sprintf - "This operation can only be performed on a VM snapshot. %s is not a \ - VM snapshot." - uuid - ) ; + let vm = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in + let is_template () = Client.VM.get_is_a_template ~rpc ~session_id ~self:vm in + let is_snapshot () = Client.VM.get_is_a_snapshot ~rpc ~session_id ~self:vm in + let msg () = + Printf.sprintf + "This operation can only be performed on a VM %s. %s is not a VM %s." + obj_type uuid obj_type + in + if obj_type = "template" && not (is_template ()) then + failwith (msg ()) ; + if obj_type = "snapshot" && not (is_snapshot ()) then + failwith (msg ()) ; + let num = Atomic.make 1 in export_common fd printer rpc session_id params filename num compression preserve_power_state - (vm_record rpc session_id ref) + (vm_record rpc session_id vm) let vm_copy_bios_strings printer rpc session_id params = let host = @@ -7349,7 +7335,7 @@ let vmss_create printer rpc session_id params = let schedule = read_map_params "schedule" params in (* optional parameters with default values *) let name_description = get "name-description" ~default:"" in - let enabled = Record_util.bool_of_string (get "enabled" ~default:"true") in + let enabled = get_bool_param ~default:true params "enabled" in let retained_snapshots = Int64.of_string (get "retained-snapshots" ~default:"7") in @@ -7503,13 +7489,13 @@ let pgpu_enable_dom0_access printer rpc session_id params = let uuid = List.assoc "uuid" params in let ref = Client.PGPU.get_by_uuid ~rpc ~session_id ~uuid in let result = Client.PGPU.enable_dom0_access ~rpc ~session_id ~self:ref in - printer (Cli_printer.PMsg (Record_util.pgpu_dom0_access_to_string result)) + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) let pgpu_disable_dom0_access printer rpc session_id params = let uuid = List.assoc "uuid" params in let ref = Client.PGPU.get_by_uuid ~rpc ~session_id ~uuid in let result = Client.PGPU.disable_dom0_access ~rpc ~session_id ~self:ref in - printer (Cli_printer.PMsg (Record_util.pgpu_dom0_access_to_string result)) + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) let lvhd_enable_thin_provisioning _printer rpc session_id params = let sr_uuid = List.assoc "sr-uuid" params in @@ -7533,6 +7519,24 @@ let lvhd_enable_thin_provisioning _printer rpc session_id params = ["sr-uuid"; "initial-allocation"; "allocation-quantum"] ) +let pci_enable_dom0_access printer rpc session_id params = + let uuid = List.assoc "uuid" params in + let ref = Client.PCI.get_by_uuid ~rpc ~session_id ~uuid in + let result = Client.PCI.enable_dom0_access ~rpc ~session_id ~self:ref in + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) + +let pci_disable_dom0_access printer rpc session_id params = + let uuid = List.assoc "uuid" params in + let ref = Client.PCI.get_by_uuid ~rpc ~session_id ~uuid in + let result = Client.PCI.disable_dom0_access ~rpc ~session_id ~self:ref in + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) + +let get_dom0_access_status printer rpc session_id params = + let uuid = List.assoc "uuid" params in + let ref = Client.PCI.get_by_uuid ~rpc ~session_id ~uuid in + let result = Client.PCI.get_dom0_access_status ~rpc ~session_id ~self:ref in + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) + module PVS_site = struct let introduce printer rpc session_id params = let name_label = List.assoc "name-label" params in @@ -7918,13 +7922,7 @@ module VTPM = struct let create printer rpc session_id params = let vm_uuid = List.assoc "vm-uuid" params in let vM = Client.VM.get_by_uuid ~rpc ~session_id ~uuid:vm_uuid in - let is_unique = - match List.assoc_opt "is_unique" params with - | Some value -> - bool_of_string "is_unique" value - | None -> - false - in + let is_unique = get_bool_param params "is_unique" in let ref = Client.VTPM.create ~rpc ~session_id ~vM ~is_unique in let uuid = Client.VTPM.get_uuid ~rpc ~session_id ~self:ref in printer (Cli_printer.PList [uuid]) @@ -7940,33 +7938,12 @@ module Observer = struct let create printer rpc session_id params = let name_label = List.assoc "name-label" params in let hosts = - List.assoc_opt "host-uuids" params - |> Option.fold ~none:[] ~some:(fun host_uuids -> - List.map - (fun uuid -> Client.Host.get_by_uuid ~rpc ~session_id ~uuid) - (String.split_on_char ',' host_uuids) - ) - in - let name_description = - List.assoc_opt "name-description" params |> Option.value ~default:"" - in - let enabled = - List.assoc_opt "enabled" params - |> Option.fold ~none:false ~some:(fun s -> - try Stdlib.bool_of_string s with _ -> false - ) - in - let attributes = - List.assoc_opt "attributes" params - |> Option.fold ~none:[] ~some:(String.split_on_char ',') - |> List.filter_map (fun kv -> - match String.split_on_char ':' kv with - | [k; v] -> - Some (k, v) - | _ -> - None - ) + get_set_param params "host-uuids" + |> List.map (fun uuid -> Client.Host.get_by_uuid ~rpc ~session_id ~uuid) in + let name_description = get_param ~default:"" params "name-description" in + let enabled = get_bool_param params "enabled" in + let attributes = get_map_param params "attributes" in let endpoints = List.assoc_opt "endpoints" params |> Option.fold ~none:[Tracing.bugtool_name] diff --git a/ocaml/xapi-cli-server/cli_util.ml b/ocaml/xapi-cli-server/cli_util.ml index 86e3401b57a..be9ad66839c 100644 --- a/ocaml/xapi-cli-server/cli_util.ml +++ b/ocaml/xapi-cli-server/cli_util.ml @@ -242,6 +242,7 @@ let get_default_sr_uuid rpc session_id = (* Given a string that might be a ref, lookup ref in cache and print uuid/name-label where possible *) let ref_convert x = + let module Ref_index = Xapi_database.Ref_index in match Ref_index.lookup x with | None -> x diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index 6814d74fd56..e10c76ea4c3 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -1,5 +1,6 @@ (library (name xapi_cli_server) + (modes best) (libraries astring base64 diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 5332c2aee16..7c5e93ff222 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -737,7 +737,7 @@ let host_numa_affinity_policy_of_string = function ("Expected 'any', 'best_effort' or 'default_policy', got " ^ s) ) -let pgpu_dom0_access_to_string x = host_display_to_string x +let pci_dom0_access_to_string x = host_display_to_string x let string_to_vdi_onboot s = match String.lowercase_ascii s with @@ -953,12 +953,17 @@ let cluster_host_operation_to_string op = let bool_of_string s = match String.lowercase_ascii s with - | "true" | "yes" -> + | "true" | "t" | "yes" | "y" | "1" -> true - | "false" | "no" -> + | "false" | "f" | "no" | "n" | "0" -> false | _ -> - raise (Record_failure ("Expected 'true','yes','false','no', got " ^ s)) + raise + (Record_failure + ("Expected 'true','t','yes','y','1','false','f','no','n','0' got " + ^ s + ) + ) let sdn_protocol_of_string s = match String.lowercase_ascii s with diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index 6648d755876..516f4c56763 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -139,6 +139,8 @@ let safe_get_field x = | e -> raise e +module Ref_index = Xapi_database.Ref_index + let get_uuid_from_ref r = try match Ref_index.lookup (Ref.string_of r) with @@ -4127,6 +4129,9 @@ let pgpu_record rpc session_id pgpu = ; fields= [ make_field ~name:"uuid" ~get:(fun () -> (x ()).API.pGPU_uuid) () + ; make_field ~name:"pci-uuid" + ~get:(fun () -> try (xp ()).API.pCI_uuid with _ -> nid) + () ; make_field ~name:"vendor-name" ~get:(fun () -> try (xp ()).API.pCI_vendor_name with _ -> nid) () @@ -4135,7 +4140,7 @@ let pgpu_record rpc session_id pgpu = () ; make_field ~name:"dom0-access" ~get:(fun () -> - Record_util.pgpu_dom0_access_to_string (x ()).API.pGPU_dom0_access + Record_util.pci_dom0_access_to_string (x ()).API.pGPU_dom0_access ) () ; make_field ~name:"is-system-display-device" @@ -5500,3 +5505,80 @@ let observer_record rpc session_id observer = () ] } + +let pci_record rpc session_id pci = + let _ref = ref pci in + let empty_record = + ToGet (fun () -> Client.PCI.get_record ~rpc ~session_id ~self:!_ref) + in + let record = ref empty_record in + let x () = lzy_get record in + let pci_record p = + ref (ToGet (fun () -> Client.PCI.get_record ~rpc ~session_id ~self:p)) + in + let xp0 p = lzy_get (pci_record p) in + { + setref= + (fun r -> + _ref := r ; + record := empty_record + ) + ; setrefrec= + (fun (a, b) -> + _ref := a ; + record := Got b + ) + ; record= x + ; getref= (fun () -> !_ref) + ; fields= + [ + make_field ~name:"uuid" ~get:(fun () -> (x ()).API.pCI_uuid) () + ; make_field ~name:"vendor-name" + ~get:(fun () -> try (x ()).API.pCI_vendor_name with _ -> nid) + () + ; make_field ~name:"device-name" + ~get:(fun () -> try (x ()).API.pCI_device_name with _ -> nid) + () + ; make_field ~name:"driver-name" + ~get:(fun () -> try (x ()).API.pCI_driver_name with _ -> nid) + () + ; make_field ~name:"host-uuid" + ~get:(fun () -> + try get_uuid_from_ref (x ()).API.pCI_host with _ -> nid + ) + () + ; make_field ~name:"host-name-label" + ~get:(fun () -> + try get_name_from_ref (x ()).API.pCI_host with _ -> nid + ) + () + ; make_field ~name:"pci-id" + ~get:(fun () -> try (x ()).API.pCI_pci_id with _ -> nid) + () + ; make_field ~name:"dependencies" + ~get:(fun () -> + map_and_concat + (fun pci -> (xp0 pci).API.pCI_pci_id) + (x ()).API.pCI_dependencies + ) + ~get_set:(fun () -> + List.map + (fun pci -> (xp0 pci).API.pCI_pci_id) + (x ()).API.pCI_dependencies + ) + () + ; make_field ~name:"other-config" + ~get:(fun () -> + Record_util.s2sm_to_string "; " (x ()).API.pCI_other_config + ) + ~add_to_map:(fun key value -> + Client.PCI.add_to_other_config ~rpc ~session_id ~self:pci ~key + ~value + ) + ~remove_from_map:(fun key -> + Client.PCI.remove_from_other_config ~rpc ~session_id ~self:pci ~key + ) + ~get_map:(fun () -> (x ()).API.pCI_other_config) + () + ] + } diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 43fff504a3d..dacae2879b6 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1261,8 +1261,6 @@ let invalid_repomd_xml = "INVALID_REPOMD_XML" let get_updates_failed = "GET_UPDATES_FAILED" -let get_updates_in_progress = "GET_UPDATES_IN_PROGRESS" - let apply_updates_in_progress = "APPLY_UPDATES_IN_PROGRESS" let apply_updates_failed = "APPLY_UPDATES_FAILED" diff --git a/ocaml/xapi-guard/lib/disk_cache.ml b/ocaml/xapi-guard/lib/disk_cache.ml index 0f0a6e2c248..5e8b9bb0650 100644 --- a/ocaml/xapi-guard/lib/disk_cache.ml +++ b/ocaml/xapi-guard/lib/disk_cache.ml @@ -62,18 +62,15 @@ let unlink_safe file = type valid_file = t * string -type file = - | Latest of valid_file - | Outdated of valid_file - | Temporary of string - | Invalid of string - -let path_of_key root (uuid, timestamp, key) = - root - // Uuidm.to_string uuid +type file = Latest of valid_file | Outdated of valid_file | Invalid of string + +let print_key (uuid, timestamp, key) = + Uuidm.to_string uuid // Types.Tpm.(serialize_key key |> string_of_int) // Mtime.(to_uint64_ns timestamp |> Int64.to_string) +let path_of_key root key = root // print_key key + let key_of_path path = let ( let* ) = Option.bind in let key_dir = Filename.(dirname path) in @@ -81,7 +78,12 @@ let key_of_path path = let* key = Filename.basename key_dir |> int_of_string_opt - |> Option.map Types.Tpm.deserialize_key + |> Option.map (fun e -> + Types.Tpm.deserialize_key e + |> Result.map_error (fun msg -> D.info "Invalid key found: %s" msg) + |> Result.to_option + ) + |> Option.join in let* timestamp = Filename.basename path @@ -90,24 +92,17 @@ let key_of_path path = in Some ((uuid, timestamp, key), path) -let path_is_temp path = - let pathlen = String.length path in - String.ends_with ~suffix:".pre" path - && key_of_path (String.sub path 0 (pathlen - 4)) |> Option.is_some - -let temp_of_path path = path ^ ".pre" +let only_latest = function + | Latest f -> + Either.Left f + | Outdated (_, p) | Invalid p -> + Right p let sort_updates contents = let classify elem = match key_of_path elem with | None -> - let file = - if path_is_temp elem then - Temporary elem - else - Invalid elem - in - Either.Right file + Either.Right (Invalid elem) | Some valid_file -> Either.Left valid_file in @@ -152,7 +147,7 @@ let read_from ~filename = let persist_to ~filename:f_path ~contents = let atomic_write_to_file ~perm f = - let tmp_path = temp_of_path f_path in + let tmp_path = f_path ^ ".pre" in let dirname = Filename.dirname f_path in let flags = Unix.[O_WRONLY; O_CREAT; O_SYNC] in let* fd_tmp = Lwt_unix.openfile tmp_path flags perm in @@ -285,16 +280,10 @@ end = struct let updates = sort_updates contents in (* 2. Pick latest *) - let only_latest = function - | Latest (_, p) -> - Either.Left p - | Temporary p | Outdated (_, p) | Invalid p -> - Right p - in let latest, _ = List.partition_map only_latest updates in (* 3. fall back to remote read if needed *) - let get_contents path = + let get_contents (_, path) = Lwt.catch (fun () -> read_from ~filename:path) (fun _ -> read_remote ()) in @@ -382,43 +371,38 @@ module Watcher : sig end = struct type push_cache = File of valid_file | Update_all | Wait - (* Outdated and invalid files can be deleted, keep temporary files just in case - they need to be recovered *) - let discarder = function - | Latest _ as f -> - Either.Left f - | Temporary _ as f -> - Left f - | Outdated (_, p) -> - Right p - | Invalid p -> - Right p - let get_latest_and_delete_rest root = let* files = get_all_contents root in - let keep, to_delete = List.partition_map discarder files in + let latest, to_delete = List.partition_map only_latest files in let* () = Lwt_list.iter_p unlink_safe to_delete in - (* Ignore temporaty files *) - let latest = - List.filter_map (function Latest f -> Some f | _ -> None) keep - in Lwt.return latest let retry_push push (uuid, timestamp, key) contents = let __FUN = __FUNCTION__ in let push' () = push (uuid, timestamp, key) contents in - let rec retry k = + let counter = Mtime_clock.counter () in + let rec retry is_first_try = let on_error e = - D.info "%s: Error on push, attempt %i. Reason: %s" __FUN k - (Printexc.to_string e) ; + if is_first_try then + D.debug "%s: Error on push, retrying. Reason: %s" __FUN + (Printexc.to_string e) ; let* () = Lwt_unix.sleep 0.1 in - retry (k + 1) + retry false in Lwt.try_bind push' - (function Ok () -> Lwt.return_unit | Error e -> on_error e) + (function + | Ok () -> Lwt.return (not is_first_try) | Error e -> on_error e + ) on_error in - retry 1 + let* failed = retry true in + ( if failed then + let elapsed = Mtime_clock.count counter in + D.debug "%s: Pushed %s after trying for %s" __FUN + (print_key (uuid, timestamp, key)) + (Fmt.to_to_string Mtime.Span.pp elapsed) + ) ; + Lwt.return_unit let push_file push (key, path) = let __FUN = __FUNCTION__ in @@ -519,30 +503,28 @@ end (** Module use to change the cache contents before the reader and writer start running *) module Setup : sig - val retime_cache_contents : Types.Service.t -> unit Lwt.t + val retime_cache_contents : Types.Service.t -> t List.t Lwt.t + (** [retime_cache_contents typ] retimes the current cache contents so they + are time congruently with the current execution and returns the keys of + valid files that are yet to be pushed *) end = struct type file_action = | Keep of file | Delete of string | Move of {from: string; into: string} - let get_fs_action root now = function + let get_fs_action root now acc = function | Latest ((uuid, timestamp, key), from) as latest -> if Mtime.is_later ~than:now timestamp then let timestamp = now in let into = path_of_key root (uuid, timestamp, key) in - Move {from; into} + ((uuid, timestamp, key) :: acc, Move {from; into}) else - Keep latest - | Temporary _ as temp -> - Keep temp + ((uuid, timestamp, key) :: acc, Keep latest) | Invalid p | Outdated (_, p) -> - Delete p + (acc, Delete p) let commit __FUN = function - | Keep (Temporary p) -> - D.warn "%s: Found temporary file, ignoring '%s'" __FUN p ; - Lwt.return_unit | Keep _ -> Lwt.return_unit | Delete p -> @@ -585,19 +567,31 @@ end = struct let now = Mtime_clock.now () in let root = cache_of typ in let* contents = get_all_contents root in - let* () = - contents - |> List.map (get_fs_action root now) - |> Lwt_list.iter_p (commit __FUNCTION__) + let pending, actions = + contents |> List.fold_left_map (get_fs_action root now) [] in - delete_empty_dirs ~delete_root:false root + let* () = Lwt_list.iter_p (commit __FUNCTION__) actions in + let* () = delete_empty_dirs ~delete_root:false root in + Lwt.return pending end let setup typ read write = - let* () = Setup.retime_cache_contents typ in - let queue, push = Lwt_bounded_stream.create 2 in + let* pending = Setup.retime_cache_contents typ in + let capacity = 512 in + let queue, push = Lwt_bounded_stream.create capacity in let lock = Lwt_mutex.create () in - let q = {queue; push; lock; state= Disengaged} in + let state = + if pending = [] then + Direct + else if List.length pending < capacity then + let () = + List.iter (fun e -> Option.value ~default:() (push (Some e))) pending + in + Engaged + else + Disengaged + in + let q = {queue; push; lock; state} in Lwt.return ( Writer.with_cache ~direct:(read, write) typ q , Watcher.watch ~direct:write typ q diff --git a/ocaml/xapi-guard/lib/server_interface.ml b/ocaml/xapi-guard/lib/server_interface.ml index 0884c2bf1b2..d58a934f5f2 100644 --- a/ocaml/xapi-guard/lib/server_interface.ml +++ b/ocaml/xapi-guard/lib/server_interface.ml @@ -32,7 +32,7 @@ type session = [`session] Ref.t type rpc = call -> response Lwt.t -open Xen_api_lwt_unix +open Xen_api_client_lwt.Xen_api_lwt_unix let shutdown = Lwt_switch.create () @@ -102,10 +102,8 @@ let serve_forever_lwt_callback rpc_fn path _ req body = let with_xapi_vtpm ~cache vm_uuid = let vm_uuid_str = Uuidm.to_string vm_uuid in - let* vm = - with_xapi ~cache @@ Xen_api_lwt_unix.VM.get_by_uuid ~uuid:vm_uuid_str - in - let* vTPMs = with_xapi ~cache @@ Xen_api_lwt_unix.VM.get_VTPMs ~self:vm in + let* vm = with_xapi ~cache @@ VM.get_by_uuid ~uuid:vm_uuid_str in + let* vTPMs = with_xapi ~cache @@ VM.get_VTPMs ~self:vm in match vTPMs with | [] -> D.warn diff --git a/ocaml/xapi-guard/lib/types.ml b/ocaml/xapi-guard/lib/types.ml index 3f2b41c7682..ff6dbc1dd3c 100644 --- a/ocaml/xapi-guard/lib/types.ml +++ b/ocaml/xapi-guard/lib/types.ml @@ -28,13 +28,13 @@ module Tpm = struct let deserialize_key = function | 0 -> - Perm + Ok Perm | 1 -> - Save + Ok Save | 2 -> - Volatile + Ok Volatile | s -> - Fmt.invalid_arg "Unknown TPM state key: %i" s + Error Printf.(sprintf "Unknown TPM state key: %i" s) let empty_state = "" diff --git a/ocaml/xapi-guard/lib/types.mli b/ocaml/xapi-guard/lib/types.mli index f210ea8c96a..06b811ba30c 100644 --- a/ocaml/xapi-guard/lib/types.mli +++ b/ocaml/xapi-guard/lib/types.mli @@ -17,7 +17,7 @@ module Tpm : sig (** [key_of_swtpm path] returns a state key represented by [path]. These paths are parts of the requests generated by SWTPM and may contain slashes *) - val deserialize_key : int -> key + val deserialize_key : int -> (key, string) Result.t val serialize_key : key -> int (** [serialize key] returns the state key represented by [key]. *) diff --git a/ocaml/xapi-guard/src/main.ml b/ocaml/xapi-guard/src/main.ml index 9fb40aa038b..67e0b7f1d0b 100644 --- a/ocaml/xapi-guard/src/main.ml +++ b/ocaml/xapi-guard/src/main.ml @@ -16,7 +16,7 @@ open Lwt.Syntax open Xapi_guard_server module Types = Xapi_guard.Types -module SessionCache = Xen_api_lwt_unix.SessionCache +module SessionCache = Xen_api_client_lwt.Xen_api_lwt_unix.SessionCache let ( let@ ) f x = f x @@ -87,16 +87,15 @@ let safe_unlink path = ) let cache = - Xen_api_lwt_unix.( - SessionCache.create_uri ~switch:Server_interface.shutdown - ~target:uri_local_json ~uname:"root" ~pwd:"" ~version:Xapi_version.version - ~originator:Server_interface.originator () - ) + let target = Xen_api_client_lwt.Xen_api_lwt_unix.uri_local_json in + SessionCache.create_uri ~switch:Server_interface.shutdown ~target + ~uname:"root" ~pwd:"" ~version:Xapi_version.version + ~originator:Server_interface.originator () let () = Lwt_switch.add_hook (Some Server_interface.shutdown) (fun () -> D.debug "Cleaning up cache at exit" ; - Xen_api_lwt_unix.SessionCache.destroy cache + SessionCache.destroy cache ) let listen_for_vm read_write {Persistent.vm_uuid; path; gid; typ} = @@ -214,7 +213,7 @@ let depriv_swtpm_destroy dbg gid path = it's OK to assume it's available. *) let vtpm_set_contents dbg vtpm_uuid contents = - let open Xen_api_lwt_unix in + let open Xen_api_client_lwt.Xen_api_lwt_unix in let open Lwt.Syntax in let uuid = Uuidm.to_string vtpm_uuid in D.debug "[%s] saving vTPM contents for %s" dbg uuid ; @@ -223,7 +222,7 @@ let vtpm_set_contents dbg vtpm_uuid contents = Server_interface.with_xapi ~cache @@ VTPM.set_contents ~self ~contents let vtpm_get_contents _dbg vtpm_uuid = - let open Xen_api_lwt_unix in + let open Xen_api_client_lwt.Xen_api_lwt_unix in let open Lwt.Syntax in let uuid = Uuidm.to_string vtpm_uuid in ret diff --git a/ocaml/xapi-guard/test/cache_test.ml b/ocaml/xapi-guard/test/cache_test.ml index 97b144839a6..3e51cab2c35 100644 --- a/ocaml/xapi-guard/test/cache_test.ml +++ b/ocaml/xapi-guard/test/cache_test.ml @@ -12,7 +12,7 @@ module TPMs = struct let request_persist uuid write = let __FUN = __FUNCTION__ in - let key = Tpm.deserialize_key (Random.int 3) in + let key = Tpm.deserialize_key (Random.int 3) |> Result.get_ok in let time = Mtime_clock.now () in let serial_n = Atomic.fetch_and_add writes_created 1 in @@ -31,7 +31,7 @@ module TPMs = struct let request_read uuid read = let __FUN = __FUNCTION__ in - let key = Tpm.deserialize_key (Random.int 3) in + let key = Tpm.deserialize_key (Random.int 3) |> Result.get_ok in let time = Mtime_clock.now () in let serial_n = Atomic.fetch_and_add reads_created 1 in @@ -200,5 +200,6 @@ let main () = Lwt.return_unit let () = + Debug.log_to_stdout () ; setup_log @@ Some Logs.Debug ; Lwt_main.run (main ()) diff --git a/ocaml/xapi-guard/test/xapi_guard_test.ml b/ocaml/xapi-guard/test/xapi_guard_test.ml index 86efb713d29..b9e6fea2c9b 100644 --- a/ocaml/xapi-guard/test/xapi_guard_test.ml +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -1,8 +1,8 @@ open Xapi_guard_server -module SessionCache = Xen_api_lwt_unix.SessionCache +module SessionCache = Xen_api_client_lwt.Xen_api_lwt_unix.SessionCache open Alcotest_lwt open Lwt.Syntax -open Xen_api_lwt_unix +open Xen_api_client_lwt.Xen_api_lwt_unix module D = Debug.Make (struct let name = "xapi-guard-test" end) @@ -88,7 +88,7 @@ let with_rpc f switch () = (* rpc simulates what varstored would do *) let uri = Uri.make ~scheme:"file" ~path () |> Uri.to_string in D.debug "Connecting to %s" uri ; - let rpc = Xen_api_lwt_unix.make uri in + let rpc = make uri in Lwt.finalize (fun () -> (* not strictly necessary to login/logout here - since we only get dummy sessions *) diff --git a/ocaml/xapi-idl/lib/debuginfo.ml b/ocaml/xapi-idl/lib/debug_info.ml similarity index 100% rename from ocaml/xapi-idl/lib/debuginfo.ml rename to ocaml/xapi-idl/lib/debug_info.ml diff --git a/ocaml/xapi-idl/lib/debuginfo.mli b/ocaml/xapi-idl/lib/debug_info.mli similarity index 100% rename from ocaml/xapi-idl/lib/debuginfo.mli rename to ocaml/xapi-idl/lib/debug_info.mli diff --git a/ocaml/xapi-idl/lib/task_server.ml b/ocaml/xapi-idl/lib/task_server.ml index e963e42687f..a4c675e7d04 100644 --- a/ocaml/xapi-idl/lib/task_server.ml +++ b/ocaml/xapi-idl/lib/task_server.ml @@ -128,16 +128,16 @@ functor (* [add dbg f] creates a fresh [t], registers and returns it *) let add ?traceparent tasks dbg (f : task_handle -> Interface.Task.async_result option) = - let dbg' = Debuginfo.of_string dbg in + let dbg' = Debug_info.of_string dbg in let tracing = - match (dbg'.Debuginfo.tracing, traceparent) with + match (dbg'.Debug_info.tracing, traceparent) with | Some t, _ -> Some t | None, Some traceparent -> let spancontext = Tracing.SpanContext.of_traceparent traceparent in Option.map (fun tp -> - Tracing.Tracer.span_of_span_context tp dbg'.Debuginfo.log + Tracing.Tracer.span_of_span_context tp dbg'.Debug_info.log ) spancontext | _ -> @@ -148,7 +148,7 @@ functor tasks ; id= next_task_id () ; ctime= Unix.gettimeofday () - ; dbg= dbg'.Debuginfo.log + ; dbg= dbg'.Debug_info.log ; tracing ; state= Interface.Task.Pending 0. ; subtasks= [] diff --git a/ocaml/xapi-storage/generator/lib/control.ml b/ocaml/xapi-storage/generator/lib/control.ml index 93b2800a766..f4d8a22a4a5 100644 --- a/ocaml/xapi-storage/generator/lib/control.ml +++ b/ocaml/xapi-storage/generator/lib/control.ml @@ -30,6 +30,12 @@ type health = (** Storage is busy recovering, e.g. rebuilding mirrors *) [@@deriving rpcty] +type volume_type = + | Data (** Normal data volume *) + | CBT_Metadata (** CBT Metadata only, data destroyed *) + | Data_and_CBT_Metadata (** Both Data and CBT Metadata *) +[@@deriving rpcty] + (** Primary key for a specific Storage Repository. This can be any string which is meaningful to the implementation. For example this could be an NFS directory name, an LVM VG name or even a URI. This string is @@ -116,6 +122,11 @@ type volume = { ; keys: (string * string) list (** A list of key=value pairs which have been stored in the Volume metadata. These should not be interpreted by the Volume plugin. *) + ; volume_type: volume_type option [@default Some Data] + (** The content type of this volume *) + ; cbt_enabled: bool option [@default Some false] + (** True means that the storage datapath will track changed dirty blocks + while writing and will be able to provide CBT Metadata when requested *) } [@@deriving rpcty] diff --git a/ocaml/xapi-storage/generator/test/storage_test.ml b/ocaml/xapi-storage/generator/test/storage_test.ml index eca6cf45afb..3da8be64711 100644 --- a/ocaml/xapi-storage/generator/test/storage_test.ml +++ b/ocaml/xapi-storage/generator/test/storage_test.ml @@ -57,6 +57,8 @@ let test_volume = ; physical_utilisation= 0L ; uri= ["uri1"] ; keys= [] + ; cbt_enabled= Some false + ; volume_type= Some Data } (** Check that we successfully parse the responses and diff --git a/ocaml/xapi-storage/rpc-light/SR.ls/response b/ocaml/xapi-storage/rpc-light/SR.ls/response index b85cff59c56..7f989e33066 100644 --- a/ocaml/xapi-storage/rpc-light/SR.ls/response +++ b/ocaml/xapi-storage/rpc-light/SR.ls/response @@ -12,6 +12,8 @@ physical_utilisation0 uriuri1 keys + volume_typeData + cbt_enabledfalse diff --git a/ocaml/xapi-storage/rpc-light/Volume.clone/response b/ocaml/xapi-storage/rpc-light/Volume.clone/response index 4b0f52b2305..dc4036f599d 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.clone/response +++ b/ocaml/xapi-storage/rpc-light/Volume.clone/response @@ -11,6 +11,8 @@ physical_utilisation0 uriuri1 keys + volume_typeData + cbt_enabledfalse diff --git a/ocaml/xapi-storage/rpc-light/Volume.create/response b/ocaml/xapi-storage/rpc-light/Volume.create/response index 4b0f52b2305..dc4036f599d 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.create/response +++ b/ocaml/xapi-storage/rpc-light/Volume.create/response @@ -11,6 +11,8 @@ physical_utilisation0 uriuri1 keys + volume_typeData + cbt_enabledfalse diff --git a/ocaml/xapi-storage/rpc-light/Volume.snapshot/response b/ocaml/xapi-storage/rpc-light/Volume.snapshot/response index 4b0f52b2305..dc4036f599d 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.snapshot/response +++ b/ocaml/xapi-storage/rpc-light/Volume.snapshot/response @@ -11,6 +11,8 @@ physical_utilisation0 uriuri1 keys + volume_typeData + cbt_enabledfalse diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml index 37fafc0905a..d55d7d01c37 100644 --- a/ocaml/xapi-types/features.ml +++ b/ocaml/xapi-types/features.ml @@ -64,6 +64,7 @@ type feature = | Updates | Internal_repo_access | VTPM + | VM_anti_affinity [@@deriving rpc] type orientation = Positive | Negative @@ -132,6 +133,9 @@ let keys_of_features = , ("restrict_internal_repo_access", Negative, "Internal_repo_access") ) ; (VTPM, ("restrict_vtpm", Negative, "VTPM")) + ; ( VM_anti_affinity + , ("restrict_vm_anti_affinity", Negative, "VM_anti_affinity") + ) ] (* A list of features that must be considered "enabled" by `of_assoc_list` diff --git a/ocaml/xapi-types/features.mli b/ocaml/xapi-types/features.mli index c2f1ed2a51b..0696b3ddb5e 100644 --- a/ocaml/xapi-types/features.mli +++ b/ocaml/xapi-types/features.mli @@ -72,6 +72,7 @@ type feature = | Internal_repo_access (** Enable restriction on repository access to pool members only *) | VTPM (** Support VTPM device required by Win11 guests *) + | VM_anti_affinity (** Enable use of VM anti-affinity placement *) val feature_of_rpc : Rpc.t -> feature (** Convert RPC into {!feature}s *) diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index b7209ec323e..a6016b5805b 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -320,7 +320,8 @@ let jsoncallback req bio _ = let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = - Http_svr.read_body ~limit:Db_globs.http_limit_max_rpc_size req bio + Http_svr.read_body ~limit:Xapi_database.Db_globs.http_limit_max_rpc_size req + bio in try let json_rpc_version, id, rpc = diff --git a/ocaml/xapi/cancel_tasks.ml b/ocaml/xapi/cancel_tasks.ml index 3a61fa26bca..690cd1026b1 100644 --- a/ocaml/xapi/cancel_tasks.ml +++ b/ocaml/xapi/cancel_tasks.ml @@ -26,7 +26,7 @@ let safe_wrapper n f x = Debug.log_backtrace e (Backtrace.get e) let update_all_allowed_operations ~__context = - let open Stats in + let time_this = Xapi_database.Stats.time_this in let all_vms = Db.VM.get_all ~__context and all_vbds = Db.VBD.get_all ~__context and all_vifs = Db.VIF.get_all ~__context diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 6b871e686c5..0204b7b064a 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -179,7 +179,7 @@ end = struct let get_ca_certs ~__context name = let expr = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let type' = Eq (Field "type", Literal "ca") in let name' = Eq (Field "name", Literal name) in And (type', name') @@ -187,7 +187,7 @@ end = struct Db.Certificate.get_refs_where ~__context ~expr let get_host_certs ~__context ~type' ~host = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let type' = Eq (Field "type", Literal (Record_util.certificate_type_to_string type')) in @@ -251,7 +251,7 @@ end = struct let get_ca_certs ~__context = let expr = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in Eq (Field "type", Literal "ca") in Db.Certificate.get_refs_where ~__context ~expr diff --git a/ocaml/xapi/cluster_stack_constraints.ml b/ocaml/xapi/cluster_stack_constraints.ml index d6689085173..8efa8bc4cab 100644 --- a/ocaml/xapi/cluster_stack_constraints.ml +++ b/ocaml/xapi/cluster_stack_constraints.ml @@ -1,4 +1,4 @@ -open Db_filter_types +open Xapi_database.Db_filter_types module Listext = Xapi_stdext_std.Listext.List module D = Debug.Make (struct let name = "cluster_stack_constraints" end) diff --git a/ocaml/xapi/console.ml b/ocaml/xapi/console.ml index f682289163d..03cb4bf9559 100644 --- a/ocaml/xapi/console.ml +++ b/ocaml/xapi/console.ml @@ -184,7 +184,9 @@ let console_of_request __context req = go for that. *) let db = Context.database_of __context in let is_vm, _ = - let module DB = (val Db_cache.get db : Db_interface.DB_ACCESS) in + let module DB = + (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS) + in match DB.get_table_from_ref db _ref with | Some c when c = Db_names.vm -> (true, false) diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index 4179cf7d930..080bab8fcad 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -42,7 +42,7 @@ type t = { ; task_id: API.ref_task ; forwarded_task: bool ; origin: origin - ; database: Db_ref.t + ; database: Xapi_database.Db_ref.t ; dbg: string ; mutable tracing: Tracing.Span.t option ; client: Http_svr.client option @@ -99,9 +99,9 @@ let is_unix_socket s = let default_database () = if Pool_role.is_master () then - Db_backend.make () + Xapi_database.Db_backend.make () else - Db_ref.Remote + Xapi_database.Db_ref.Remote let preauth ~__context = match __context.origin with @@ -154,17 +154,19 @@ let __destroy_task : (__context:t -> API.ref_task -> unit) ref = let string_of_task __context = __context.dbg let string_of_task_and_tracing __context = - Debuginfo.make ~log:__context.dbg ~tracing:__context.tracing - |> Debuginfo.to_string + Debug_info.make ~log:__context.dbg ~tracing:__context.tracing + |> Debug_info.to_string let tracing_of_dbg s = - let dbg = Debuginfo.of_string s in + let dbg = Debug_info.of_string s in (dbg.log, dbg.tracing) let check_for_foreign_database ~__context = match __context.session_id with | Some sid -> ( - match Db_backend.get_registered_database (Ref.string_of sid) with + match + Xapi_database.Db_backend.get_registered_database (Ref.string_of sid) + with | Some database -> {__context with database} | None -> @@ -227,8 +229,64 @@ let parent_of_origin (origin : origin) span_name = | _ -> None +let attribute_helper_fn f v = Option.fold ~none:[] ~some:f v + +let addr_port_of_sock s = + match s with + | None -> + (None, None) + | Some (Unix.ADDR_UNIX "") -> + (None, None) + | Some (Unix.ADDR_UNIX socket_name) -> + (Some socket_name, None) + | Some (Unix.ADDR_INET (addr, port)) -> + (Some (Unix.string_of_inet_addr addr), Some (string_of_int port)) + +let with_try_get_addr f s = + (try Some (f s) with Unix.Unix_error (Unix.ENOTSOCK, _, _) -> None) + |> addr_port_of_sock + +let attr_of_fd s = + let peer_addr, peer_port = s |> with_try_get_addr Unix.getpeername in + let local_addr, local_port = s |> with_try_get_addr Unix.getsockname in + [ + attribute_helper_fn + (fun addr -> [("network.local.address", addr)]) + local_addr + ; attribute_helper_fn (fun port -> [("network.local.port", port)]) local_port + ; attribute_helper_fn (fun addr -> [("network.peer.address", addr)]) peer_addr + ; attribute_helper_fn (fun port -> [("network.peer.port", port)]) peer_port + ] + |> List.concat + +let attr_of_req (req : Http.Request.t) = + [ + [ + ("xs.xapi.task.origin", "http") + ; ("http.request.header.method", Http.string_of_method_t req.m) + ] + ; attribute_helper_fn + (fun user_agent -> [("http.request.header.user-agent", user_agent)]) + req.user_agent + ; attribute_helper_fn + (fun content_type -> [("http.request.header.content-type", content_type)]) + req.content_type + ; attribute_helper_fn + (fun content_length -> + [("http.request.body.size", Printf.sprintf "%Li" content_length)] + ) + req.content_length + ; List.map + (fun (h, v) -> + ( h |> String.lowercase_ascii |> Printf.sprintf "http.request.header.%s" + , v + ) + ) + req.additional_headers + ] + |> List.concat + let make_attributes ?task_name ?task_id ?task_uuid ?session_id ?origin () = - let attribute_helper_fn f v = Option.fold ~none:[] ~some:f v in [ attribute_helper_fn (fun task_name -> [("xs.xapi.task.name", task_name)]) @@ -249,8 +307,8 @@ let make_attributes ?task_name ?task_id ?task_uuid ?session_id ?origin () = match origin with | Internal -> [("xs.xapi.task.origin", "internal")] - | Http _ -> - [("xs.xapi.task.origin", "http")] + | Http (req, s) -> + [attr_of_req req; attr_of_fd s] |> List.concat ) origin ] diff --git a/ocaml/xapi/context.mli b/ocaml/xapi/context.mli index 7b2ece18c2c..07e5cb6ea29 100644 --- a/ocaml/xapi/context.mli +++ b/ocaml/xapi/context.mli @@ -25,7 +25,7 @@ val make : -> ?quiet:bool -> ?subtask_of:API.ref_task -> ?session_id:API.ref_session - -> ?database:Db_ref.t + -> ?database:Xapi_database.Db_ref.t -> ?task_in_database:bool -> ?task_description:string -> ?origin:origin @@ -87,7 +87,7 @@ val task_in_database : t -> bool val get_origin : t -> string (** [get_origin __context] returns a string containing the origin of [__context]. *) -val database_of : t -> Db_ref.t +val database_of : t -> Xapi_database.Db_ref.t (** [database_of __context] returns a database handle, which can be used by Db.* *) (** {6 Destructors} *) diff --git a/ocaml/xapi/create_misc.ml b/ocaml/xapi/create_misc.ml index 7a2630ea57f..546b3cc24d1 100644 --- a/ocaml/xapi/create_misc.ml +++ b/ocaml/xapi/create_misc.ml @@ -20,7 +20,7 @@ module Unixext = Xapi_stdext_unix.Unixext module Date = Xapi_stdext_date.Date open Xapi_vm_memory_constraints open Vm_memory_constraints -open Db_filter_types +open Xapi_database.Db_filter_types open Network module XenAPI = Client.Client diff --git a/ocaml/xapi/db.ml b/ocaml/xapi/db.ml index 0ceecb1d459..4b4b6c2deea 100644 --- a/ocaml/xapi/db.ml +++ b/ocaml/xapi/db.ml @@ -16,6 +16,7 @@ *) include Db_actions.DB_Action +open Xapi_database let is_valid_ref __context r = if r = Ref.null then diff --git a/ocaml/xapi/db_gc.ml b/ocaml/xapi/db_gc.ml index e0d79a5bc8e..c7fb5d93373 100644 --- a/ocaml/xapi/db_gc.ml +++ b/ocaml/xapi/db_gc.ml @@ -270,10 +270,10 @@ let tickle_heartbeat ~__context host stuff = let single_pass () = Server_helpers.exec_with_new_task "DB GC" (fun __context -> - Db_lock.with_lock (fun () -> + Xapi_database.Db_lock.with_lock (fun () -> let time_one (name, f) = - Stats.time_this (Printf.sprintf "Db_gc: %s" name) (fun () -> - f ~__context + Xapi_database.Stats.time_this (Printf.sprintf "Db_gc: %s" name) + (fun () -> f ~__context ) in List.iter time_one Db_gc_util.gc_subtask_list diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index 3a9d8f74856..eb86d981291 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -27,7 +27,9 @@ let valid_ref x = Db.is_valid_ref x 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 Db_cache.get db : Db_interface.DB_ACCESS) in + let module DB = + (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS) + in let all_refs = get_all ~__context in let do_gc ref = let print_valid b = if b then "valid" else "INVALID" in @@ -188,7 +190,7 @@ let gc_PGPUs ~__context = let gc_VGPU_types ~__context = (* We delete a VGPU_type iff it does not appear in the supported_VGPU_types of any PGPU _and_ there doesn't exist a VGPU with this VGPU_type *) - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let garbage = Db.VGPU_type.get_records_where ~__context ~expr: @@ -272,7 +274,8 @@ let probation_pending_tasks = Hashtbl.create 53 let timeout_tasks ~__context = let all_tasks = - Db.Task.get_internal_records_where ~__context ~expr:Db_filter_types.True + Db.Task.get_internal_records_where ~__context + ~expr:Xapi_database.Db_filter_types.True in let oldest_completed_time = Unix.time () -. !Xapi_globs.completed_task_timeout @@ -474,7 +477,8 @@ let last_session_log_time = ref None let timeout_sessions ~__context = let all_sessions = - Db.Session.get_internal_records_where ~__context ~expr:Db_filter_types.True + Db.Session.get_internal_records_where ~__context + ~expr:Xapi_database.Db_filter_types.True in let pool_sessions, nonpool_sessions = List.partition (fun (_, s) -> s.Db_actions.session_pool) all_sessions diff --git a/ocaml/xapi/dbsync_master.ml b/ocaml/xapi/dbsync_master.ml index 5d657d2cb09..5cdc4b9106e 100644 --- a/ocaml/xapi/dbsync_master.ml +++ b/ocaml/xapi/dbsync_master.ml @@ -156,12 +156,20 @@ let release_locks ~__context = Xapi_vm_lifecycle.force_state_reset ~__context ~self ~value:`Halted ) vms ; - (* All VMs should have their scheduled_to_be_resident_on field cleared *) - List.iter - (fun self -> - Db.VM.set_scheduled_to_be_resident_on ~__context ~self ~value:Ref.null - ) - (Db.VM.get_all ~__context) + (* Clear all assignments that are only scheduled *) + let value = Ref.null in + Db.VM.get_all ~__context + |> List.iter (fun self -> + Db.VM.set_scheduled_to_be_resident_on ~__context ~self ~value + ) ; + Db.PCI.get_all ~__context + |> List.iter (fun self -> + Db.PCI.set_scheduled_to_be_attached_to ~__context ~self ~value + ) ; + Db.VGPU.get_all ~__context + |> List.iter (fun self -> + Db.VGPU.set_scheduled_to_be_resident_on ~__context ~self ~value + ) let create_tools_sr __context name_label name_description sr_introduce maybe_create_pbd = diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 45d5e67aaf9..6575b66aea5 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -57,6 +57,7 @@ (library (name xapi_internal) (wrapped false) + (modes best) (modules (:standard \ xapi_main)) (libraries angstrom @@ -73,6 +74,7 @@ hex http_lib ipaddr + magic-mime message-switch-core message-switch-unix mirage-crypto diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index a3ef6e60608..274e74abb78 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -92,8 +92,8 @@ let events_of_other_tbl_refs other_tbl_refs = other_tbl_refs ) -open Db_cache_types -open Db_action_helper +open Xapi_database.Db_cache_types +open Xapi_database.Db_action_helper let database_callback_inner event db context = let other_tbl_refs tblname = follow_references tblname in diff --git a/ocaml/xapi/exnHelper.ml b/ocaml/xapi/exnHelper.ml index 84dbf269bfc..af5458e7839 100644 --- a/ocaml/xapi/exnHelper.ml +++ b/ocaml/xapi/exnHelper.ml @@ -68,7 +68,7 @@ let error_of_exn e = ) | Invalid_argument x -> (internal_error, [Printf.sprintf "Invalid argument: %s" x]) - | Db_filter.Expression_error (expr, exc) -> + | Xapi_database.Db_filter.Expression_error (expr, exc) -> (invalid_value, [expr; Printexc.to_string exc]) | Forkhelpers.Subprocess_failed n -> ( internal_error diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 49ccc7b0c57..c549fb74295 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -52,7 +52,7 @@ let make_id = "Ref:" ^ string_of_int this let rec update_table ~__context ~include_snapshots ~preserve_power_state - ~include_vhd_parents ~table vm = + ~include_vhd_parents ~table ~excluded_devices vm = let add r = if not (Hashtbl.mem table (Ref.string_of r)) then Hashtbl.add table (Ref.string_of r) (make_id ()) @@ -77,38 +77,40 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state then ( add vm ; let vm = Db.VM.get_record ~__context ~self:vm in - List.iter - (fun vif -> - if Db.is_valid_ref __context vif then ( - add vif ; - let vif = Db.VIF.get_record ~__context ~self:vif in - add vif.API.vIF_network + if not (List.mem Devicetype.VIF excluded_devices) then + List.iter + (fun vif -> + if Db.is_valid_ref __context vif then ( + add vif ; + let vif = Db.VIF.get_record ~__context ~self:vif in + add vif.API.vIF_network + ) ) - ) - vm.API.vM_VIFs ; - List.iter - (fun vbd -> - if Db.is_valid_ref __context vbd then ( - add vbd ; - let vbd = Db.VBD.get_record ~__context ~self:vbd in - if not vbd.API.vBD_empty then - add_vdi vbd.API.vBD_VDI + vm.API.vM_VIFs ; + if not (List.mem Devicetype.VBD excluded_devices) then + List.iter + (fun vbd -> + if Db.is_valid_ref __context vbd then ( + add vbd ; + let vbd = Db.VBD.get_record ~__context ~self:vbd in + if not vbd.API.vBD_empty then + add_vdi vbd.API.vBD_VDI + ) ) - ) - vm.API.vM_VBDs ; - List.iter - (fun vgpu -> - if Db.is_valid_ref __context vgpu then ( - add vgpu ; - let vgpu = Db.VGPU.get_record ~__context ~self:vgpu in - add vgpu.API.vGPU_type ; - add vgpu.API.vGPU_GPU_group + vm.API.vM_VBDs ; + if not (List.mem Devicetype.VGPU excluded_devices) then + List.iter + (fun vgpu -> + if Db.is_valid_ref __context vgpu then ( + add vgpu ; + let vgpu = Db.VGPU.get_record ~__context ~self:vgpu in + add vgpu.API.vGPU_type ; + add vgpu.API.vGPU_GPU_group + ) ) - ) - vm.API.vM_VGPUs ; + vm.API.vM_VGPUs ; (* add all PVS proxies that have a VIF belonging to this VM, add their - * PVS sites as well - *) + PVS sites as well *) Db.PVS_proxy.get_all_records ~__context |> List.filter (fun (_, p) -> List.mem p.API.pVS_proxy_VIF vm.API.vM_VIFs) |> List.iter (fun (ref, proxy) -> @@ -118,15 +120,16 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state ) ) ; (* add VTPMs that belong to this VM *) - vm.API.vM_VTPMs - |> List.iter (fun ref -> if Db.is_valid_ref __context ref then add ref) ; + if not (List.mem Devicetype.VTPM excluded_devices) then + vm.API.vM_VTPMs + |> List.iter (fun ref -> if Db.is_valid_ref __context ref then add ref) ; (* If we need to include snapshots, update the table for VMs in the 'snapshots' field *) if include_snapshots then List.iter (fun snap -> update_table ~__context ~include_snapshots:false ~preserve_power_state - ~include_vhd_parents ~table snap + ~include_vhd_parents ~table ~excluded_devices snap ) vm.API.vM_snapshots ; (* If VM is suspended then add the suspend_VDI *) @@ -145,7 +148,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state (* Add the parent VM *) if include_snapshots && Db.is_valid_ref __context vm.API.vM_parent then update_table ~__context ~include_snapshots:false ~preserve_power_state - ~include_vhd_parents ~table vm.API.vM_parent + ~include_vhd_parents ~table ~excluded_devices vm.API.vM_parent ) (** Walk the graph of objects and update the table of Ref -> ids for each object we wish @@ -580,11 +583,11 @@ let make_all ~with_snapshot_metadata ~preserve_power_state table __context = on metadata-export, include snapshots fields of the exported VM as well as the VM records of VMs which are snapshots of the exported VM. *) let vm_metadata ~with_snapshot_metadata ~preserve_power_state - ~include_vhd_parents ~__context ~vms = + ~include_vhd_parents ~__context ~vms ~excluded_devices = let table = create_table () in List.iter (update_table ~__context ~include_snapshots:with_snapshot_metadata - ~preserve_power_state ~include_vhd_parents ~table + ~preserve_power_state ~include_vhd_parents ~table ~excluded_devices ) vms ; let objects = @@ -603,31 +606,31 @@ let string_of_vm ~__context vm = (** Export a VM's metadata only *) let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state - ~include_vhd_parents ~vms s = + ~include_vhd_parents ~vms ~excluded_devices s = + let infomsg vm = + info + "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \ + include_vhd_parents = '%b'; preserve_power_state = '%s'; \ + excluded_devices = '%s'" + vm with_snapshot_metadata include_vhd_parents + (string_of_bool preserve_power_state) + (String.concat ", " (List.map Devicetype.to_string excluded_devices)) + in + let now = Date.now () |> Date.to_unix_time |> Int64.of_float in ( match vms with | [] -> failwith "need to specify at least one VM" | [vm] -> - info - "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \ - include_vhd_parents = '%b'; preserve_power_state = '%s" - (string_of_vm ~__context vm) - with_snapshot_metadata include_vhd_parents - (string_of_bool preserve_power_state) + infomsg (string_of_vm ~__context vm) | vms -> - info - "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \ - preserve_power_state = '%s" - (String.concat ", " (List.map (string_of_vm ~__context) vms)) - with_snapshot_metadata - (string_of_bool preserve_power_state) + infomsg (String.concat ", " (List.map (string_of_vm ~__context) vms)) ) ; let _, ova_xml = vm_metadata ~with_snapshot_metadata ~preserve_power_state - ~include_vhd_parents ~__context ~vms + ~include_vhd_parents ~__context ~vms ~excluded_devices in let hdr = - Tar.Header.make Xapi_globs.ova_xml_filename + Tar.Header.make ~mod_time:now Xapi_globs.ova_xml_filename (Int64.of_int @@ String.length ova_xml) in Tar_helpers.write_block hdr (fun s -> Unixext.really_write_string s ova_xml) s ; @@ -635,16 +638,17 @@ let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state let export refresh_session __context rpc session_id s vm_ref preserve_power_state = + let now = Date.now () |> Date.to_unix_time |> Int64.of_float in info "VM.export: VM = %s; preserve_power_state = '%s'" (string_of_vm ~__context vm_ref) (string_of_bool preserve_power_state) ; let table, ova_xml = vm_metadata ~with_snapshot_metadata:false ~preserve_power_state - ~include_vhd_parents:false ~__context ~vms:[vm_ref] + ~include_vhd_parents:false ~__context ~vms:[vm_ref] ~excluded_devices:[] in debug "Outputting ova.xml" ; let hdr = - Tar.Header.make Xapi_globs.ova_xml_filename + Tar.Header.make ~mod_time:now Xapi_globs.ova_xml_filename (Int64.of_int @@ String.length ova_xml) in Tar_helpers.write_block hdr (fun s -> Unixext.really_write_string s ova_xml) s ; @@ -716,35 +720,43 @@ let vm_from_request ~__context (req : Request.t) = Client.VM.get_by_uuid ~rpc ~session_id ~uuid ) -let bool_from_request ~__context (req : Request.t) default k = - if List.mem_assoc k req.Request.query then - bool_of_string (List.assoc k req.Request.query) - else - default +let arg_from_request (req : Request.t) k = List.assoc_opt k req.Request.query -let export_all_vms_from_request ~__context (req : Request.t) = - bool_from_request ~__context req false "all" +let bool_from_request req default k = + arg_from_request req k |> Option.fold ~none:default ~some:bool_of_string + +let devicetypelist_from_request req default k = + let to_list = function + | "" -> + [] + | x -> + String.split_on_char ',' x |> List.map Devicetype.of_string + in + arg_from_request req k |> Option.fold ~none:default ~some:to_list -let include_vhd_parents_from_request ~__context (req : Request.t) = - bool_from_request ~__context req false "include_vhd_parents" +let export_all_vms_from_request req = bool_from_request req false "all" -let export_snapshots_from_request ~__context (req : Request.t) = - bool_from_request ~__context req true "export_snapshots" +let include_vhd_parents_from_request req = + bool_from_request req false "include_vhd_parents" -let include_dom0_from_request ~__context (req : Request.t) = - bool_from_request ~__context req true "include_dom0" +let export_snapshots_from_request req = + bool_from_request req true "export_snapshots" + +let include_dom0_from_request req = bool_from_request req true "include_dom0" + +let excluded_devices_from_request req = + devicetypelist_from_request req [] "excluded_device_types" let metadata_handler (req : Request.t) s _ = debug "metadata_handler called" ; req.Request.close <- true ; (* Xapi_http.with_context always completes the task at the end *) Xapi_http.with_context "VM.export_metadata" req s (fun __context -> - let include_vhd_parents = - include_vhd_parents_from_request ~__context req - in - let export_all = export_all_vms_from_request ~__context req in - let export_snapshots = export_snapshots_from_request ~__context req in - let include_dom0 = include_dom0_from_request ~__context req in + let include_vhd_parents = include_vhd_parents_from_request req in + let export_all = export_all_vms_from_request req in + let export_snapshots = export_snapshots_from_request req in + let include_dom0 = include_dom0_from_request req in + let excluded_devices = excluded_devices_from_request req in (* Get the VM refs. In case of exporting the metadata of a particular VM, return a singleton list containing the vm ref. *) (* In case of exporting all the VMs metadata, get all the VM records which are not default templates. *) let vm_refs = @@ -771,16 +783,6 @@ let metadata_handler (req : Request.t) s _ = else [vm_from_request ~__context req] in - if - (not export_all) - && Db.VM.get_is_a_snapshot ~__context ~self:(List.hd vm_refs) - then - raise - (Api_errors.Server_error - ( Api_errors.operation_not_allowed - , ["Exporting metadata of a snapshot is not allowed"] - ) - ) ; let task_id = Ref.string_of (Context.get_task_id __context) in let read_fd, write_fd = Unix.pipe () in let export_error = ref None in @@ -800,7 +802,7 @@ let metadata_handler (req : Request.t) s _ = vm_refs ; export_metadata ~with_snapshot_metadata:export_snapshots ~preserve_power_state:true ~include_vhd_parents - ~__context ~vms:vm_refs write_fd + ~excluded_devices ~__context ~vms:vm_refs write_fd ) (fun () -> Unix.close write_fd ; diff --git a/ocaml/xapi/fileserver.ml b/ocaml/xapi/fileserver.ml index 1c4cf9520e3..ed9ed334d66 100644 --- a/ocaml/xapi/fileserver.ml +++ b/ocaml/xapi/fileserver.ml @@ -42,40 +42,8 @@ let missing uri = ^ " was not found on this server.

Xapi \ Server
" -let get_extension filename = - try - let basename = Filename.basename filename in - let i = String.rindex basename '.' in - Some (String.sub basename (i + 1) (String.length basename - i - 1)) - with _ -> None - -let application_octet_stream = "application/octet-stream" - -let mime_of_extension = function - | "html" | "htm" -> - "text/html" - | "css" -> - "text/css" - | "js" -> - "application/javascript" - | "gif" -> - "image/gif" - | "png" -> - "image/png" - | "jpg" | "jpeg" -> - "image/jpeg" - | "xml" -> - "application/xml" - | "rpm" -> - "application/x-rpm" - | _ -> - application_octet_stream - let response_file s file_path = - let mime_content_type = - let ext = Option.map String.lowercase_ascii (get_extension file_path) in - Option.fold ~none:application_octet_stream ~some:mime_of_extension ext - in + let mime_content_type = Magic_mime.lookup file_path in let hsts_time = !Xapi_globs.hsts_max_age in Http_svr.response_file ~mime_content_type ~hsts_time s file_path diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index bed75da7b0a..d8366e00a9a 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -23,7 +23,7 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute open Xapi_globs -open Db_filter_types +open Xapi_database.Db_filter_types include Helper_process open Network @@ -1292,7 +1292,9 @@ let vm_to_string __context vm = if not (Db.is_valid_ref __context vm) then raise (Api_errors.Server_error (Api_errors.invalid_value, [str])) ; let t = Context.database_of __context in - let module DB = (val Db_cache.get t : Db_interface.DB_ACCESS) in + let module DB = + (val Xapi_database.Db_cache.get t : Xapi_database.Db_interface.DB_ACCESS) + in let fields = fst (DB.read_record t Db_names.vm str) in let sexpr = SExpr.Node @@ -1966,7 +1968,7 @@ end = struct in Xapi_globs.pool_secrets := [ps] ; Db_globs.pool_secret := - ps |> SecretString.rpc_of_t |> Db_secret_string.t_of_rpc ; + ps |> SecretString.rpc_of_t |> Xapi_database.Db_secret_string.t_of_rpc ; SecretString.write_to_file !Xapi_globs.pool_secret_path ps ; Xapi_psr_util.load_psr_pool_secrets () end diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index fd6d898b1e0..372cdb7fa20 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -287,7 +287,7 @@ let assert_can_live_import_vgpu ~__context vgpu_record = let local_pgpus = Db.PGPU.get_refs_where ~__context ~expr: - Db_filter_types.( + Xapi_database.Db_filter_types.( And ( Eq ( Field "GPU_group" @@ -629,17 +629,15 @@ module VM : HandlerTools = struct ~domain_type:vm_record.API.vM_domain_type ~is_a_template:vm_record.API.vM_is_a_template vm_record.API.vM_platform + ; API.vM_suspend_VDI= Ref.null + ; API.vM_power_state= `Halted } in let vm = log_reraise ("failed to create VM with name-label " ^ vm_record.API.vM_name_label) (fun value -> - let vm = - Xapi_vm_helpers - .create_from_record_without_checking_licence_feature_for_vendor_device - ~__context rpc session_id value - in + let vm = Client.VM.create_from_record ~rpc ~session_id ~value in if config.full_restore then Db.VM.set_uuid ~__context ~self:vm ~value:value.API.vM_uuid ; vm @@ -2158,11 +2156,18 @@ let complete_import ~__context vmrefs = Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm ) vmrefs ; - (* We only keep VMs which are not snapshot *) + (* When only snapshots have been imported, return all of them. + Otherwise, only keep VMs which are not snapshots *) let vmrefs = - List.filter - (fun vmref -> not (Db.VM.get_is_a_snapshot ~__context ~self:vmref)) + let non_snapshots = + List.filter + (fun x -> not (Db.VM.get_is_a_snapshot ~__context ~self:x)) + vmrefs + in + if non_snapshots = [] then vmrefs + else + non_snapshots in (* We only set the result on the task since it is officially completed later. *) TaskHelper.set_result ~__context (Some (API.rpc_of_ref_VM_set vmrefs)) diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index a7354fce45e..f90a8da80ea 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -469,6 +469,37 @@ module Format = struct (* default *) end +module Devicetype = struct + type t = VIF | VBD | VGPU | VTPM + + let all = [VIF; VBD; VGPU; VTPM] + + let to_string = function + | VIF -> + "vif" + | VBD -> + "vbd" + | VGPU -> + "vgpu" + | VTPM -> + "vtpm" + + let of_string x = + match String.lowercase_ascii x with + | "vif" -> + VIF + | "vbd" -> + VBD + | "vgpu" -> + VGPU + | "vtpm" -> + VTPM + | other -> + let fail fmt = Printf.kprintf failwith fmt in + fail "%s: Type '%s' not one of [%s]" __FUNCTION__ other + (String.concat "; " (List.map to_string all)) +end + let return_302_redirect (req : Http.Request.t) s address = let address = Http.Url.maybe_wrap_IPv6_literal address in let url = diff --git a/ocaml/xapi/livepatch.ml b/ocaml/xapi/livepatch.ml index 0dc3869338e..63afa9a2c82 100644 --- a/ocaml/xapi/livepatch.ml +++ b/ocaml/xapi/livepatch.ml @@ -187,29 +187,34 @@ module KernelLivePatch = struct end module XenLivePatch = struct - let get_regexp status = - Re.Posix.compile_pat - (Printf.sprintf {|^[ ]*lp_([^- ]+)-([^- ]+)-([^- ]+)-([^- ]+).+%s.*$|} - status - ) + let drop x = Astring.Char.Ascii.(is_control x || is_white x) - let get_livepatches pattern s = + let get_livepatches state s = + let pattern = + Re.Posix.compile_pat {|^lp_([^- ]+)-([^- ]+)-([^- ]+)-([^- ]+)$|} + in Astring.String.cuts ~sep:"\n" s |> List.filter_map (fun line -> - match Re.exec_opt pattern line with - | Some groups -> - let base_version = Re.Group.get groups 1 in - let base_release = Re.Group.get groups 2 in - let to_version = Re.Group.get groups 3 in - let to_release = Re.Group.get groups 4 in - Some (base_version, base_release, to_version, to_release) - | None -> + Astring.String.cuts ~sep:"|" line + |> List.map (Astring.String.trim ~drop) + |> function + | name :: state' :: _ when state' = state -> ( + match Re.exec_opt pattern name with + | Some groups -> + let base_version = Re.Group.get groups 1 in + let base_release = Re.Group.get groups 2 in + let to_version = Re.Group.get groups 3 in + let to_release = Re.Group.get groups 4 in + Some (base_version, base_release, to_version, to_release) + | None -> + None + ) + | _ -> None ) let get_running_livepatch' s = - let r = get_regexp "APPLIED" in - get_livepatches r s |> get_latest_livepatch + get_livepatches "APPLIED" s |> get_latest_livepatch let get_running_livepatch () = Helpers.call_script !Xapi_globs.xen_livepatch_cmd ["list"] @@ -217,13 +222,9 @@ module XenLivePatch = struct let get_checked_livepatches () = Helpers.call_script !Xapi_globs.xen_livepatch_cmd ["list"] - |> get_livepatches (get_regexp "CHECKED") + |> get_livepatches "CHECKED" let get_base_build_id () = - let drop x = - let open Astring.Char.Ascii in - is_control x || is_blank x || is_white x - in Helpers.call_script !Xapi_globs.xl_cmd ["info"; "build_id"] |> Astring.String.trim ~drop |> function diff --git a/ocaml/xapi/memory_check.ml b/ocaml/xapi/memory_check.ml index 51bc945904a..4d537aec2ca 100644 --- a/ocaml/xapi/memory_check.ml +++ b/ocaml/xapi/memory_check.ml @@ -128,7 +128,7 @@ type host_memory_summary = { (** list of VMs which are in the process of having a domain created here *) } -open Db_filter_types +open Xapi_database.Db_filter_types (** Return a host's memory summary from live database contents. *) let get_host_memory_summary ~__context ~host = diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index b2eb86c805d..d55d3ee0ed2 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -1346,18 +1346,8 @@ functor else local_fn ~__context - (* Clear scheduled_to_be_resident_on for a VM and all its vGPUs. *) - let clear_scheduled_to_be_resident_on ~__context ~vm = - Db.VM.set_scheduled_to_be_resident_on ~__context ~self:vm - ~value:Ref.null ; - List.iter - (fun vgpu -> - Db.VGPU.set_scheduled_to_be_resident_on ~__context ~self:vgpu - ~value:Ref.null - ) - (Db.VM.get_VGPUs ~__context ~self:vm) - - let clear_reserved_netsriov_vfs_on ~__context ~vm = + let clear_vif_reservations ~__context ~vm = + debug "%s VM=%s" __FUNCTION__ (Ref.string_of vm) ; Db.VM.get_VIFs ~__context ~self:vm |> List.iter (fun vif -> let vf = Db.VIF.get_reserved_pci ~__context ~self:vif in @@ -1367,6 +1357,32 @@ functor ~value:Ref.null ) + let clear_reservations ~__context ~vm = + debug "%s VM=%s" __FUNCTION__ (Ref.string_of vm) ; + (* host *) + Db.VM.set_scheduled_to_be_resident_on ~__context ~self:vm + ~value:Ref.null ; + (* vgpu *) + Db.VM.get_VGPUs ~__context ~self:vm + |> List.iter (fun vgpu -> + Db.VGPU.set_scheduled_to_be_resident_on ~__context ~self:vgpu + ~value:Ref.null + ) ; + (* pcis *) + Db.PCI.get_refs_where ~__context + ~expr: + (Eq (Field "scheduled_to_be_attached_to", Literal (Ref.string_of vm)) + ) + |> List.iter (function + | pci when pci <> Ref.null -> + debug "%s: clearing reservation of PCI %s for VM %s" + __FUNCTION__ (Ref.string_of pci) (Ref.string_of vm) ; + Db.PCI.set_scheduled_to_be_attached_to ~__context ~self:pci + ~value:Ref.null + | _ -> + () + ) + (* Notes on memory checking/reservation logic: When computing the hosts free memory we consider all VMs resident_on (ie running and consuming resources NOW) and scheduled_to_be_resident_on (ie those which are @@ -1399,8 +1415,8 @@ functor (Helpers.will_have_qemu ~__context ~self:vm) ; Xapi_network_sriov_helpers.reserve_sriov_vfs ~__context ~host ~vm with e -> - clear_scheduled_to_be_resident_on ~__context ~vm ; - clear_reserved_netsriov_vfs_on ~__context ~vm ; + clear_vif_reservations ~__context ~vm ; + clear_reservations ~__context ~vm ; raise e (* For start/start_on/resume/resume_on/migrate *) @@ -1469,7 +1485,7 @@ functor ?host_op () ; (* In certain cases, VM might have been destroyed as a consequence of operation *) if Db.is_valid_ref __context vm then - clear_scheduled_to_be_resident_on ~__context ~vm + clear_reservations ~__context ~vm ) ) @@ -1488,7 +1504,7 @@ functor finally f (fun () -> Helpers.with_global_lock (fun () -> finally_clear_host_operation ~__context ~host ?host_op () ; - clear_scheduled_to_be_resident_on ~__context ~vm + clear_reservations ~__context ~vm ) ) @@ -2544,7 +2560,7 @@ functor Helpers.with_global_lock (fun () -> finally_clear_host_operation ~__context ~host ~host_op:`vm_migrate () ; - clear_scheduled_to_be_resident_on ~__context ~vm + clear_reservations ~__context ~vm ) in finally @@ -5351,15 +5367,14 @@ functor let pool_migrate ~__context ~vdi ~sr ~options = let vbds = - Db.VBD.get_records_where ~__context - ~expr: - (Db_filter_types.Eq - ( Db_filter_types.Field "VDI" - , Db_filter_types.Literal (Ref.string_of vdi) - ) - ) + let expr = + Xapi_database.Db_filter_types.( + Eq (Field "VDI", Literal (Ref.string_of vdi)) + ) + in + Db.VBD.get_records_where ~__context ~expr in - if List.length vbds < 1 then + if vbds = [] then raise (Api_errors.Server_error (Api_errors.vdi_needs_vm_for_migrate, [Ref.string_of vdi]) @@ -5867,7 +5882,31 @@ functor module Secret = Local.Secret - module PCI = struct end + module PCI = struct + let disable_dom0_access ~__context ~self = + info "PCI.disable_dom0_access: pci = '%s'" (pci_uuid ~__context self) ; + let host = Db.PCI.get_host ~__context ~self in + let local_fn = Local.PCI.disable_dom0_access ~self in + do_op_on ~__context ~local_fn ~host (fun session_id rpc -> + Client.PCI.disable_dom0_access ~rpc ~session_id ~self + ) + + let enable_dom0_access ~__context ~self = + info "PCI.enable_dom0_access: pci = '%s'" (pci_uuid ~__context self) ; + let host = Db.PCI.get_host ~__context ~self in + let local_fn = Local.PCI.enable_dom0_access ~self in + do_op_on ~__context ~local_fn ~host (fun session_id rpc -> + Client.PCI.enable_dom0_access ~rpc ~session_id ~self + ) + + let get_dom0_access_status ~__context ~self = + info "PCI.get_dom0_access_status: pci = '%s'" (pci_uuid ~__context self) ; + let host = Db.PCI.get_host ~__context ~self in + let local_fn = Local.PCI.get_dom0_access_status ~self in + do_op_on ~__context ~local_fn ~host (fun session_id rpc -> + Client.PCI.get_dom0_access_status ~rpc ~session_id ~self + ) + end module VTPM = struct let create ~__context ~vM ~is_unique = diff --git a/ocaml/xapi/monitor_dbcalls.ml b/ocaml/xapi/monitor_dbcalls.ml index 32cba8c2cd1..ab521155d2c 100644 --- a/ocaml/xapi/monitor_dbcalls.ml +++ b/ocaml/xapi/monitor_dbcalls.ml @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -open Db_filter_types +open Xapi_database.Db_filter_types open Monitor_types open Monitor_dbcalls_cache diff --git a/ocaml/xapi/monitor_master.ml b/ocaml/xapi/monitor_master.ml index e65b4b5beca..bb4e6cf2e5b 100644 --- a/ocaml/xapi/monitor_master.ml +++ b/ocaml/xapi/monitor_master.ml @@ -15,7 +15,7 @@ module Rrdd = Rrd_client.Client module Date = Xapi_stdext_date.Date open Monitor_types -open Db_filter_types +open Xapi_database.Db_filter_types open Network module D = Debug.Make (struct let name = "monitor_master" end) @@ -128,12 +128,10 @@ let update_pifs ~__context host pifs = in let set_carrier (domid, devid) = let expr = - Db_filter_types.( - And - ( Eq (Field "resident_on", Literal (Ref.string_of host)) - , Eq (Field "domid", Literal (string_of_int domid)) - ) - ) + And + ( Eq (Field "resident_on", Literal (Ref.string_of host)) + , Eq (Field "domid", Literal (string_of_int domid)) + ) in match Db.VM.get_refs_where ~__context ~expr with | [] -> diff --git a/ocaml/xapi/network_event_loop.ml b/ocaml/xapi/network_event_loop.ml index 8e4b39cdbf7..4967e7f369e 100644 --- a/ocaml/xapi/network_event_loop.ml +++ b/ocaml/xapi/network_event_loop.ml @@ -26,7 +26,9 @@ let _watch_networks_for_nbd_changes __context ~update_firewall let allowed_interfaces = None in let api_timeout = 60. in let timeout = - 30. +. api_timeout +. !Db_globs.master_connection_reset_timeout + 30. + +. api_timeout + +. !Xapi_database.Db_globs.master_connection_reset_timeout in let wait_for_network_change ~token = let from = diff --git a/ocaml/xapi/nm.ml b/ocaml/xapi/nm.ml index 5129b01b389..5db9cb9a29f 100644 --- a/ocaml/xapi/nm.ml +++ b/ocaml/xapi/nm.ml @@ -16,7 +16,7 @@ module D = Debug.Make (struct let name = "nm" end) open D open Xapi_stdext_std.Xstringext module Listext = Xapi_stdext_std.Listext.List -open Db_filter_types +open Xapi_database.Db_filter_types open Network open Network_interface @@ -725,7 +725,7 @@ let bring_pif_up ~__context ?(management_interface = false) (pif : API.ref_PIF) (* The master_connection would otherwise try to take a broken stunnel from the cache *) Stunnel_cache.flush () ; warn "About to forcibly reset the master connection" ; - Master_connection.force_connection_reset () + Xapi_database.Master_connection.force_connection_reset () ) ; if rc.API.pIF_currently_attached = false || management_interface then ( if management_interface then ( diff --git a/ocaml/xapi/pool_db_backup.ml b/ocaml/xapi/pool_db_backup.ml index 3a6207ab63e..2a0ab1eae21 100644 --- a/ocaml/xapi/pool_db_backup.ml +++ b/ocaml/xapi/pool_db_backup.ml @@ -20,7 +20,8 @@ module Unixext = Xapi_stdext_unix.Unixext let finally = Xapi_stdext_pervasives.Pervasiveext.finally open Client -open Db_cache_types +open Xapi_database +open Xapi_database.Db_cache_types module D = Debug.Make (struct let name = "pool_db_sync" end) diff --git a/ocaml/xapi/pvs_cache_vdi.ml b/ocaml/xapi/pvs_cache_vdi.ml index b0b3f42d694..5fe404be616 100644 --- a/ocaml/xapi/pvs_cache_vdi.ml +++ b/ocaml/xapi/pvs_cache_vdi.ml @@ -15,7 +15,7 @@ module D = Debug.Make (struct let name = "pvs_cache_vdi" end) open D -open Db_filter_types +open Xapi_database.Db_filter_types let create_vdi ~__context ~sR ~size = info "Creating new PVS-cache VDI" ; diff --git a/ocaml/xapi/pvs_proxy_control.ml b/ocaml/xapi/pvs_proxy_control.ml index 0b5360a86b8..8597166fe7b 100644 --- a/ocaml/xapi/pvs_proxy_control.ml +++ b/ocaml/xapi/pvs_proxy_control.ml @@ -26,7 +26,7 @@ let proxy_port_name vif = (** [proxies] returns all currently attached proxies *) let get_running_proxies ~__context ~site = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in Db.PVS_proxy.get_refs_where ~__context ~expr: (And @@ -39,7 +39,7 @@ let get_running_proxies ~__context ~site = module State = struct type t = Starting | Started | Stopping | Failed - open Xenstore + open Ezxenstore_core.Xenstore let of_string = function | "starting" -> @@ -192,7 +192,7 @@ let remove_site_on_localhost ~__context ~site = exception No_cache_sr_available let find_cache_vdi ~__context ~host ~site = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in (* There should be at most one matching PVS_cache_storage object *) let pcs' = Db.PVS_cache_storage.get_refs_where ~__context @@ -376,7 +376,7 @@ let clear_proxy_state ~__context _vif proxy = Db.PVS_proxy.set_status ~__context ~self:proxy ~value:`stopped let find_proxy_for_vif ~__context ~vif = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let proxies = Db.PVS_proxy.get_refs_where ~__context ~expr:(Eq (Field "VIF", Literal (Ref.string_of vif))) diff --git a/ocaml/xapi/rbac_audit.ml b/ocaml/xapi/rbac_audit.ml index 6c3f99b7341..bbc5a7a6fc9 100644 --- a/ocaml/xapi/rbac_audit.ml +++ b/ocaml/xapi/rbac_audit.ml @@ -111,7 +111,7 @@ let get_obj_names_of_refs (obj_ref_list : SExpr.t list) : SExpr.t list = (function | SExpr.(Node [String name; String ""; String ""; String ref_value]) -> let obj_name, uuid = - match Ref_index.lookup ref_value with + match Xapi_database.Ref_index.lookup ref_value with | None -> ("", "") | Some {name_label= None; uuid; _} -> @@ -312,7 +312,7 @@ let rec sexpr_args_of __context name rpc_value action = else (* heuristic 2: print uuid/refs arguments in the xapi call *) match rpc_value with | Rpc.String value -> ( - match Ref_index.lookup value with + match Xapi_database.Ref_index.lookup value with | None when Ref.(is_real (of_string value)) -> (* it's a ref, just not in the db cache *) Some diff --git a/ocaml/xapi/redo_log_alert.ml b/ocaml/xapi/redo_log_alert.ml index 02ae81f62ef..11e9db4bdfe 100644 --- a/ocaml/xapi/redo_log_alert.ml +++ b/ocaml/xapi/redo_log_alert.ml @@ -52,7 +52,7 @@ let loop () = (fun () -> while true do let name, accessible = - Event.sync (Event.receive Redo_log.redo_log_events) + Event.sync (Event.receive Xapi_database.Redo_log.redo_log_events) in let alert_body = Printf.sprintf "Redo log [%s]" name in if accessible then ( diff --git a/ocaml/xapi/redo_log_usage.ml b/ocaml/xapi/redo_log_usage.ml index 245a0d183cd..630ebf03be5 100644 --- a/ocaml/xapi/redo_log_usage.ml +++ b/ocaml/xapi/redo_log_usage.ml @@ -19,6 +19,8 @@ exception DeltaTooOld exception DatabaseWrongSize of int * int +open Xapi_database + let read_from_redo_log log staging_path db_ref = R.log_and_ignore_exn @@ fun () -> (* 1. Start the process with which we communicate to access the redo log *) diff --git a/ocaml/xapi/redo_log_usage.mli b/ocaml/xapi/redo_log_usage.mli index 1bbd9c8888b..1e1c921820b 100644 --- a/ocaml/xapi/redo_log_usage.mli +++ b/ocaml/xapi/redo_log_usage.mli @@ -16,9 +16,12 @@ *) val read_from_redo_log : - [< `RO | `RW] Redo_log.redo_log -> string -> Db_ref.t -> unit + [< `RO | `RW] Xapi_database.Redo_log.redo_log + -> string + -> Xapi_database.Db_ref.t + -> unit (** Connect to the block device and write the latest version of the database * on it to a file with a given name. *) -val stop_using_redo_log : _ Redo_log.redo_log -> unit +val stop_using_redo_log : _ Xapi_database.Redo_log.redo_log -> unit (** Disconnect from the block device. May be safely called even when not currently connected. *) diff --git a/ocaml/xapi/slave_backup.ml b/ocaml/xapi/slave_backup.ml index bf8cd226031..aeb3e3e1e95 100644 --- a/ocaml/xapi/slave_backup.ml +++ b/ocaml/xapi/slave_backup.ml @@ -21,6 +21,8 @@ *) type write_entry = {period_start_time: float; writes_this_period: int} +module Parse_db_conf = Xapi_database.Parse_db_conf + let backup_write_table : (Parse_db_conf.db_connection, write_entry) Hashtbl.t = Hashtbl.create 20 @@ -93,7 +95,9 @@ let notify_write dbconn = let determine_backup_connections generation_count = tick_backup_write_table () ; (* reset existing write_entries if any periods expire *) - let dbconns_and_gen_counts = Db_connections.get_dbs_and_gen_counts () in + let dbconns_and_gen_counts = + Xapi_database.Db_connections.get_dbs_and_gen_counts () + in (* throw out dbconns that are up-to-date *) let dbconns_and_gen_counts = List.filter (fun (gen, _) -> gen <> generation_count) dbconns_and_gen_counts diff --git a/ocaml/xapi/sm.ml b/ocaml/xapi/sm.ml index 2526aa79b6c..df438a656bd 100644 --- a/ocaml/xapi/sm.ml +++ b/ocaml/xapi/sm.ml @@ -30,7 +30,7 @@ exception Unknown_driver of string exception MasterOnly -let with_dbg ~name ~dbg f = Debuginfo.with_dbg ~module_name:"SM" ~name ~dbg f +let with_dbg ~name ~dbg f = Debug_info.with_dbg ~module_name:"SM" ~name ~dbg f let supported_drivers () = Hashtbl.fold (fun name _ acc -> name :: acc) driver_info_cache [] @@ -39,7 +39,7 @@ let supported_drivers () = let register ~__context () = let dbg = Context.string_of_task_and_tracing __context in with_dbg ~name:"register" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in let add_entry driver info = let name = String.lowercase_ascii driver in Hashtbl.replace driver_info_cache name info @@ -77,7 +77,7 @@ let srmaster_only (_, dconf) = let sr_create ~dbg dconf driver sr size = with_dbg ~dbg ~name:"sr_create" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_create" [Int64.to_string size] in @@ -86,7 +86,7 @@ let sr_create ~dbg dconf driver sr size = let sr_delete ~dbg dconf driver sr = with_dbg ~dbg ~name:"sr_delete" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_delete" [] in debug "sr_delete" driver (sprintf "sr=%s" (Ref.string_of sr)) ; Sm_exec.parse_unit (Sm_exec.exec_xmlrpc ~dbg (driver_filename driver) call) @@ -97,7 +97,7 @@ let serialize_attach_detach = let sr_attach ~dbg dconf driver sr = with_dbg ~dbg ~name:"sr_attach" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Locking_helpers.Named_mutex.execute serialize_attach_detach (fun () -> debug "sr_attach" driver (sprintf "sr=%s" (Ref.string_of sr)) ; let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_attach" [] in @@ -106,7 +106,7 @@ let sr_attach ~dbg dconf driver sr = let sr_detach ~dbg dconf driver sr = with_dbg ~dbg ~name:"sr_detach" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Locking_helpers.Named_mutex.execute serialize_attach_detach (fun () -> debug "sr_detach" driver (sprintf "sr=%s" (Ref.string_of sr)) ; let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_detach" [] in @@ -115,7 +115,7 @@ let sr_detach ~dbg dconf driver sr = let sr_probe ~dbg dconf driver sr_sm_config = with_dbg ~dbg ~name:"sr_probe" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in if List.mem_assoc Sr_probe (features_of_driver driver) then Locking_helpers.Named_mutex.execute serialize_attach_detach (fun () -> debug "sr_probe" driver @@ -139,7 +139,7 @@ let sr_probe ~dbg dconf driver sr_sm_config = let sr_scan ~dbg dconf driver sr = with_dbg ~dbg ~name:"sr_scan" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "sr_scan" driver (sprintf "sr=%s" (Ref.string_of sr)) ; srmaster_only dconf ; let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_scan" [] in @@ -147,16 +147,16 @@ let sr_scan ~dbg dconf driver sr = let sr_update ~dbg dconf driver sr = with_dbg ~dbg ~name:"sr_update" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "sr_update" driver (sprintf "sr=%s" (Ref.string_of sr)) ; let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_update" [] in Sm_exec.parse_unit (Sm_exec.exec_xmlrpc ~dbg (driver_filename driver) call) -let vdi_create ~dbg dconf driver sr sm_config vdi_type size name_label +let vdi_create ~dbg ?vdi_uuid dconf driver sr sm_config vdi_type size name_label name_description metadata_of_pool is_a_snapshot snapshot_time snapshot_of read_only = with_dbg ~dbg ~name:"vdi_create" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_create" driver (sprintf "sr=%s sm_config=[%s] type=[%s] size=%Ld" (Ref.string_of sr) (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) sm_config)) @@ -164,8 +164,8 @@ let vdi_create ~dbg dconf driver sr sm_config vdi_type size name_label ) ; srmaster_only dconf ; let call = - Sm_exec.make_call ~sr_ref:sr ~vdi_sm_config:sm_config ~vdi_type dconf - "vdi_create" + Sm_exec.make_call ?vdi_uuid ~sr_ref:sr ~vdi_sm_config:sm_config ~vdi_type + dconf "vdi_create" [ sprintf "%Lu" size ; name_label @@ -181,7 +181,7 @@ let vdi_create ~dbg dconf driver sr sm_config vdi_type size name_label let vdi_update ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_update" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_update" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; let call = Sm_exec.make_call ~sr_ref:sr ~vdi_ref:vdi dconf "vdi_update" [] in @@ -189,7 +189,7 @@ let vdi_update ~dbg dconf driver sr vdi = let vdi_introduce ~dbg dconf driver sr new_uuid sm_config location = with_dbg ~dbg ~name:"vdi_introduce" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_introduce" driver (sprintf "sr=%s new_uuid=%s sm_config=[%s] location=%s" (Ref.string_of sr) new_uuid @@ -204,7 +204,7 @@ let vdi_introduce ~dbg dconf driver sr new_uuid sm_config location = let vdi_delete ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_delete" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_delete" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; srmaster_only dconf ; @@ -213,7 +213,7 @@ let vdi_delete ~dbg dconf driver sr vdi = let vdi_attach ~dbg dconf driver sr vdi writable = with_dbg ~dbg ~name:"vdi_attach" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_attach" driver (sprintf "sr=%s vdi=%s writable=%b" (Ref.string_of sr) (Ref.string_of vdi) writable @@ -227,7 +227,7 @@ let vdi_attach ~dbg dconf driver sr vdi writable = let vdi_detach ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_detach" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_detach" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; let call = Sm_exec.make_call ~sr_ref:sr ~vdi_ref:vdi dconf "vdi_detach" [] in @@ -235,7 +235,7 @@ let vdi_detach ~dbg dconf driver sr vdi = let vdi_activate ~dbg dconf driver sr vdi writable = with_dbg ~dbg ~name:"vdi_activate" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_activate" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; let call = @@ -246,7 +246,7 @@ let vdi_activate ~dbg dconf driver sr vdi writable = let vdi_deactivate ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_deactivate" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_deactivate" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; let call = @@ -256,7 +256,7 @@ let vdi_deactivate ~dbg dconf driver sr vdi = let vdi_snapshot ~dbg dconf driver driver_params sr vdi = with_dbg ~dbg ~name:"vdi_snapshot" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_snapshot" driver (sprintf "sr=%s vdi=%s driver_params=[%s]" (Ref.string_of sr) (Ref.string_of vdi) @@ -271,7 +271,7 @@ let vdi_snapshot ~dbg dconf driver driver_params sr vdi = let vdi_clone ~dbg dconf driver driver_params sr vdi = with_dbg ~dbg ~name:"vdi_clone" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_clone" driver (sprintf "sr=%s vdi=%s driver_params=[%s]" (Ref.string_of sr) (Ref.string_of vdi) @@ -286,7 +286,7 @@ let vdi_clone ~dbg dconf driver driver_params sr vdi = let vdi_resize ~dbg dconf driver sr vdi newsize = with_dbg ~dbg ~name:"vdi_resize" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_resize" driver (sprintf "sr=%s vdi=%s newsize=%Ld" (Ref.string_of sr) (Ref.string_of vdi) newsize @@ -300,7 +300,7 @@ let vdi_resize ~dbg dconf driver sr vdi newsize = let vdi_generate_config ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_generate_config" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_generate_config" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; let call = @@ -310,7 +310,7 @@ let vdi_generate_config ~dbg dconf driver sr vdi = let vdi_compose ~dbg dconf driver sr vdi1 vdi2 = with_dbg ~dbg ~name:"vdi_compose" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_compose" driver (sprintf "sr=%s vdi1=%s vdi2=%s" (Ref.string_of sr) (Ref.string_of vdi1) (Ref.string_of vdi2) @@ -324,7 +324,7 @@ let vdi_compose ~dbg dconf driver sr vdi1 vdi2 = let vdi_epoch_begin ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_epoch_begin" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_epoch_begin" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; let call = @@ -334,7 +334,7 @@ let vdi_epoch_begin ~dbg dconf driver sr vdi = let vdi_epoch_end ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_epoch_end" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_epoch_end" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; let call = @@ -344,7 +344,7 @@ let vdi_epoch_end ~dbg dconf driver sr vdi = let vdi_enable_cbt ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_enable_cbt" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_enable_cbt" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; srmaster_only dconf ; @@ -355,7 +355,7 @@ let vdi_enable_cbt ~dbg dconf driver sr vdi = let vdi_disable_cbt ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_disable_cbt" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_disable_cbt" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; srmaster_only dconf ; @@ -366,7 +366,7 @@ let vdi_disable_cbt ~dbg dconf driver sr vdi = let vdi_data_destroy ~dbg dconf driver sr vdi = with_dbg ~dbg ~name:"vdi_data_destroy" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_data_destroy" driver (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ; srmaster_only dconf ; @@ -377,7 +377,7 @@ let vdi_data_destroy ~dbg dconf driver sr vdi = let vdi_list_changed_blocks ~dbg dconf driver sr ~vdi_from ~vdi_to = with_dbg ~dbg ~name:"vdi_list_changed_blocks" @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in debug "vdi_list_changed_blocks" driver (sprintf "sr=%s vdi_from=%s vdi_to=%s" (Ref.string_of sr) (Ref.string_of vdi_from) (Ref.string_of vdi_to) @@ -407,17 +407,12 @@ let assert_session_has_internal_sr_access ~__context ~sr = let get_my_pbd_for_sr __context sr_id = let me = Helpers.get_localhost ~__context in let pbd_ref_and_record = + let open Xapi_database.Db_filter_types in Db.PBD.get_records_where ~__context ~expr: - (Db_filter_types.And - ( Db_filter_types.Eq - ( Db_filter_types.Field "host" - , Db_filter_types.Literal (Ref.string_of me) - ) - , Db_filter_types.Eq - ( Db_filter_types.Field "SR" - , Db_filter_types.Literal (Ref.string_of sr_id) - ) + (And + ( Eq (Field "host", Literal (Ref.string_of me)) + , Eq (Field "SR", Literal (Ref.string_of sr_id)) ) ) in diff --git a/ocaml/xapi/sm_exec.ml b/ocaml/xapi/sm_exec.ml index a6d0d231ee2..28cdd11e07b 100644 --- a/ocaml/xapi/sm_exec.ml +++ b/ocaml/xapi/sm_exec.ml @@ -33,7 +33,7 @@ let cmd_name driver = sprintf "%s/%sSR" !Xapi_globs.sm_dir driver let sm_username = "__sm__backend" let with_dbg ~name ~dbg f = - Debuginfo.with_dbg ~module_name:"Sm_exec" ~name ~dbg f + Debug_info.with_dbg ~module_name:"Sm_exec" ~name ~dbg f (*********************************************************************************************) (* Random utility functions *) @@ -69,8 +69,8 @@ type call = { } let make_call ?driver_params ?sr_sm_config ?vdi_sm_config ?vdi_type - ?vdi_location ?new_uuid ?sr_ref ?vdi_ref (subtask_of, device_config) cmd - args = + ?vdi_location ?new_uuid ?sr_ref ?vdi_ref ?vdi_uuid + (subtask_of, device_config) cmd args = Server_helpers.exec_with_new_task "sm_exec" (fun __context -> (* Only allow a subset of calls if the SR has been introduced by a DR task. *) Option.iter @@ -117,7 +117,22 @@ let make_call ?driver_params ?sr_sm_config ?vdi_sm_config ?vdi_type Option.map (fun self -> Db.VDI.get_location ~__context ~self) vdi_ref in let vdi_uuid = - Option.map (fun self -> Db.VDI.get_uuid ~__context ~self) vdi_ref + match (cmd, vdi_ref, vdi_uuid) with + | "vdi_create", None, (Some x as uuid) -> + debug "%s: cmd=%s vdi_uuid=%s" __FUNCTION__ cmd x ; + uuid + (* when creating a VDI we sometimes want to provide the UUID + rather than letting the backend pick one. This is to + support backup VDIs CP-46179. So in that case, use the + provided UUID but not for other commands *) + | _, None, Some uuid -> + warn "%s: cmd=%s vdi_uuid=%s - should not happen" __FUNCTION__ cmd + uuid ; + None + | _, Some self, _ -> + Db.VDI.get_uuid ~__context ~self |> Option.some + | _, None, None -> + None in let vdi_on_boot = Option.map @@ -326,12 +341,11 @@ let with_session sr f = let exec_xmlrpc ~dbg ?context:_ ?(needs_session = true) (driver : string) (call : call) = with_dbg ~name:call.cmd ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in let do_call call = let xml = xmlrpc_of_call call in let name = Printf.sprintf "sm_exec: %s" call.cmd in let xml, stderr = - Stats.time_this name (fun () -> + Xapi_database.Stats.time_this name (fun () -> let exe = cmd_name driver in (* Logging call.cmd is safe, but call.args could contain a password. *) try @@ -343,12 +357,11 @@ let exec_xmlrpc ~dbg ?context:_ ?(needs_session = true) (driver : string) | false -> (None, exe, args) | true -> - let traceparent = Debuginfo.traceparent_of_dbg dbg in Xapi_observer_components.env_exe_args_of - ~component:Xapi_observer_components.SMApi ~traceparent - ~exe ~args + ~component:Xapi_observer_components.SMApi ~exe ~args in - Forkhelpers.execute_command_get_output ?env exe args + Forkhelpers.execute_command_get_output ?tracing:di.tracing ?env + exe args in try (Xml.parse_string output, stderr) with e -> @@ -566,7 +579,7 @@ let parse_sr_get_driver_info driver (xml : Xml.xml) = let sr_get_driver_info ~dbg driver = with_dbg ~name:"sr_get_driver_info" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in let call = make_call (None, []) "sr_get_driver_info" [] in parse_sr_get_driver_info driver (exec_xmlrpc ~dbg ~needs_session:false driver call) @@ -575,7 +588,7 @@ let sr_get_driver_info ~dbg driver = * backend and daemon found. *) let get_supported ~dbg add_fn = with_dbg ~name:"get_supported" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in let check_driver entry = if Astring.String.is_suffix ~affix:"SR" entry then let driver = String.sub entry 0 (String.length entry - 2) in diff --git a/ocaml/xapi/startup.ml b/ocaml/xapi/startup.ml index a230fc680db..73b496f327d 100644 --- a/ocaml/xapi/startup.ml +++ b/ocaml/xapi/startup.ml @@ -63,7 +63,7 @@ let run ~__context tasks = List.iter (fun (tsk_name, tsk_flags, tsk_fct) -> (* Wrap the function with a timer *) - let tsk_fct () = Stats.time_this tsk_name tsk_fct in + let tsk_fct () = Xapi_database.Stats.time_this tsk_name tsk_fct in let only_master, only_slave, exnraise, onthread = get_flags_of_list tsk_flags in @@ -105,4 +105,6 @@ let run ~__context tasks = tasks let run ~__context tasks = - Stats.time_this "overall xapi startup" (fun () -> run ~__context tasks) + Xapi_database.Stats.time_this "overall xapi startup" (fun () -> + run ~__context tasks + ) diff --git a/ocaml/xapi/static_vdis.ml b/ocaml/xapi/static_vdis.ml index 5ed45c95e16..049708e9c71 100644 --- a/ocaml/xapi/static_vdis.ml +++ b/ocaml/xapi/static_vdis.ml @@ -18,7 +18,8 @@ module D = Debug.Make (struct let name = "static_vdis" end) open D -include Static_vdis_list (* include the vdi type and the list() function *) +include Xapi_database.Static_vdis_list +(* include the vdi type and the list() function *) (** Generate the static configuration and attach the VDI now *) let permanent_vdi_attach ~__context ~vdi ~reason = diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index fa306e42b61..eff980cfbe6 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -654,10 +654,10 @@ let stop ~dbg ~id = raise (Storage_interface.Storage_error (Does_not_exist ("mirror", id))) let dbg_and_tracing_of_task task = - Debuginfo.make + Debug_info.make ~log:(Storage_task.get_dbg task) ~tracing:(Storage_task.tracing task) - |> Debuginfo.to_string + |> Debug_info.to_string let start' ~task ~dbg:_ ~sr ~vdi ~dp ~url ~dest ~verify_dest = debug "Mirror.start sr:%s vdi:%s url:%s dest:%s verify_dest:%B" @@ -1336,8 +1336,8 @@ let copy ~task ~dbg ~sr ~vdi ~dp:_ ~url ~dest ~verify_dest = let with_task_and_thread ~dbg f = let task = - Storage_task.add tasks dbg.Debuginfo.log (fun task -> - Storage_task.set_tracing task dbg.Debuginfo.tracing ; + Storage_task.add tasks dbg.Debug_info.log (fun task -> + Storage_task.set_tracing task dbg.Debug_info.tracing ; try f task with | Storage_error (Backend_error (code, params)) | Api_errors.Server_error (code, params) -> @@ -1360,17 +1360,17 @@ let with_task_and_thread ~dbg f = let start ~dbg ~sr ~vdi ~dp ~url ~dest ~verify_dest = with_task_and_thread ~dbg (fun task -> - start' ~task ~dbg:dbg.Debuginfo.log ~sr ~vdi ~dp ~url ~dest ~verify_dest + start' ~task ~dbg:dbg.Debug_info.log ~sr ~vdi ~dp ~url ~dest ~verify_dest ) let copy ~dbg ~sr ~vdi ~dp ~url ~dest ~verify_dest = with_task_and_thread ~dbg (fun task -> - copy ~task ~dbg:dbg.Debuginfo.log ~sr ~vdi ~dp ~url ~dest ~verify_dest + copy ~task ~dbg:dbg.Debug_info.log ~sr ~vdi ~dp ~url ~dest ~verify_dest ) let copy_into ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~verify_dest = with_task_and_thread ~dbg (fun task -> - copy_into ~task ~dbg:dbg.Debuginfo.log ~sr ~vdi ~url ~dest ~dest_vdi + copy_into ~task ~dbg:dbg.Debug_info.log ~sr ~vdi ~url ~dest ~dest_vdi ~verify_dest ) diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 7e85a2ed324..0931b4b0903 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -21,7 +21,7 @@ open D (* 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 ~name ~dbg f = - let open Debuginfo in + let open Debug_info in let di = of_string dbg in Debug.with_thread_associated di.log (fun () -> @@ -189,7 +189,7 @@ module Mux = struct let rpc = of_sr sr end)) in with_dbg ~name:"Query.diagnostics" ~dbg @@ fun di -> - C.Query.diagnostics (Debuginfo.to_string di) + C.Query.diagnostics (Debug_info.to_string di) ) end @@ -247,7 +247,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.DP.destroy2 (Debuginfo.to_string di) dp sr vdi vm allow_leak ; + C.DP.destroy2 (Debug_info.to_string di) dp sr vdi vm allow_leak ; DP_info.delete dp let destroy _context ~dbg ~dp ~allow_leak = @@ -256,7 +256,7 @@ module Mux = struct let open DP_info in match read dp with | Some {sr; vdi; vm; _} -> - destroy2 _context ~dbg:(Debuginfo.to_string di) ~dp ~sr ~vdi ~vm + destroy2 _context ~dbg:(Debug_info.to_string di) ~dp ~sr ~vdi ~vm ~allow_leak | None -> info @@ -305,7 +305,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.create (Debuginfo.to_string di) sr name_label name_description + C.SR.create (Debug_info.to_string di) sr name_label name_description device_config physical_size let attach () ~dbg ~sr ~device_config = @@ -315,7 +315,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.attach (Debuginfo.to_string di) sr device_config + C.SR.attach (Debug_info.to_string di) sr device_config let set_name_label () ~dbg ~sr ~new_name_label = with_dbg ~name:"SR.set_name_label" ~dbg @@ fun di -> @@ -324,7 +324,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.set_name_label (Debuginfo.to_string di) sr new_name_label + C.SR.set_name_label (Debug_info.to_string di) sr new_name_label let set_name_description () ~dbg ~sr ~new_name_description = with_dbg ~name:"SR.set_name_description" ~dbg @@ fun di -> @@ -333,7 +333,8 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.set_name_description (Debuginfo.to_string di) sr new_name_description + C.SR.set_name_description (Debug_info.to_string di) sr + new_name_description let detach () ~dbg ~sr = with_dbg ~name:"SR.detach" ~dbg @@ fun di -> @@ -341,7 +342,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.detach (Debuginfo.to_string di) sr + C.SR.detach (Debug_info.to_string di) sr let destroy () ~dbg ~sr = with_dbg ~name:"SR.destroy" ~dbg @@ fun di -> @@ -349,7 +350,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.destroy (Debuginfo.to_string di) sr + C.SR.destroy (Debug_info.to_string di) sr let stat () ~dbg ~sr = with_dbg ~name:"SR.stat" ~dbg @@ fun di -> @@ -357,7 +358,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.stat (Debuginfo.to_string di) sr + C.SR.stat (Debug_info.to_string di) sr let scan () ~dbg ~sr = with_dbg ~name:"SR.scan" ~dbg @@ fun di -> @@ -365,7 +366,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.scan (Debuginfo.to_string di) sr + C.SR.scan (Debug_info.to_string di) sr module SRSet = Set.Make (struct type t = Storage_interface.Sr.t @@ -389,7 +390,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.list (Debuginfo.to_string di) + C.SR.list (Debug_info.to_string di) ) ) |> SRSet.elements @@ -400,7 +401,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.SR.reset (Debuginfo.to_string di) sr + C.SR.reset (Debug_info.to_string di) sr let update_snapshot_info_src () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs = @@ -418,8 +419,8 @@ module Mux = struct |> String.concat "; " |> Printf.sprintf "[%s]" ) ; - Storage_migrate.update_snapshot_info_src ~dbg:(Debuginfo.to_string di) ~sr - ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs + Storage_migrate.update_snapshot_info_src ~dbg:(Debug_info.to_string di) + ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs let update_snapshot_info_dest () ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs = with_dbg ~name:"SR.update_snapshot_info_dest" ~dbg @@ fun di -> @@ -439,7 +440,7 @@ module Mux = struct |> String.concat "; " |> Printf.sprintf "[%s]" ) ; - C.SR.update_snapshot_info_dest (Debuginfo.to_string di) sr vdi src_vdi + C.SR.update_snapshot_info_dest (Debug_info.to_string di) sr vdi src_vdi snapshot_pairs end @@ -451,7 +452,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.create (Debuginfo.to_string di) sr vdi_info + C.VDI.create (Debug_info.to_string di) sr vdi_info let set_name_label () ~dbg ~sr ~vdi ~new_name_label = with_dbg ~name:"VDI.set_name_label" ~dbg @@ fun di -> @@ -460,7 +461,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.set_name_label (Debuginfo.to_string di) sr vdi new_name_label + C.VDI.set_name_label (Debug_info.to_string di) sr vdi new_name_label let set_name_description () ~dbg ~sr ~vdi ~new_name_description = with_dbg ~name:"VDI.set_name_description" ~dbg @@ fun di -> @@ -470,7 +471,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.set_name_description (Debuginfo.to_string di) sr vdi + C.VDI.set_name_description (Debug_info.to_string di) sr vdi new_name_description let snapshot () ~dbg ~sr ~vdi_info = @@ -480,7 +481,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - try C.VDI.snapshot (Debuginfo.to_string di) sr vdi_info + try C.VDI.snapshot (Debug_info.to_string di) sr vdi_info with Storage_interface.Storage_error (Activated_on_another_host uuid) -> Server_helpers.exec_with_new_task "smapiv2.snapshot.activated" ~subtask_of:(Ref.of_string dbg) (fun __context -> @@ -500,7 +501,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.clone (Debuginfo.to_string di) sr vdi_info + C.VDI.clone (Debug_info.to_string di) sr vdi_info let resize () ~dbg ~sr ~vdi ~new_size = with_dbg ~name:"VDI.resize" ~dbg @@ fun di -> @@ -509,7 +510,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.resize (Debuginfo.to_string di) sr vdi new_size + C.VDI.resize (Debug_info.to_string di) sr vdi new_size let destroy () ~dbg ~sr ~vdi = with_dbg ~name:"VDI.destroy" ~dbg @@ fun di -> @@ -517,7 +518,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.destroy (Debuginfo.to_string di) sr vdi + C.VDI.destroy (Debug_info.to_string di) sr vdi let stat () ~dbg ~sr ~vdi = with_dbg ~name:"VDI.stat" ~dbg @@ fun di -> @@ -525,7 +526,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.stat (Debuginfo.to_string di) sr vdi + C.VDI.stat (Debug_info.to_string di) sr vdi let introduce () ~dbg ~sr ~uuid ~sm_config ~location = with_dbg ~name:"VDI.introduce" ~dbg @@ fun di -> @@ -536,7 +537,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.introduce (Debuginfo.to_string di) sr uuid sm_config location + C.VDI.introduce (Debug_info.to_string di) sr uuid sm_config location let set_persistent () ~dbg ~sr ~vdi ~persistent = with_dbg ~name:"VDI.set_persistent" ~dbg @@ fun di -> @@ -545,7 +546,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.set_persistent (Debuginfo.to_string di) sr vdi persistent + C.VDI.set_persistent (Debug_info.to_string di) sr vdi persistent let epoch_begin () ~dbg ~sr ~vdi ~vm ~persistent = with_dbg ~name:"VDI.epoch_begin" ~dbg @@ fun di -> @@ -554,7 +555,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.epoch_begin (Debuginfo.to_string di) sr vdi vm persistent + C.VDI.epoch_begin (Debug_info.to_string di) sr vdi vm persistent let attach () ~dbg ~dp ~sr ~vdi ~read_write = with_dbg ~name:"VDI.attach" ~dbg @@ fun di -> @@ -566,7 +567,7 @@ module Mux = struct let vm = Vm.of_string "0" in DP_info.write dp DP_info.{sr; vdi; vm; read_write} ; let backend = - C.VDI.attach3 (Debuginfo.to_string di) dp sr vdi vm read_write + C.VDI.attach3 (Debug_info.to_string di) dp sr vdi vm read_write in (* VDI.attach2 should be used instead, VDI.attach is only kept for backwards-compatibility, because older xapis call Remote.VDI.attach during SXM. @@ -615,17 +616,17 @@ module Mux = struct end)) in let vm = Vm.of_string "0" in DP_info.write dp DP_info.{sr; vdi; vm; read_write} ; - C.VDI.attach3 (Debuginfo.to_string di) dp sr vdi vm read_write + C.VDI.attach3 (Debug_info.to_string di) dp sr vdi vm read_write let attach3 () ~dbg ~dp ~sr ~vdi ~vm ~read_write = with_dbg ~name:"VDI.attach3" ~dbg @@ fun di -> info "VDI.attach3 dbg:%s dp:%s sr:%s vdi:%s vm:%s read_write:%b" - di.Debuginfo.log dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) read_write ; + di.Debug_info.log dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) read_write ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in DP_info.write dp DP_info.{sr; vdi; vm; read_write} ; - C.VDI.attach3 (Debuginfo.to_string di) dp sr vdi vm read_write + C.VDI.attach3 (Debug_info.to_string di) dp sr vdi vm read_write let activate () ~dbg ~dp ~sr ~vdi = with_dbg ~name:"VDI.activate" ~dbg @@ fun di -> @@ -634,7 +635,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.activate (Debuginfo.to_string di) dp sr vdi + C.VDI.activate (Debug_info.to_string di) dp sr vdi let activate3 () ~dbg ~dp ~sr ~vdi ~vm = with_dbg ~name:"VDI.activate3" ~dbg @@ fun di -> @@ -654,10 +655,10 @@ module Mux = struct if (not read_write) && sr_has_capability sr Smint.Vdi_activate_readonly then ( info "The VDI was attached read-only: calling activate_readonly" ; - C.VDI.activate_readonly (Debuginfo.to_string di) dp sr vdi vm + C.VDI.activate_readonly (Debug_info.to_string di) dp sr vdi vm ) else ( info "The VDI was attached read/write: calling activate3" ; - C.VDI.activate3 (Debuginfo.to_string di) dp sr vdi vm + C.VDI.activate3 (Debug_info.to_string di) dp sr vdi vm ) let activate_readonly () ~dbg ~dp ~sr ~vdi ~vm = @@ -667,7 +668,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.activate_readonly (Debuginfo.to_string di) dp sr vdi vm + C.VDI.activate_readonly (Debug_info.to_string di) dp sr vdi vm let deactivate () ~dbg ~dp ~sr ~vdi ~vm = with_dbg ~name:"VDI.deativate" ~dbg @@ fun di -> @@ -676,7 +677,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.deactivate (Debuginfo.to_string di) dp sr vdi vm + C.VDI.deactivate (Debug_info.to_string di) dp sr vdi vm let detach () ~dbg ~dp ~sr ~vdi ~vm = with_dbg ~name:"VDI.detach" ~dbg @@ fun di -> @@ -685,7 +686,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.detach (Debuginfo.to_string di) dp sr vdi vm ; + C.VDI.detach (Debug_info.to_string di) dp sr vdi vm ; DP_info.delete dp let epoch_end () ~dbg ~sr ~vdi ~vm = @@ -695,7 +696,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.epoch_end (Debuginfo.to_string di) sr vdi vm + C.VDI.epoch_end (Debug_info.to_string di) sr vdi vm let get_by_name () ~dbg ~sr ~name = with_dbg ~name:"VDI.get_by_name" ~dbg @@ fun di -> @@ -703,7 +704,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.get_by_name (Debuginfo.to_string di) sr name + C.VDI.get_by_name (Debug_info.to_string di) sr name let set_content_id () ~dbg ~sr ~vdi ~content_id = with_dbg ~name:"VDI.set_content_id" ~dbg @@ fun di -> @@ -712,7 +713,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.set_content_id (Debuginfo.to_string di) sr vdi content_id + C.VDI.set_content_id (Debug_info.to_string di) sr vdi content_id let similar_content () ~dbg ~sr ~vdi = with_dbg ~name:"VDI.similar_content" ~dbg @@ fun di -> @@ -721,7 +722,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.similar_content (Debuginfo.to_string di) sr vdi + C.VDI.similar_content (Debug_info.to_string di) sr vdi let compose () ~dbg ~sr ~vdi1 ~vdi2 = with_dbg ~name:"VDI.compose" ~dbg @@ fun di -> @@ -730,7 +731,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.compose (Debuginfo.to_string di) sr vdi1 vdi2 + C.VDI.compose (Debug_info.to_string di) sr vdi1 vdi2 let add_to_sm_config () ~dbg ~sr ~vdi ~key ~value = with_dbg ~name:"VDI.add_to_sm_config" ~dbg @@ fun di -> @@ -739,7 +740,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.add_to_sm_config (Debuginfo.to_string di) sr vdi key value + C.VDI.add_to_sm_config (Debug_info.to_string di) sr vdi key value let remove_from_sm_config () ~dbg ~sr ~vdi ~key = with_dbg ~name:"VDI.remove_from_sm_config" ~dbg @@ fun di -> @@ -748,7 +749,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.remove_from_sm_config (Debuginfo.to_string di) sr vdi key + C.VDI.remove_from_sm_config (Debug_info.to_string di) sr vdi key let get_url () ~dbg ~sr ~vdi = with_dbg ~name:"VDI.get_url" ~dbg @@ fun di -> @@ -756,7 +757,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.get_url (Debuginfo.to_string di) sr vdi + C.VDI.get_url (Debug_info.to_string di) sr vdi let enable_cbt () ~dbg ~sr ~vdi = with_dbg ~name:"VDI.enabled_cbt" ~dbg @@ fun di -> @@ -764,7 +765,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.enable_cbt (Debuginfo.to_string di) sr vdi + C.VDI.enable_cbt (Debug_info.to_string di) sr vdi let disable_cbt () ~dbg ~sr ~vdi = with_dbg ~name:"VDI.disable_cbt" ~dbg @@ fun di -> @@ -772,7 +773,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.disable_cbt (Debuginfo.to_string di) sr vdi + C.VDI.disable_cbt (Debug_info.to_string di) sr vdi let data_destroy () ~dbg ~sr ~vdi = with_dbg ~name:"VDI.data_destroy" ~dbg @@ fun di -> @@ -780,7 +781,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.data_destroy (Debuginfo.to_string di) sr vdi + C.VDI.data_destroy (Debug_info.to_string di) sr vdi let list_changed_blocks () ~dbg ~sr ~vdi_from ~vdi_to = with_dbg ~name:"VDI.list_changed_blocks" ~dbg @@ fun di -> @@ -789,7 +790,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.list_changed_blocks (Debuginfo.to_string di) sr vdi_from vdi_to + C.VDI.list_changed_blocks (Debug_info.to_string di) sr vdi_from vdi_to end let get_by_name () ~dbg ~name = @@ -804,7 +805,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - (sr, C.VDI.get_by_name (Debuginfo.to_string di) sr name) + (sr, C.VDI.get_by_name (Debug_info.to_string di) sr name) | [name] -> ( match success_or choose @@ -812,7 +813,7 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - (sr, C.VDI.get_by_name (Debuginfo.to_string di) sr name) + (sr, C.VDI.get_by_name (Debug_info.to_string di) sr name) ) ) with diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index 9ca3660eeb6..b6abfdcd2c3 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -28,13 +28,13 @@ let s_of_sr = Sr.string_of let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute let with_dbg ~name ~dbg f = - Debuginfo.with_dbg ~module_name:"SMAPIv1" ~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 Db_filter_types 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 @@ -53,7 +53,7 @@ let find_vdi ~__context sr vdi = (* Find a VDI reference given a name *) let find_content ~__context ?sr name = (* PR-1255: the backend should do this for us *) - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let expr = Option.fold ~none:True ~some:(fun sr -> @@ -395,7 +395,7 @@ module SMAPIv1 : Server_impl = struct Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> try Sm.sr_scan ~dbg device_config _type sr ; - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let vdis = Db.VDI.get_records_where ~__context ~expr:(Eq (Field "SR", Literal (Ref.string_of sr))) @@ -498,7 +498,7 @@ module SMAPIv1 : Server_impl = struct let epoch_begin _context ~dbg ~sr ~vdi ~vm:_ ~persistent:_ = with_dbg ~name:"VDI.epoch_begin" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try for_vdi ~dbg ~sr ~vdi "VDI.epoch_begin" (fun device_config _type sr self -> @@ -509,7 +509,7 @@ module SMAPIv1 : Server_impl = struct let attach2 _context ~dbg ~dp:_ ~sr ~vdi ~read_write = with_dbg ~name:"VDI.attach2" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try let backend = for_vdi ~dbg ~sr ~vdi "VDI.attach2" @@ -575,7 +575,7 @@ module SMAPIv1 : Server_impl = struct let attach3 context ~dbg ~dp ~sr ~vdi ~vm:_ ~read_write = with_dbg ~name:"VDI.attach3" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in (*Throw away vm argument as does nothing in SMAPIv1*) attach2 context ~dbg ~dp ~sr ~vdi ~read_write @@ -586,7 +586,7 @@ module SMAPIv1 : Server_impl = struct let activate _context ~dbg ~dp ~sr ~vdi = with_dbg ~name:"VDI.activate" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try let read_write = with_lock vdi_read_write_m (fun () -> @@ -616,14 +616,14 @@ module SMAPIv1 : Server_impl = struct let activate3 context ~dbg ~dp ~sr ~vdi ~vm:_ = with_dbg ~name:"VDI.activate3" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in activate context ~dbg ~dp ~sr ~vdi let activate_readonly = activate3 let deactivate _context ~dbg ~dp ~sr ~vdi ~vm:_ = with_dbg ~name:"VDI.deactivate" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try for_vdi ~dbg ~sr ~vdi "VDI.deactivate" (fun device_config _type sr self -> @@ -647,7 +647,7 @@ module SMAPIv1 : Server_impl = struct let detach _context ~dbg ~dp:_ ~sr ~vdi ~vm:_ = with_dbg ~name:"VDI.detach" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try for_vdi ~dbg ~sr ~vdi "VDI.detach" (fun device_config _type sr self -> Sm.vdi_detach ~dbg device_config _type sr self ; @@ -670,7 +670,7 @@ module SMAPIv1 : Server_impl = struct let epoch_end _context ~dbg ~sr ~vdi ~vm:_ = with_dbg ~name:"VDI.epoch_end" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try for_vdi ~dbg ~sr ~vdi "VDI.epoch_end" (fun device_config _type sr self -> @@ -691,19 +691,33 @@ module SMAPIv1 : Server_impl = struct let uuid = require_uuid vi in vdi_info_from_db ~__context (Db.VDI.get_by_uuid ~__context ~uuid) - let create _context ~dbg ~sr ~vdi_info = + let create _context ~dbg ~sr ~(vdi_info : Storage_interface.vdi_info) = with_dbg ~name:"VDI.create" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try Server_helpers.exec_with_new_task "VDI.create" ~subtask_of:(Ref.of_string dbg) (fun __context -> - let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr) in + let sr_uuid = s_of_sr sr in + let sr = Db.SR.get_by_uuid ~__context ~uuid:sr_uuid in let vi = + (* we want to set vdi_uuid when creating a backup VDI with + a specific UUID. SM picks up vdi_uuid instead of creating + a new random UUID; Cf. Xapi_vdi.create *) + let vdi_uuid = + match vdi_info.uuid with + | Some uuid when uuid = Uuidx.(Hash.string sr_uuid |> to_string) + -> + info "%s: creating a backup VDI %s" __FUNCTION__ uuid ; + vdi_info.uuid + | _ -> + None + in Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> - Sm.vdi_create ~dbg device_config _type sr vdi_info.sm_config - vdi_info.ty vdi_info.virtual_size vdi_info.name_label - vdi_info.name_description vdi_info.metadata_of_pool - vdi_info.is_a_snapshot vdi_info.snapshot_time + Sm.vdi_create ~dbg ?vdi_uuid device_config _type sr + vdi_info.sm_config vdi_info.ty vdi_info.virtual_size + vdi_info.name_label vdi_info.name_description + vdi_info.metadata_of_pool vdi_info.is_a_snapshot + vdi_info.snapshot_time (s_of_vdi vdi_info.snapshot_of) vdi_info.read_only ) @@ -722,7 +736,7 @@ module SMAPIv1 : Server_impl = struct let snapshot_and_clone call_name call_f is_a_snapshot _context ~dbg ~sr ~vdi_info = with_dbg ~name:"VDI.snapshot_and_clone" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try Server_helpers.exec_with_new_task call_name ~subtask_of:(Ref.of_string dbg) (fun __context -> @@ -788,7 +802,7 @@ module SMAPIv1 : Server_impl = struct let set_name_label _context ~dbg ~sr ~vdi ~new_name_label = with_dbg ~name:"VDI.set_name_label" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Server_helpers.exec_with_new_task "VDI.set_name_label" ~subtask_of:(Ref.of_string dbg) (fun __context -> let self, _ = find_vdi ~__context sr vdi in @@ -797,7 +811,7 @@ module SMAPIv1 : Server_impl = struct let set_name_description _context ~dbg ~sr ~vdi ~new_name_description = with_dbg ~name:"VDI.set_name_description" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Server_helpers.exec_with_new_task "VDI.set_name_description" ~subtask_of:(Ref.of_string dbg) (fun __context -> let self, _ = find_vdi ~__context sr vdi in @@ -807,7 +821,7 @@ module SMAPIv1 : Server_impl = struct let resize _context ~dbg ~sr ~vdi ~new_size = with_dbg ~name:"VDI.resize" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try let vi = for_vdi ~dbg ~sr ~vdi "VDI.resize" (fun device_config _type sr self -> @@ -832,7 +846,7 @@ module SMAPIv1 : Server_impl = struct let destroy _context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.destroy" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try for_vdi ~dbg ~sr ~vdi "VDI.destroy" (fun device_config _type sr self -> Sm.vdi_delete ~dbg device_config _type sr self @@ -850,7 +864,7 @@ module SMAPIv1 : Server_impl = struct let stat _context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.stat" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try Server_helpers.exec_with_new_task "VDI.stat" ~subtask_of:(Ref.of_string dbg) (fun __context -> @@ -866,7 +880,7 @@ module SMAPIv1 : Server_impl = struct let introduce _context ~dbg ~sr ~uuid ~sm_config ~location = with_dbg ~name:"VDI.introduce" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try Server_helpers.exec_with_new_task "VDI.introduce" ~subtask_of:(Ref.of_string dbg) (fun __context -> @@ -886,7 +900,7 @@ module SMAPIv1 : Server_impl = struct let set_persistent _context ~dbg ~sr ~vdi ~persistent = with_dbg ~name:"VDI.set_persistent" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try Server_helpers.exec_with_new_task "VDI.set_persistent" ~subtask_of:(Ref.of_string dbg) (fun __context -> @@ -916,7 +930,7 @@ module SMAPIv1 : Server_impl = struct let get_by_name _context ~dbg ~sr ~name = with_dbg ~name:"VDI.get_by_name" ~dbg @@ fun di -> info "VDI.get_by_name dbg:%s sr:%s name:%s" di.log (s_of_sr sr) name ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in (* PR-1255: the backend should do this for us *) Server_helpers.exec_with_new_task "VDI.get_by_name" ~subtask_of:(Ref.of_string dbg) (fun __context -> @@ -935,7 +949,7 @@ module SMAPIv1 : Server_impl = struct with_dbg ~name:"VDI.set_content_id" ~dbg @@ fun di -> info "VDI.get_by_content dbg:%s sr:%s vdi:%s content_id:%s" di.log (s_of_sr sr) (s_of_vdi vdi) content_id ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in (* PR-1255: the backend should do this for us *) Server_helpers.exec_with_new_task "VDI.set_content_id" ~subtask_of:(Ref.of_string dbg) (fun __context -> @@ -949,7 +963,7 @@ module SMAPIv1 : Server_impl = struct with_dbg ~name:"VDI.similar_content" ~dbg @@ fun di -> info "VDI.similar_content dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Server_helpers.exec_with_new_task "VDI.similar_content" ~subtask_of:(Ref.of_string dbg) (fun __context -> (* PR-1255: the backend should do this for us. *) @@ -965,7 +979,7 @@ module SMAPIv1 : Server_impl = struct let compare = compare end) in let _vhdparent = "vhd-parent" in - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let all = Db.VDI.get_records_where ~__context ~expr:(Eq (Field "SR", Literal (Ref.string_of sr_ref))) @@ -1061,7 +1075,7 @@ module SMAPIv1 : Server_impl = struct with_dbg ~name:"VDI.compose" ~dbg @@ fun di -> info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" di.log (s_of_sr sr) (s_of_vdi vdi1) (s_of_vdi vdi2) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try Server_helpers.exec_with_new_task "VDI.compose" ~subtask_of:(Ref.of_string dbg) (fun __context -> @@ -1089,7 +1103,7 @@ module SMAPIv1 : Server_impl = struct with_dbg ~name:"VDI.add_to_sm_config" ~dbg @@ fun di -> info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" di.log (s_of_sr sr) (s_of_vdi vdi) key value ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Server_helpers.exec_with_new_task "VDI.add_to_sm_config" ~subtask_of:(Ref.of_string dbg) (fun __context -> let self = find_vdi ~__context sr vdi |> fst in @@ -1100,7 +1114,7 @@ module SMAPIv1 : Server_impl = struct with_dbg ~name:"VDI.remove_from_sm_config" ~dbg @@ fun di -> info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" di.log (s_of_sr sr) (s_of_vdi vdi) key ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Server_helpers.exec_with_new_task "VDI.remove_from_sm_config" ~subtask_of:(Ref.of_string dbg) (fun __context -> let self = find_vdi ~__context sr vdi |> fst in @@ -1110,7 +1124,7 @@ module SMAPIv1 : Server_impl = struct let get_url _context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.get_url" ~dbg @@ fun di -> info "VDI.get_url dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in (* XXX: PR-1255: tapdisk shouldn't hardcode xapi urls *) (* peer_ip/session_ref/vdi_ref *) Server_helpers.exec_with_new_task "VDI.get_url" @@ -1131,7 +1145,7 @@ module SMAPIv1 : Server_impl = struct let call_cbt_function _context ~f ~f_name ~dbg ~sr ~vdi = with_dbg ~name:"VDI.call_cbt_function" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try for_vdi ~dbg ~sr ~vdi f_name (fun device_config _type sr self -> f ~dbg device_config _type sr self @@ -1163,7 +1177,7 @@ module SMAPIv1 : Server_impl = struct let list_changed_blocks _context ~dbg ~sr ~vdi_from ~vdi_to = with_dbg ~name:"VDI.list_changed_blocks" ~dbg @@ fun di -> - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in try Server_helpers.exec_with_new_task "VDI.list_changed_blocks" ~subtask_of:(Ref.of_string dbg) (fun __context -> diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index b3d748c7ad0..8fde6ec60bd 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -93,8 +93,8 @@ let indent x = " " ^ x let string_of_date x = Date.to_string (Date.of_float x) let with_dbg ~name ~dbg f = - Debuginfo.with_dbg ~with_thread:true ~module_name:"SMAPIv1-Wrapper" ~name ~dbg - f + Debug_info.with_dbg ~with_thread:true ~module_name:"SMAPIv1-Wrapper" ~name + ~dbg f let rpc_fns keyty valty = let rpc_of hashtbl = @@ -589,7 +589,7 @@ functor with_dbg ~name:"VDI.epoch_begin" ~dbg @@ fun di -> info "VDI.epoch_begin dbg:%s sr:%s vdi:%s vm:%s persistent:%b" di.log (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) persistent ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked (fun () -> @@ -601,7 +601,7 @@ functor with_dbg ~name:"VDI.attach3" ~dbg @@ fun di -> info "VDI.attach3 dbg:%s dp:%s sr:%s vdi:%s vm:%s read_write:%b" di.log dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) read_write ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked (fun () -> @@ -625,7 +625,7 @@ functor (s_of_sr sr) (s_of_vdi vdi) read_write ; (*Support calls from older XAPI during migrate operation (dom 0 attach )*) let vm = vm_of_s "0" in - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in attach3 context ~dbg ~dp ~sr ~vdi ~vm ~read_write let attach context ~dbg ~dp ~sr ~vdi ~read_write = @@ -633,7 +633,7 @@ functor info "VDI.attach dbg:%s dp:%s sr:%s vdi:%s read_write:%b" di.log dp (s_of_sr sr) (s_of_vdi vdi) read_write ; let vm = vm_of_s "0" in - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in let backend = attach3 context ~dbg ~dp ~sr ~vdi ~vm ~read_write in (* VDI.attach2 should be used instead, VDI.attach is only kept for backwards-compatibility, because older xapis call Remote.VDI.attach during SXM. @@ -677,7 +677,7 @@ functor with_dbg ~name:"VDI.activate3" ~dbg @@ fun di -> info "VDI.activate3 dbg:%s dp:%s sr:%s vdi:%s vm:%s" di.log dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked (fun () -> @@ -696,14 +696,14 @@ functor (s_of_vdi vdi) ; (*Support calls from older XAPI during migrate operation (dom 0 attach )*) let vm = vm_of_s "0" in - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in activate3 context ~dbg ~dp ~sr ~vdi ~vm let deactivate context ~dbg ~dp ~sr ~vdi ~vm = with_dbg ~name:"VDI.deactivate" ~dbg @@ fun di -> info "VDI.deactivate dbg:%s dp:%s sr:%s vdi:%s vm:%s" di.log dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked (fun () -> @@ -718,7 +718,7 @@ functor with_dbg ~name:"VDI.detach" ~dbg @@ fun di -> info "VDI.detach dbg:%s dp:%s sr:%s vdi:%s vm:%s" di.log dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked (fun () -> @@ -733,7 +733,7 @@ functor with_dbg ~name:"VDI.epoch_end" ~dbg @@ fun di -> info "VDI.epoch_end dbg:%s sr:%s vdi:%s vm:%s" di.log (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked (fun () -> Impl.VDI.epoch_end context ~dbg ~sr ~vdi ~vm @@ -744,7 +744,7 @@ functor with_dbg ~name:"VDI.create" ~dbg @@ fun di -> info "VDI.create dbg:%s sr:%s vdi_info:%s" di.log (s_of_sr sr) (string_of_vdi_info vdi_info) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in let result = Impl.VDI.create context ~dbg ~sr ~vdi_info in match result with | {virtual_size= virtual_size'; _} @@ -770,7 +770,7 @@ functor with_dbg ~name:call_name ~dbg @@ fun di -> info "%s dbg:%s sr:%s vdi_info:%s" call_name di.log (s_of_sr sr) (string_of_vdi_info vdi_info) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi_info.vdi (fun () -> call_f context ~dbg ~sr ~vdi_info) let snapshot = snapshot_and_clone "VDI.snapshot" Impl.VDI.snapshot @@ -781,7 +781,7 @@ functor with_dbg ~name:"VDI.set_name_label" ~dbg @@ fun di -> info "VDI.set_name_label dbg:%s sr:%s vdi:%s new_name_label:%s" di.log (s_of_sr sr) (s_of_vdi vdi) new_name_label ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> Impl.VDI.set_name_label context ~dbg ~sr ~vdi ~new_name_label ) @@ -791,7 +791,7 @@ functor info "VDI.set_name_description dbg:%s sr:%s vdi:%s new_name_description:%s" di.log (s_of_sr sr) (s_of_vdi vdi) new_name_description ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> Impl.VDI.set_name_description context ~dbg ~sr ~vdi ~new_name_description @@ -801,7 +801,7 @@ functor with_dbg ~name:"VDI.resize" ~dbg @@ fun di -> info "VDI.resize dbg:%s sr:%s vdi:%s new_size:%Ld" di.log (s_of_sr sr) (s_of_vdi vdi) new_size ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> Impl.VDI.resize context ~dbg ~sr ~vdi ~new_size ) @@ -810,7 +810,7 @@ functor with_dbg ~name:call_name ~dbg @@ fun di -> info "%s dbg:%s sr:%s vdi:%s" call_name di.log (s_of_sr sr) (s_of_vdi vdi) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi Vdi.all (fun () -> call_f context ~dbg ~sr ~vdi @@ -825,7 +825,7 @@ functor let stat context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.stat" ~dbg @@ fun di -> info "VDI.stat dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.stat context ~dbg ~sr ~vdi let introduce context ~dbg ~sr ~uuid ~sm_config ~location = @@ -834,14 +834,14 @@ functor di.log (s_of_sr sr) uuid (String.concat ", " (List.map (fun (k, v) -> k ^ ":" ^ v) sm_config)) location ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.introduce context ~dbg ~sr ~uuid ~sm_config ~location let set_persistent context ~dbg ~sr ~vdi ~persistent = with_dbg ~name:"VDI.set_persistent" ~dbg @@ fun di -> info "VDI.set_persistent dbg:%s sr:%s vdi:%s persistent:%b" di.log (s_of_sr sr) (s_of_vdi vdi) persistent ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> Impl.VDI.set_persistent context ~dbg ~sr ~vdi ~persistent ) @@ -849,62 +849,62 @@ functor let get_by_name context ~dbg ~sr ~name = with_dbg ~name:"VDI.get_by_name" ~dbg @@ fun di -> info "VDI.get_by_name dbg:%s sr:%s name:%s" di.log (s_of_sr sr) name ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.get_by_name context ~dbg ~sr ~name let set_content_id context ~dbg ~sr ~vdi ~content_id = with_dbg ~name:"VDI.set_content_id" ~dbg @@ fun di -> info "VDI.set_content_id dbg:%s sr:%s vdi:%s content_id:%s" di.log (s_of_sr sr) (s_of_vdi vdi) content_id ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.set_content_id context ~dbg ~sr ~vdi ~content_id let similar_content context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.similar_content" ~dbg @@ fun di -> info "VDI.similar_content dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.similar_content context ~dbg ~sr ~vdi let compose context ~dbg ~sr ~vdi1 ~vdi2 = with_dbg ~name:"VDI.compose" ~dbg @@ fun di -> info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" di.log (s_of_sr sr) (s_of_vdi vdi1) (s_of_vdi vdi2) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.compose context ~dbg ~sr ~vdi1 ~vdi2 let add_to_sm_config context ~dbg ~sr ~vdi ~key ~value = with_dbg ~name:"VDI.add_to_sm_config" ~dbg @@ fun di -> info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" di.log (s_of_sr sr) (s_of_vdi vdi) key value ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.add_to_sm_config context ~dbg ~sr ~vdi ~key ~value let remove_from_sm_config context ~dbg ~sr ~vdi ~key = with_dbg ~name:"VDI.remove_from_sm_config" ~dbg @@ fun di -> info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" di.log (s_of_sr sr) (s_of_vdi vdi) key ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.remove_from_sm_config context ~dbg ~sr ~vdi ~key let get_url context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.get_url" ~dbg @@ fun di -> info "VDI.get_url dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.VDI.get_url context ~dbg ~sr ~vdi let enable_cbt context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.enabled_cbt" ~dbg @@ fun di -> info "VDI.enable_cbt dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> Impl.VDI.enable_cbt context ~dbg ~sr ~vdi) let disable_cbt context ~dbg ~sr ~vdi = with_dbg ~name:"VDI.disable_cbt" ~dbg @@ fun di -> info "VDI.disable_cbt dbg:%s sr:%s vdi:%s" di.log (s_of_sr sr) (s_of_vdi vdi) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi (fun () -> Impl.VDI.disable_cbt context ~dbg ~sr ~vdi) (** The [sr] parameter is the SR of VDI [vdi_to]. *) @@ -912,7 +912,7 @@ functor with_dbg ~name:"VDI.list_changed_blocks" ~dbg @@ fun di -> info "VDI.list_changed_blocks dbg:%s sr:%s vdi_from:%s vdi_to:%s" di.log (s_of_sr sr) (s_of_vdi vdi_from) (s_of_vdi vdi_to) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_vdi sr vdi_to (fun () -> Impl.VDI.list_changed_blocks context ~dbg ~sr ~vdi_from ~vdi_to ) @@ -921,7 +921,7 @@ functor let get_by_name context ~dbg ~name = with_dbg ~name:"get_by_name" ~dbg @@ fun di -> debug "get_by_name dbg:%s name:%s" di.log name ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.get_by_name context ~dbg ~name module DATA = struct @@ -1107,7 +1107,7 @@ functor with_dbg ~name:"DP.destroy2" ~dbg @@ fun di -> info "DP.destroy2 dbg:%s dp:%s sr:%s vdi:%s vm:%s allow_leak:%b" di.log dp (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) allow_leak ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in destroy' context ~dbg ~dp ~allow_leak let diagnostics _context () = @@ -1183,7 +1183,7 @@ functor let probe context ~dbg ~queue ~device_config ~sm_config = with_dbg ~name:"SR.probe" ~dbg @@ fun di -> info "SR.probe dbg:%s" di.log ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.SR.probe context ~dbg ~queue ~device_config ~sm_config let list _context ~dbg = @@ -1194,7 +1194,7 @@ functor let stat context ~dbg ~sr = with_dbg ~name:"SR.stat" ~dbg @@ fun di -> info "SR.stat dbg:%s sr:%s" di.log (s_of_sr sr) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_sr sr (fun () -> match Host.find sr !Host.host with | None -> @@ -1206,7 +1206,7 @@ functor let scan context ~dbg ~sr = with_dbg ~name:"SR.scan" ~dbg @@ fun di -> info "SR.scan dbg:%s sr:%s" di.log (s_of_sr sr) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_sr sr (fun () -> match Host.find sr !Host.host with | None -> @@ -1220,7 +1220,7 @@ functor with_dbg ~name:"SR.create" ~dbg @@ fun di -> info "SR.create dbg:%s sr:%s name_label:%s" di.log (s_of_sr sr) name_label ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_sr sr (fun () -> match Host.find sr !Host.host with | None -> @@ -1235,14 +1235,14 @@ functor with_dbg ~name:"SR.set_name_label" ~dbg @@ fun di -> info "SR.set_name_label dbg:%s sr:%s new_name_label:%s" di.log (s_of_sr sr) new_name_label ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.SR.set_name_label context ~dbg ~sr ~new_name_label let set_name_description context ~dbg ~sr ~new_name_description = with_dbg ~name:"SR.set_name_description" ~dbg @@ fun di -> info "SR.set_name_description dbg:%s sr:%s new_name_description:%s" di.log (s_of_sr sr) new_name_description ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.SR.set_name_description context ~dbg ~sr ~new_name_description let attach context ~dbg ~sr ~device_config = @@ -1271,7 +1271,7 @@ functor in info "SR.attach dbg:%s sr:%s device_config:[%s]" di.log (s_of_sr sr) device_config_str ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in with_sr sr (fun () -> match Host.find sr !Host.host with | None -> @@ -1321,7 +1321,7 @@ functor let detach context ~dbg ~sr = with_dbg ~name:"SR.detach" ~dbg @@ fun di -> info "SR.detach dbg:%s sr:%s" di.log (s_of_sr sr) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in detach_destroy_common context ~dbg ~sr Impl.SR.detach let reset _context ~dbg ~sr = @@ -1336,7 +1336,7 @@ functor let destroy context ~dbg ~sr = with_dbg ~name:"SR.destroy" ~dbg @@ fun di -> info "SR.destroy dbg:%s sr:%s" di.log (s_of_sr sr) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in detach_destroy_common context ~dbg ~sr Impl.SR.destroy let update_snapshot_info_src context ~dbg ~sr ~vdi ~url ~dest ~dest_vdi @@ -1356,7 +1356,7 @@ functor |> String.concat "; " |> Printf.sprintf "[%s]" ) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.SR.update_snapshot_info_src context ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs @@ -1376,7 +1376,7 @@ functor |> String.concat "; " |> Printf.sprintf "[%s]" ) ; - let dbg = Debuginfo.to_string di in + let dbg = Debug_info.to_string di in Impl.SR.update_snapshot_info_dest context ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs end diff --git a/ocaml/xapi/stream_vdi.ml b/ocaml/xapi/stream_vdi.ml index 64b1da93eee..3c27d158af3 100644 --- a/ocaml/xapi/stream_vdi.ml +++ b/ocaml/xapi/stream_vdi.ml @@ -163,6 +163,31 @@ let get_nbd_device path = else None +(* Copied from vhd-tool/src/image.ml. + * Just keep the situation of xapi doesn't depend on vhd-tool OCaml module. + *) +let image_behind_nbd_device = function + | Some (path, _exportname) as image -> + (* The nbd server path exposed by tapdisk can lead us to the actual image + file below. Following the symlink gives a path like + `/run/blktap-control/nbd.`, + containing the tapdisk pid and minor number. Using this information, + we can get the file path from tap-ctl. + *) + let default _ _ = image in + let filename = Unix.realpath path |> Filename.basename in + Scanf.ksscanf filename default "nbd%d.%d" (fun pid minor -> + match Tapctl.find (Tapctl.create ()) ~pid ~minor with + | _, _, Some ("vhd", vhd) -> + Some ("vhd", vhd) + | _, _, Some ("aio", vhd) -> + Some ("raw", vhd) + | _, _, _ | (exception _) -> + None + ) + | _ -> + None + type extent = {flags: int32; length: int64} [@@deriving rpc] type extent_list = extent list [@@deriving rpc] diff --git a/ocaml/xapi/sync_networking.ml b/ocaml/xapi/sync_networking.ml index fb0d9ed9ec6..6046a14782f 100644 --- a/ocaml/xapi/sync_networking.ml +++ b/ocaml/xapi/sync_networking.ml @@ -13,7 +13,6 @@ *) open Client -open Db_filter_types module D = Debug.Make (struct let name = "sync_networking" end) diff --git a/ocaml/xapi/vhd_tool_wrapper.ml b/ocaml/xapi/vhd_tool_wrapper.ml index 7e22dc86597..ee1151febb5 100644 --- a/ocaml/xapi/vhd_tool_wrapper.ml +++ b/ocaml/xapi/vhd_tool_wrapper.ml @@ -117,7 +117,7 @@ let receive progress_cb format protocol (s : Unix.file_descr) the driver domain corresponding to the frontend device [path] in this domain. *) let find_backend_device path = try - let open Xenstore in + let open Ezxenstore_core.Xenstore in (* If we're looking at a xen frontend device, see if the backend is in the same domain. If so check if it looks like a .vhd *) let rdev = (Unix.stat path).Unix.st_rdev in @@ -170,9 +170,16 @@ let vhd_of_device path = | _, _, _ -> raise Not_found with - | Tapctl.Not_blktap -> + | Tapctl.Not_blktap -> ( debug "Device %s is not controlled by blktap" path ; - None + (* Check if it is a VHD behind a NBD deivce *) + Stream_vdi.(get_nbd_device path |> image_behind_nbd_device) |> function + | Some ("vhd", vhd) -> + debug "%s is a VHD behind NBD device %s" vhd path ; + Some vhd + | _ -> + None + ) | Tapctl.Not_a_device -> debug "%s is not a device" path ; None @@ -186,15 +193,18 @@ let send progress_cb ?relative_to (protocol : string) (dest_format : string) (s : Unix.file_descr) (path : string) (size : Int64.t) (prefix : string) = let s' = Uuidx.(to_string (make ())) in let source_format, source = - match (Stream_vdi.get_nbd_device path, vhd_of_device path) with - | Some (nbd_server, exportname), _ -> + match (Stream_vdi.get_nbd_device path, vhd_of_device path, relative_to) with + | Some (nbd_server, exportname), _, None -> ( "nbdhybrid" , Printf.sprintf "%s:%s:%s:%Ld" path nbd_server exportname size ) - | None, Some vhd -> + | Some _, Some vhd, Some _ | None, Some vhd, _ -> ("hybrid", path ^ ":" ^ vhd) - | None, None -> + | None, None, None -> ("raw", path) + | _, None, Some _ -> + let msg = "Cannot compute differences on non-VHD images" in + error "%s" msg ; failwith msg in let relative_to = match relative_to with diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index ac65142e0c6..105fd9db581 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -25,7 +25,9 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally open Auth_signature open Extauth -open Db_filter_types +open Xapi_database +open Xapi_database.Db_filter_types +open Xapi_database.Db_cache_types module D = Debug.Make (struct let name = "xapi" end) @@ -62,8 +64,6 @@ let database_ready_for_clients = ref false (* while this is false, client calls will be blocked *) -open Db_cache_types - (** Populate the database from the default connections or the restore db file (if it is present). Perform an initial flush to the database connections which were already setup, then delete the restore file. *) diff --git a/ocaml/xapi/xapi_bond.ml b/ocaml/xapi/xapi_bond.ml index 0a78bef2501..20764394b36 100644 --- a/ocaml/xapi/xapi_bond.ml +++ b/ocaml/xapi/xapi_bond.ml @@ -14,7 +14,7 @@ module D = Debug.Make (struct let name = "xapi_bond" end) open D -open Db_filter_types +open Xapi_database.Db_filter_types (* Returns the name of a new bond device, which is the string "bond" followed * by the smallest integer > 0 that does not yet appear in a bond name on this host. *) diff --git a/ocaml/xapi/xapi_cluster_host.ml b/ocaml/xapi/xapi_cluster_host.ml index f026e782f2e..17c87419bdd 100644 --- a/ocaml/xapi/xapi_cluster_host.ml +++ b/ocaml/xapi/xapi_cluster_host.ml @@ -417,7 +417,7 @@ let sync_required ~__context ~host = None | [(cluster_ref, cluster_rec)] -> ( let expr = - Db_filter_types.( + Xapi_database.Db_filter_types.( And ( Eq (Field "host", Literal (Ref.string_of host)) , Eq (Field "cluster", Literal (Ref.string_of cluster_ref)) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index f9a78fef05f..dca5efdd986 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -52,7 +52,7 @@ let pif_of_host ~__context (network : API.ref_network) (host : API.ref_host) = let pifs = Db.PIF.get_records_where ~__context ~expr: - Db_filter_types.( + Xapi_database.Db_filter_types.( And ( Eq (Literal (Ref.string_of host), Field "host") , Eq (Literal (Ref.string_of network), Field "network") @@ -118,10 +118,12 @@ let handle_error = function failwith ("Unix Error: " ^ message) let assert_cluster_host_can_be_created ~__context ~host = - match - Db.Cluster_host.get_refs_where ~__context - ~expr:Db_filter_types.(Eq (Literal (Ref.string_of host), Field "host")) - with + let expr = + Xapi_database.Db_filter_types.( + Eq (Literal (Ref.string_of host), Field "host") + ) + in + match Db.Cluster_host.get_refs_where ~__context ~expr with | [] -> () | _ -> @@ -137,10 +139,10 @@ let assert_cluster_host_can_be_created ~__context ~host = [get_required_cluster_stacks context sr_sm_type] should be configured and running for SRs of type [sr_sm_type] to work. *) let get_required_cluster_stacks ~__context ~sr_sm_type = - let sms_matching_sr_type = - Db.SM.get_records_where ~__context - ~expr:Db_filter_types.(Eq (Field "type", Literal sr_sm_type)) + let expr = + Xapi_database.Db_filter_types.(Eq (Field "type", Literal sr_sm_type)) in + let sms_matching_sr_type = Db.SM.get_records_where ~__context ~expr in sms_matching_sr_type |> List.map (fun (_sm_ref, sm_rec) -> sm_rec.API.sM_required_cluster_stack) (* We assume that we only have one SM for each SR type, so this is only to satisfy type checking *) @@ -166,10 +168,12 @@ let with_clustering_lock_if_cluster_exists ~__context where f = with_clustering_lock where f let find_cluster_host ~__context ~host = - match - Db.Cluster_host.get_refs_where ~__context - ~expr:Db_filter_types.(Eq (Field "host", Literal (Ref.string_of host))) - with + let expr = + Xapi_database.Db_filter_types.( + Eq (Field "host", Literal (Ref.string_of host)) + ) + in + match Db.Cluster_host.get_refs_where ~__context ~expr with | [ref] -> Some ref | _ :: _ -> diff --git a/ocaml/xapi/xapi_db_upgrade.ml b/ocaml/xapi/xapi_db_upgrade.ml index 05f20f083e7..b9ecf94ba01 100644 --- a/ocaml/xapi/xapi_db_upgrade.ml +++ b/ocaml/xapi/xapi_db_upgrade.ml @@ -488,7 +488,7 @@ let remove_vmpp = (fun ~__context -> let vmpps = Db.VMPP.get_all ~__context in List.iter (fun self -> Db.VMPP.destroy ~__context ~self) vmpps ; - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let vms = Db.VM.get_refs_where ~__context ~expr: @@ -938,9 +938,10 @@ let rules = (* Maybe upgrade most recent db *) let maybe_upgrade ~__context = let db_ref = Context.database_of __context in + let open Xapi_database in let db = Db_ref.get_database db_ref in let ((previous_major_vsn, previous_minor_vsn) as previous_vsn) = - Db_cache_types.Manifest.schema (Db_cache_types.Database.manifest db) + Db_cache_types.(Manifest.schema (Database.manifest db)) in let ((latest_major_vsn, latest_minor_vsn) as latest_vsn) = (Datamodel_common.schema_major_vsn, Datamodel_common.schema_minor_vsn) diff --git a/ocaml/xapi/xapi_diagnostics.ml b/ocaml/xapi/xapi_diagnostics.ml index 4c709f0d055..c765867a987 100644 --- a/ocaml/xapi/xapi_diagnostics.ml +++ b/ocaml/xapi/xapi_diagnostics.ml @@ -1,11 +1,11 @@ (* Copyright (C) Citrix Systems Inc. - + This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; version 2.1 only. with the special exception on linking described in file LICENSE. - + This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @@ -36,7 +36,7 @@ let gc_stats ~__context ~host:_ = let db_stats ~__context = (* Use Printf.sprintf to keep format *) - let n, avgtime, min, max = Db_lock.report () in + let n, avgtime, min, max = Xapi_database.Db_lock.report () in [ ("n", Printf.sprintf "%d" n) ; ("avgtime", Printf.sprintf "%f" avgtime) diff --git a/ocaml/xapi/xapi_dr.ml b/ocaml/xapi/xapi_dr.ml index e9c1c53ad0c..b2f80481324 100644 --- a/ocaml/xapi/xapi_dr.ml +++ b/ocaml/xapi/xapi_dr.ml @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -open Db_cache_types +open Xapi_database.Db_cache_types let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute @@ -25,7 +25,8 @@ open D (* Keep track of foreign metadata VDIs and their database generations and pool UUIDs. *) (* The generation count is used to keep track of metadata_latest of all foreign database VDIs. *) (* The pool uuid is cached so that "xe pool-param-get param-name=metadata-of-pool" can be called without opening the database. *) -let db_vdi_cache : (API.ref_VDI, Generation.t * string) Hashtbl.t = +let db_vdi_cache : (API.ref_VDI, Xapi_database.Generation.t * string) Hashtbl.t + = Hashtbl.create 10 let db_vdi_cache_mutex = Mutex.create () @@ -101,7 +102,7 @@ let update_metadata_latest ~__context = vdis_grouped_by_pool let read_database_generation ~db_ref = - let db = Db_ref.get_database db_ref in + let db = Xapi_database.Db_ref.get_database db_ref in let manifest = Database.manifest db in Manifest.generation manifest @@ -245,6 +246,7 @@ let create_import_objects ~__context ~vms = List.iter (Export.update_table ~__context ~include_snapshots:true ~preserve_power_state:true ~include_vhd_parents:false ~table + ~excluded_devices:[] ) vms ; Export.make_all ~with_snapshot_metadata:true ~preserve_power_state:true table diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 5e10d5590a1..4c6a5eac959 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -338,6 +338,7 @@ module From = struct let calls : (API.ref_session, call list) Hashtbl.t = Hashtbl.create 10 let get_current_event_number () = + let open Xapi_database in Db_cache_types.Manifest.generation (Db_cache_types.Database.manifest (Db_ref.get_database (Db_backend.make ())) @@ -507,6 +508,7 @@ let rec next ~__context = rpc_of_events relevant let from_inner __context session subs from from_t deadline = + let open Xapi_database in let open From in (* The database tables involved in our subscription *) let tables = @@ -730,7 +732,8 @@ let from ~__context ~classes ~token ~timeout = let get_current_id ~__context = with_lock Next.m (fun () -> !Next.id) let inject ~__context ~_class ~_ref = - let open Db_cache_types in + let open Xapi_database in + let open Xapi_database.Db_cache_types in let generation : int64 = Db_lock.with_lock (fun () -> let db_ref = Db_backend.make () in @@ -780,13 +783,13 @@ let event_add ?snapshot ty op reference = From.add ev ; Next.add ev ) -let register_hooks () = Db_action_helper.events_register event_add +let register_hooks () = Xapi_database.Db_action_helper.events_register event_add (* Called whenever a session is being destroyed i.e. by Session.logout and db_gc *) let on_session_deleted session_id = (* Unregister this session if is associated with in imported DB. *) (* FIXME: this doesn't logically belong in the event code *) - Db_backend.unregister_session (Ref.string_of session_id) ; + Xapi_database.Db_backend.unregister_session (Ref.string_of session_id) ; Next.on_session_deleted session_id ; From.on_session_deleted session_id @@ -795,7 +798,7 @@ let on_session_deleted session_id = 2. allow the server to detect when a client has failed *) let heartbeat ~__context = try - Db_lock.with_lock (fun () -> + Xapi_database.Db_lock.with_lock (fun () -> (* We must hold the database lock since we are sending an update for a real object and we don't want to accidentally transmit an older snapshot. *) let pool = try Some (Helpers.get_pool ~__context) with _ -> None in diff --git a/ocaml/xapi/xapi_fuse.ml b/ocaml/xapi/xapi_fuse.ml index bb318848fbd..48d0737a613 100644 --- a/ocaml/xapi/xapi_fuse.ml +++ b/ocaml/xapi/xapi_fuse.ml @@ -55,6 +55,7 @@ let light_fuse_and_run ?(fuse_length = !Constants.fuse_time) () = ignore (Thread.create (fun () -> + let open Xapi_database in Thread.delay new_fuse_length ; debug "light_fuse_and_run: calling flush and exit" ; (* CA-16368: If the database hasn't been initialised *at all* we can exit immediately. @@ -112,6 +113,7 @@ let light_fuse_and_dont_restart ?(fuse_length = !Constants.fuse_time) () = ignore (Thread.create (fun () -> + let open Xapi_database in debug "light_fuse_and_dont_restart: calling Rrdd.backup_rrds to save \ current RRDs locally" ; diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 37e9f561537..f58cb35757b 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -20,6 +20,8 @@ module StringSet = Set.Make (String) module D = Debug.Make (struct let name = "xapi_globs" end) +module Db_globs = Xapi_database.Db_globs + (* set this to true to enable XSM to out-of-pool SRs with matching UUID *) let relax_xsm_sr_check = ref true diff --git a/ocaml/xapi/xapi_ha.ml b/ocaml/xapi/xapi_ha.ml index ee8253e17b6..2295651ed05 100644 --- a/ocaml/xapi/xapi_ha.ml +++ b/ocaml/xapi/xapi_ha.ml @@ -31,8 +31,9 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute open Client -open Db_filter_types +open Xapi_database.Db_filter_types open Xha_scripts +module Redo_log = Xapi_database.Redo_log (* Create a redo_log instance to use for HA. *) let ha_redo_log = @@ -926,7 +927,7 @@ let redo_log_ha_enabled_during_runtime __context = ) else ( info "Switching on HA redo log." ; Redo_log.enable_and_flush - (Context.database_of __context |> Db_ref.get_database) + (Context.database_of __context |> Xapi_database.Db_ref.get_database) ha_redo_log Xapi_globs.ha_metadata_vdi_reason (* upon the first attempt to write a delta, it will realise that a DB flush * is necessary as the I/O process will not be running *) @@ -958,8 +959,9 @@ let redo_log_ha_enabled_at_startup () = debug "This node is a master; attempting to extract a database from a metadata \ VDI" ; - let db_ref = Db_backend.make () in - Redo_log_usage.read_from_redo_log ha_redo_log Db_globs.ha_metadata_db db_ref + let db_ref = Xapi_database.Db_backend.make () in + Redo_log_usage.read_from_redo_log ha_redo_log + Xapi_database.Db_globs.ha_metadata_db db_ref (* best effort only: does not raise any exceptions *) ) @@ -1759,8 +1761,6 @@ let disable __context = raise (Api_errors.Server_error (Api_errors.ha_not_enabled, [])) ; disable_internal __context -open Db_cache_types (* for the Manifest. Database. functions below *) - let enable __context heartbeat_srs configuration = debug "Enabling HA on the Pool." ; let pool = Helpers.get_pool ~__context in @@ -1984,6 +1984,8 @@ let enable __context heartbeat_srs configuration = (* ... *) (* Make sure everyone's got a fresh database *) let generation = + let open Xapi_database in + let open Xapi_database.Db_cache_types in Db_lock.with_lock (fun () -> Manifest.generation (Database.manifest (Db_ref.get_database (Db_backend.make ()))) diff --git a/ocaml/xapi/xapi_ha.mli b/ocaml/xapi/xapi_ha.mli index d6967db9807..ddf583d6cb8 100644 --- a/ocaml/xapi/xapi_ha.mli +++ b/ocaml/xapi/xapi_ha.mli @@ -15,7 +15,7 @@ (** Functions for implementing 'High Availability' (HA). @group High Availability (HA) *) -val ha_redo_log : [`RW] Redo_log.redo_log +val ha_redo_log : [`RW] Xapi_database.Redo_log.redo_log (** The redo log instance used for HA *) (******************************************************************************) diff --git a/ocaml/xapi/xapi_hooks.ml b/ocaml/xapi/xapi_hooks.ml index 7a2e2bd3b7e..abb29dd4f52 100644 --- a/ocaml/xapi/xapi_hooks.ml +++ b/ocaml/xapi/xapi_hooks.ml @@ -128,7 +128,7 @@ let internal_host_dead_hook __context host = info "Running host dead hook for %s" (Ref.string_of host) ; (* reverse lookup host from metrics id; don't have backedge here... *) let forwarded_tasks = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in Db.Task.get_refs_where ~__context ~expr:(Eq (Field "forwarded_to", Literal (Ref.string_of host))) in diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 768f33aba7b..4d5872aa5ca 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -21,7 +21,7 @@ let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute module Unixext = Xapi_stdext_unix.Unixext open Xapi_host_helpers open Xapi_pif_helpers -open Db_filter_types +open Xapi_database.Db_filter_types open Workload_balancing module D = Debug.Make (struct let name = "xapi_host" end) @@ -1196,6 +1196,7 @@ let request_backup ~__context ~host ~generation ~force = if Helpers.get_localhost ~__context <> host then failwith "Forwarded to the wrong host" ; if Pool_role.is_master () then ( + let open Xapi_database in debug "Requesting database backup on master: Using direct sync" ; let connections = Db_conn_store.read_db_connections () in Db_cache_impl.sync connections (Db_ref.get_database (Db_backend.make ())) @@ -1331,7 +1332,8 @@ let get_thread_diagnostics ~__context ~host:_ = let sm_dp_destroy ~__context ~host:_ ~dp ~allow_leak = Storage_access.dp_destroy ~__context dp allow_leak -let get_diagnostic_timing_stats ~__context ~host:_ = Stats.summarise () +let get_diagnostic_timing_stats ~__context ~host:_ = + Xapi_database.Stats.summarise () (* CP-825: Serialize execution of host-enable-extauth and host-disable-extauth *) (* We need to protect against concurrent execution of the extauth-hook script and host.enable/disable extauth, *) @@ -1966,6 +1968,8 @@ let disable_external_auth ~__context ~host ~config = disable_external_auth_common ~during_pool_eject:false ~__context ~host ~config () +module Static_vdis_list = Xapi_database.Static_vdis_list + let attach_static_vdis ~__context ~host:_ ~vdi_reason_map = (* We throw an exception immediately if any of the VDIs in vdi_reason_map is a changed block tracking metadata VDI. *) diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 040f5782273..dcac8edc5ce 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -19,26 +19,14 @@ module D = Debug.Make (struct let name = "xapi_host_helpers" end) open D module Unixext = Xapi_stdext_unix.Unixext -open Db_filter_types +open Xapi_database.Db_filter_types open Record_util (* for host_operation_to_string *) let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute let finally = Xapi_stdext_pervasives.Pervasiveext.finally -let all_operations = - [ - `provision - ; `evacuate - ; `reboot - ; `shutdown - ; `vm_start - ; `vm_resume - ; `vm_migrate - ; `power_on - ; `apply_updates - ; `enable - ] +let all_operations = API.host_allowed_operations__all (** Returns a table of operations -> API error options (None if the operation would be ok) *) let valid_operations ~__context record _ref' = diff --git a/ocaml/xapi/xapi_message.ml b/ocaml/xapi/xapi_message.ml index 2d44962d720..95702a49515 100644 --- a/ocaml/xapi/xapi_message.ml +++ b/ocaml/xapi/xapi_message.ml @@ -331,6 +331,7 @@ let write ~__context ~_ref ~message = gen in let gen = ref 0L in + let open Xapi_database in Db_lock.with_lock (fun () -> let t = Context.database_of __context in Db_ref.update_database t (fun db -> @@ -450,7 +451,8 @@ let create ~__context ~name ~priority ~cls ~obj_uuid ~body = (* Return the message ref, or Ref.null if the message wasn't written *) match gen with Some _ -> _ref | None -> Ref.null -let deleted : (Generation.t * API.ref_message) list ref = ref [(0L, Ref.null)] +let deleted : (Xapi_database.Generation.t * API.ref_message) list ref = + ref [(0L, Ref.null)] let ndeleted = ref 1 @@ -469,6 +471,7 @@ let destroy_real __context basefilename = Unixext.unlink_safe filename ; let rpc = API.rpc_of_message_t message in let gen = ref 0L in + let open Xapi_database in Db_lock.with_lock (fun () -> let t = Context.database_of __context in Db_ref.update_database t (fun db -> diff --git a/ocaml/xapi/xapi_network.ml b/ocaml/xapi/xapi_network.ml index 59686f9fa7d..bb641e980c2 100644 --- a/ocaml/xapi/xapi_network.ml +++ b/ocaml/xapi/xapi_network.ml @@ -327,7 +327,7 @@ let create_new_blob ~__context ~network ~name ~mime_type ~public = let set_default_locking_mode ~__context ~network ~value = (* Get all VIFs which are attached and associated with this network. *) - let open Db_filter_types in + let open Xapi_database.Db_filter_types in match Db.VIF.get_records_where ~__context ~expr: diff --git a/ocaml/xapi/xapi_network_attach_helpers.ml b/ocaml/xapi/xapi_network_attach_helpers.ml index b28013d5892..4a3f64b3c38 100644 --- a/ocaml/xapi/xapi_network_attach_helpers.ml +++ b/ocaml/xapi/xapi_network_attach_helpers.ml @@ -15,7 +15,7 @@ module D = Debug.Make (struct let name = "xapi_network_attach_helpers" end) open D -open Db_filter_types +open Xapi_database.Db_filter_types let assert_network_has_no_vifs_in_use_on_me ~__context ~host ~network = (* Check if there are any active VIFs on VMs resident on me *) diff --git a/ocaml/xapi/xapi_network_sriov_helpers.ml b/ocaml/xapi/xapi_network_sriov_helpers.ml index 1e14ff277c1..952a7c35270 100644 --- a/ocaml/xapi/xapi_network_sriov_helpers.ml +++ b/ocaml/xapi/xapi_network_sriov_helpers.ml @@ -13,7 +13,7 @@ *) open Network -open Db_filter_types +open Xapi_database.Db_filter_types open Xapi_stdext_std module D = Debug.Make (struct let name = "xapi_network_sriov" end) diff --git a/ocaml/xapi/xapi_observer.ml b/ocaml/xapi/xapi_observer.ml index eff01624156..b282f76bfe0 100644 --- a/ocaml/xapi/xapi_observer.ml +++ b/ocaml/xapi/xapi_observer.ml @@ -82,15 +82,15 @@ module Observer : ObserverInterface = struct let init ~__context = debug "Observer.init" ; - ignore @@ Tracing.main () + ignore @@ Tracing_export.main () let set_trace_log_dir ~__context ~dir = debug "Observer.set_trace_log_dir" ; - Tracing.Export.Destination.File.set_trace_log_dir dir + Tracing_export.Destination.File.set_trace_log_dir dir let set_export_interval ~__context ~interval = debug "Observer.set_export_interval" ; - Tracing.Export.set_export_interval interval + Tracing_export.set_export_interval interval let set_max_spans ~__context ~spans = debug "Observer.set_max_spans" ; @@ -102,15 +102,15 @@ module Observer : ObserverInterface = struct let set_max_file_size ~__context ~file_size = debug "Observer.set_max_file_size" ; - Tracing.Export.Destination.File.set_max_file_size file_size + Tracing_export.Destination.File.set_max_file_size file_size let set_host_id ~__context ~host_id = debug "Observer.set_host_id" ; - Tracing.Export.set_host_id host_id + Tracing_export.set_host_id host_id let set_compress_tracing_files ~__context ~enabled = debug "Observer.set_compress_tracing_files" ; - Tracing.Export.Destination.File.set_compress_tracing_files enabled + Tracing_export.Destination.File.set_compress_tracing_files enabled end module Xapi_cluster = struct @@ -248,7 +248,7 @@ module ObserverConfig = struct let rec bugtool_endpoint endpoints = match endpoints with | x :: _ when x = Tracing.bugtool_name -> - Some (Tracing.Export.Destination.File.get_trace_log_dir ()) + Some (Tracing_export.Destination.File.get_trace_log_dir ()) | _ :: t -> bugtool_endpoint t | [] -> @@ -570,7 +570,7 @@ let initialise ~__context = |> observed_components_of |> List.iter (initialise_observer_component ~__context) ) ; - Tracing.Export.set_service_name "xapi" + Tracing_export.set_service_name "xapi" let set_hosts ~__context ~self ~value = assert_valid_hosts ~__context value ; diff --git a/ocaml/xapi/xapi_observer_components.ml b/ocaml/xapi/xapi_observer_components.ml index e91fd143ec1..9b0ea524db6 100644 --- a/ocaml/xapi/xapi_observer_components.ml +++ b/ocaml/xapi/xapi_observer_components.ml @@ -99,24 +99,17 @@ let ( // ) = Filename.concat let dir_name_of_component component = Xapi_globs.observer_config_dir // to_string component // "enabled" -let env_exe_args_of ~component ~traceparent ~exe ~args = +let env_exe_args_of ~component ~exe ~args = let dir_name_value = Filename.quote (dir_name_of_component component) in let env_vars = Array.concat [ Forkhelpers.default_path_env_pair ; Env_record.to_string_array - ([ - Env_record.pair ("OBSERVER_CONFIG_DIR", dir_name_value) - ; Env_record.pair ("PYTHONPATH", Filename.dirname exe) - ] - @ - match traceparent with - | None -> - [] - | Some traceparent -> - [Env_record.pair ("TRACEPARENT", traceparent)] - ) + [ + Env_record.pair ("OBSERVER_CONFIG_DIR", dir_name_value) + ; Env_record.pair ("PYTHONPATH", Filename.dirname exe) + ] ] in let args = "-m" :: "observer" :: exe :: args in diff --git a/ocaml/xapi/xapi_observer_components.mli b/ocaml/xapi/xapi_observer_components.mli index 9ee531bfe36..55bdf7e7f05 100644 --- a/ocaml/xapi/xapi_observer_components.mli +++ b/ocaml/xapi/xapi_observer_components.mli @@ -64,7 +64,6 @@ val dir_name_of_component : t -> string val env_exe_args_of : component:t - -> traceparent:string option -> exe:string -> args:string list -> string array option * string * string list diff --git a/ocaml/xapi/xapi_pbd.ml b/ocaml/xapi/xapi_pbd.ml index 552bd6ad5a7..4b6b5c22711 100644 --- a/ocaml/xapi/xapi_pbd.ml +++ b/ocaml/xapi/xapi_pbd.ml @@ -15,7 +15,7 @@ * @group XenAPI functions *) -open Db_filter_types +open Xapi_database.Db_filter_types module D = Debug.Make (struct let name = "xapi_pbd" end) @@ -292,11 +292,10 @@ let get_locally_attached ~__context = let host = Helpers.get_localhost ~__context in Db.PBD.get_refs_where ~__context ~expr: - Db_filter_types.( - And - ( Eq (Field "host", Literal (Ref.string_of host)) - , Eq (Field "currently_attached", Literal "true") - ) + (And + ( Eq (Field "host", Literal (Ref.string_of host)) + , Eq (Field "currently_attached", Literal "true") + ) ) (* Host calls unplug_all_pbds on shutdown, diff --git a/ocaml/xapi/xapi_pci.ml b/ocaml/xapi/xapi_pci.ml index 6e72c366ec7..1ff5620cf58 100644 --- a/ocaml/xapi/xapi_pci.ml +++ b/ocaml/xapi/xapi_pci.ml @@ -63,7 +63,9 @@ let create ~__context ~class_id ~class_name ~vendor_id ~vendor_name ~device_id let get_local ~__context getter = let localhost = Helpers.get_localhost ~__context in let expr = - Db_filter_types.(Eq (Field "host", Literal (Ref.string_of localhost))) + Xapi_database.Db_filter_types.( + Eq (Field "host", Literal (Ref.string_of localhost)) + ) in getter ~__context ~expr @@ -319,3 +321,12 @@ let get_system_display_device () = ) None items with _ -> None + +let disable_dom0_access ~__context ~self = + Xapi_pci_helpers.update_dom0_access ~__context ~self ~action:`disable + +let enable_dom0_access ~__context ~self = + Xapi_pci_helpers.update_dom0_access ~__context ~self ~action:`enable + +let get_dom0_access_status ~__context ~self = + Xapi_pci_helpers.determine_dom0_access_status ~__context ~self diff --git a/ocaml/xapi/xapi_pci.mli b/ocaml/xapi/xapi_pci.mli index dd71dfffcc2..366da0168b8 100644 --- a/ocaml/xapi/xapi_pci.mli +++ b/ocaml/xapi/xapi_pci.mli @@ -51,3 +51,21 @@ val disable_system_display_device : unit -> unit val dequarantine : __context:Context.t -> Xenops_interface.Pci.address -> unit (** dequarantine a PCI device. This is idempotent. *) + +val disable_dom0_access : + __context:Context.t + -> self:API.ref_PCI + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] +(** Hide a PCI device from the dom0 kernel. (Takes affect after next boot.) *) + +val enable_dom0_access : + __context:Context.t + -> self:API.ref_PCI + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] +(** Unhide a PCI device from the dom0 kernel. (Takes affect after next boot.) *) + +val get_dom0_access_status : + __context:Context.t + -> self:API.ref_PCI + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] +(** Return a PCI device dom0 access status. *) diff --git a/ocaml/xapi/xapi_pci_helpers.ml b/ocaml/xapi/xapi_pci_helpers.ml index 36caab3a606..873031c9f35 100644 --- a/ocaml/xapi/xapi_pci_helpers.ml +++ b/ocaml/xapi/xapi_pci_helpers.ml @@ -15,6 +15,7 @@ module D = Debug.Make (struct let name = "xapi_pci_helpers" end) open D +module Unixext = Xapi_stdext_unix.Unixext type pci_property = {id: int; name: string} @@ -172,3 +173,68 @@ let get_host_pcis () = let igd_is_whitelisted ~__context pci = let vendor_id = Db.PCI.get_vendor_id ~__context ~self:pci in List.mem vendor_id !Xapi_globs.igd_passthru_vendor_whitelist + +let is_pci_hidden_cmdline ~__context ~self = + let cmdline = + match Unixext.read_lines ~path:"/proc/cmdline" with + | [x] -> + x + | _ -> + failwith "Unable to read cmdline" + in + let device = Db.PCI.get_pci_id ~__context ~self in + let elems = String.split_on_char ' ' cmdline in + let xen_hide_param = "xen-pciback.hide=" in + let xen_hide_param_length = String.length xen_hide_param in + let pciback = + List.find_map + (fun s -> + if String.starts_with ~prefix:xen_hide_param s then + Some + (String.sub s xen_hide_param_length + (String.length s - xen_hide_param_length) + ) + else + None + ) + elems + in + (* Look for the device id in the list of hidden devices + * pciback looks like: "xen-pciback.hide=()()..." *) + let contains str substr = Astring.String.is_infix ~affix:substr str in + match pciback with None -> false | Some value -> contains value device + +let determine_dom0_access_status ~__context ~self = + (* Current hidden status *) + let is_hidden_cmdline = is_pci_hidden_cmdline ~__context ~self in + (* Hidden status after reboot *) + let is_hidden = Pciops.is_pci_hidden ~__context self in + match (is_hidden_cmdline, is_hidden) with + | true, true -> + `disabled + | false, true -> + `disable_on_reboot + | false, false -> + `enabled + | true, false -> + `enable_on_reboot + +let update_dom0_access ~__context ~self ~action = + ( match action with + | `enable -> + Pciops.unhide_pci ~__context self + | `disable -> + Pciops.hide_pci ~__context self + ) ; + + let new_access = determine_dom0_access_status ~__context ~self in + (* Keep up to date deprecated PGPU DB field, to be removed eventually. *) + let expr = Printf.sprintf {|field "PCI"="%s"|} (Ref.string_of self) in + let pgpus = Db.PGPU.get_all_records_where ~__context ~expr in + List.iter + (fun (pgpu_ref, _) -> + Db.PGPU.set_dom0_access ~__context ~self:pgpu_ref ~value:new_access + ) + pgpus ; + + new_access diff --git a/ocaml/xapi/xapi_pgpu.ml b/ocaml/xapi/xapi_pgpu.ml index 93193aca55e..a8ce14d7347 100644 --- a/ocaml/xapi/xapi_pgpu.ml +++ b/ocaml/xapi/xapi_pgpu.ml @@ -357,27 +357,8 @@ let assert_can_run_VGPU ~__context ~self ~vgpu = ~vgpu_type let update_dom0_access ~__context ~self ~action = - let db_current = Db.PGPU.get_dom0_access ~__context ~self in - let db_new = - match (db_current, action) with - | `enabled, `enable | `disable_on_reboot, `enable -> - `enabled - | `disabled, `enable | `enable_on_reboot, `enable -> - `enable_on_reboot - | `enabled, `disable | `disable_on_reboot, `disable -> - `disable_on_reboot - | `disabled, `disable | `enable_on_reboot, `disable -> - `disabled - in let pci = Db.PGPU.get_PCI ~__context ~self in - ( match db_new with - | `enabled | `enable_on_reboot -> - Pciops.unhide_pci ~__context pci - | `disabled | `disable_on_reboot -> - Pciops.hide_pci ~__context pci - ) ; - Db.PGPU.set_dom0_access ~__context ~self ~value:db_new ; - db_new + Xapi_pci_helpers.update_dom0_access ~__context ~self:pci ~action let enable_dom0_access ~__context ~self = update_dom0_access ~__context ~self ~action:`enable diff --git a/ocaml/xapi/xapi_pgpu.mli b/ocaml/xapi/xapi_pgpu.mli index cb1a935ea45..83ffcb39ef2 100644 --- a/ocaml/xapi/xapi_pgpu.mli +++ b/ocaml/xapi/xapi_pgpu.mli @@ -51,10 +51,14 @@ val assert_can_run_VGPU : (** Check whether a VGPU can run on a particular PGPU. *) val enable_dom0_access : - __context:Context.t -> self:API.ref_PGPU -> API.pgpu_dom0_access + __context:Context.t + -> self:API.ref_PGPU + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] val disable_dom0_access : - __context:Context.t -> self:API.ref_PGPU -> API.pgpu_dom0_access + __context:Context.t + -> self:API.ref_PGPU + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] (* For AMD MxGPU. Acts on the local host only. * Ensures that the "gim" kernel module is loaded on localhost, diff --git a/ocaml/xapi/xapi_pgpu_helpers.ml b/ocaml/xapi/xapi_pgpu_helpers.ml index efe79d5296d..dc49ec33a83 100644 --- a/ocaml/xapi/xapi_pgpu_helpers.ml +++ b/ocaml/xapi/xapi_pgpu_helpers.ml @@ -40,7 +40,7 @@ let assert_VGPU_type_enabled ~__context ~self ~vgpu_type = ) let get_scheduled_VGPUs ~__context ~self = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in Db.VGPU.get_refs_where ~__context ~expr: (Eq (Field "scheduled_to_be_resident_on", Literal (Ref.string_of self))) @@ -85,7 +85,7 @@ let assert_VGPU_type_allowed ~__context ~self ~vgpu_type = ) let assert_no_resident_VGPUs_of_type ~__context ~self ~vgpu_type = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in match Db.VGPU.get_records_where ~__context ~expr: diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index e1cb02c60f0..f7bbd19ae19 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -17,7 +17,7 @@ open D module L = Debug.Make (struct let name = "license" end) -open Db_filter_types +open Xapi_database.Db_filter_types module Listext = Xapi_stdext_std.Listext.List open Xapi_stdext_std.Xstringext module Date = Xapi_stdext_date.Date @@ -27,12 +27,10 @@ let get_device_pci ~__context ~host ~device = let dbg = Context.string_of_task __context in let pci_bus_path = Net.Interface.get_pci_bus_path dbg device in let expr = - Db_filter_types.( - And - ( Eq (Field "pci_id", Literal pci_bus_path) - , Eq (Field "host", Literal (Ref.string_of host)) - ) - ) + And + ( Eq (Field "pci_id", Literal pci_bus_path) + , Eq (Field "host", Literal (Ref.string_of host)) + ) in match Db.PCI.get_refs_where ~__context ~expr with | pci :: _ -> @@ -515,9 +513,7 @@ let introduce_internal ?network ?(physical = true) ~t:_ ~__context ~host ~mAC (* Assertion passes if PIF has clusters attached but host has disabled clustering *) let assert_no_clustering_enabled_on ~__context ~self = - let cluster_host_on_pif = - Db_filter_types.(Eq (Field "PIF", Literal (Ref.string_of self))) - in + let cluster_host_on_pif = Eq (Field "PIF", Literal (Ref.string_of self)) in match Db.Cluster_host.get_refs_where ~__context ~expr:cluster_host_on_pif with | [] -> () diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index f4736a1a61f..acb7bdfa7e9 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1719,6 +1719,7 @@ let unplug_pbds ~__context host = (* This means eject me, since will have been forwarded from master *) let eject_self ~__context ~host = + let open Xapi_database in (* If HA is enabled then refuse *) let pool = Helpers.get_pool ~__context in if Db.Pool.get_ha_enabled ~__context ~self:pool then @@ -1998,7 +1999,7 @@ let eject ~__context ~host = (* Prohibit parallel flushes since they're so expensive *) let sync_m = Mutex.create () -open Db_cache_types +open Xapi_database.Db_cache_types let sync_database ~__context = with_lock sync_m (fun () -> @@ -2006,7 +2007,7 @@ let sync_database ~__context = let pool = Helpers.get_pool ~__context in let flushed_to_vdi = Db.Pool.get_ha_enabled ~__context ~self:pool - && Db_lock.with_lock (fun () -> + && Xapi_database.Db_lock.with_lock (fun () -> Xha_metadata_vdi.flush_database ~__context Xapi_ha.ha_redo_log ) in @@ -2015,10 +2016,12 @@ let sync_database ~__context = else ( debug "flushing database to all online nodes" ; let generation = - Db_lock.with_lock (fun () -> + Xapi_database.Db_lock.with_lock (fun () -> Manifest.generation (Database.manifest - (Db_ref.get_database (Context.database_of __context)) + (Xapi_database.Db_ref.get_database + (Context.database_of __context) + ) ) ) in @@ -2133,7 +2136,7 @@ let is_slave ~__context ~host:_ = debug "About to kick the database connection to make sure it's still working..." ; let (_ : bool) = - Scheduler.PipeDelay.signal Master_connection.delay ; + Scheduler.PipeDelay.signal Xapi_database.Master_connection.delay ; Db.is_valid_ref __context (Ref.of_string "Pool.is_slave checking to see if the database connection is up" @@ -2861,6 +2864,8 @@ let detect_nonhomogeneous_external_auth () = let detect_nonhomogeneous_external_auth ~__context ~pool:_ = detect_nonhomogeneous_external_auth () +module Redo_log = Xapi_database.Redo_log + let create_redo_log_vdi ~__context ~sr = Helpers.call_api_functions ~__context (fun rpc session_id -> Client.VDI.create ~rpc ~session_id ~name_label:"Metadata redo-log" @@ -2936,7 +2941,7 @@ let enable_redo_log ~__context ~sr = * is already in use) *) if not (Db.Pool.get_ha_enabled ~__context ~self:pool) then ( Redo_log.enable_and_flush - (Context.database_of __context |> Db_ref.get_database) + (Context.database_of __context |> Xapi_database.Db_ref.get_database) Xapi_ha.ha_redo_log Xapi_globs.gen_metadata_vdi_reason ; Localdb.put Constants.redo_log_enabled "true" ) ; diff --git a/ocaml/xapi/xapi_pool_helpers.ml b/ocaml/xapi/xapi_pool_helpers.ml index e3a4c76dfc1..d8c31f7071a 100644 --- a/ocaml/xapi/xapi_pool_helpers.ml +++ b/ocaml/xapi/xapi_pool_helpers.ml @@ -36,7 +36,6 @@ let blocking_ops = ; (`tls_verification_enable, Api_errors.tls_verification_enable_in_progress) ; (`configure_repositories, Api_errors.configure_repositories_in_progress) ; (`sync_updates, Api_errors.sync_updates_in_progress) - ; (`get_updates, Api_errors.get_updates_in_progress) ; (`apply_updates, Api_errors.apply_updates_in_progress) ] @@ -52,6 +51,7 @@ let wait_ops = ; `exchange_ca_certificates_on_join ; `copy_primary_host_certs ; `eject + ; `get_updates ] let all_operations = blocking_ops |> List.map fst |> List.append wait_ops diff --git a/ocaml/xapi/xapi_pool_patch.ml b/ocaml/xapi/xapi_pool_patch.ml index 433cc1e92ac..5988a1abc7c 100644 --- a/ocaml/xapi/xapi_pool_patch.ml +++ b/ocaml/xapi/xapi_pool_patch.ml @@ -35,7 +35,7 @@ let pool_patch_of_update ~__context update_ref = match Db.Pool_patch.get_refs_where ~__context ~expr: - Db_filter_types.( + Xapi_database.Db_filter_types.( Eq (Field "pool_update", Literal (Ref.string_of update_ref)) ) with @@ -124,7 +124,7 @@ let pool_patch_upload_handler (req : Http.Request.t) s _ = returns [Some (ref, false)] if it's on the host but isn't applied yet or the application is in progress. *) let get_patch_applied_to ~__context ~patch ~host = let expr = - Db_filter_types.( + Xapi_database.Db_filter_types.( And ( Eq (Field "pool_patch", Literal (Ref.string_of patch)) , Eq (Field "host", Literal (Ref.string_of host)) diff --git a/ocaml/xapi/xapi_pool_transition.ml b/ocaml/xapi/xapi_pool_transition.ml index a8f00deaa26..6ff8f892bd9 100644 --- a/ocaml/xapi/xapi_pool_transition.ml +++ b/ocaml/xapi/xapi_pool_transition.ml @@ -85,6 +85,7 @@ let become_master () = This code runs on the new master. *) let attempt_two_phase_commit_of_new_master ~__context (manual : bool) (peer_addresses : string list) (my_address : string) = + let open Xapi_database in debug "attempting %s two-phase commit of new master. My address = %s; peer \ addresses = [ %s ]" diff --git a/ocaml/xapi/xapi_psr.ml b/ocaml/xapi/xapi_psr.ml index adc9b7ec7f1..aa2481b3eca 100644 --- a/ocaml/xapi/xapi_psr.ml +++ b/ocaml/xapi/xapi_psr.ml @@ -461,8 +461,10 @@ let notify_send ~__context ~old_ps ~new_ps = ) in Xapi_globs.pool_secrets := [priority_2_ps; priority_1_ps] ; - Db_globs.pool_secret := - priority_2_ps |> SecretString.rpc_of_t |> Db_secret_string.t_of_rpc + Xapi_database.Db_globs.pool_secret := + priority_2_ps + |> SecretString.rpc_of_t + |> Xapi_database.Db_secret_string.t_of_rpc | [priority_1_ps; priority_2_ps] when SecretString.(equal priority_1_ps new_ps && equal priority_2_ps old_ps) -> diff --git a/ocaml/xapi/xapi_pusb.ml b/ocaml/xapi/xapi_pusb.ml index da34329cc4f..e1bf3e82acb 100644 --- a/ocaml/xapi/xapi_pusb.ml +++ b/ocaml/xapi/xapi_pusb.ml @@ -218,7 +218,7 @@ let set_passthrough_enabled ~__context ~self ~value = we want to re-display the vdi records. But in udevSR.py we will handle this, as if passthrough_enabled = true, we will not re-introduce the vdi. *) - let open Db_filter_types in + let open Xapi_database.Db_filter_types in Db.SR.get_refs_where ~__context ~expr:(Eq (Field "type", Literal "udev")) |> List.iter (fun sr -> diff --git a/ocaml/xapi/xapi_pvs_proxy.ml b/ocaml/xapi/xapi_pvs_proxy.ml index 71334c0d545..136daeef4be 100644 --- a/ocaml/xapi/xapi_pvs_proxy.ml +++ b/ocaml/xapi/xapi_pvs_proxy.ml @@ -21,7 +21,9 @@ open D let create ~__context ~site ~vIF = Pool_features.assert_enabled ~__context ~f:Features.PVS_proxy ; Helpers.assert_using_vswitch ~__context ; - let expr = Db_filter_types.(Eq (Field "VIF", Literal (Ref.string_of vIF))) in + let expr = + Xapi_database.Db_filter_types.(Eq (Field "VIF", Literal (Ref.string_of vIF))) + in let proxies = Db.PVS_proxy.get_refs_where ~__context ~expr in if List.length proxies > 0 then raise diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 455dcef9c55..4df3a365a2a 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -431,7 +431,7 @@ let revalidate_external_session ~__context ~session = if not (Db.Session.get_is_local_superuser ~__context ~self:session - || Db_backend.is_session_registered (Ref.string_of session) + || Xapi_database.Db_backend.is_session_registered (Ref.string_of session) ) then ( (* 1. is the external authentication disabled in the pool? *) @@ -653,7 +653,8 @@ let login_no_password_common ~__context ~uname ~originator ~host ~pool Ref.of_string ( match db_ref with | Some db_ref -> - Db_backend.create_registered_session create_session db_ref + Xapi_database.Db_backend.create_registered_session create_session + db_ref | None -> create_session () ) @@ -1149,8 +1150,8 @@ let change_password ~__context ~old_pwd ~new_pwd = try (* CP-696: only change password if session has is_local_superuser bit set *) (* - CA-13567: If you have root priviledges then we do not authenticate old_pwd; right now, since we only - ever have root priviledges we just comment this out. + CA-13567: If you have root privileges then we do not authenticate old_pwd; right now, since we only + ever have root privileges we just comment this out. begin try @@ -1347,8 +1348,8 @@ let create_readonly_session ~__context ~uname ~db_ref = (* Create a database reference from a DB dump, and register it with a new readonly session. *) let create_from_db_file ~__context ~filename = let db = - Db_xml.From.file (Datamodel_schema.of_datamodel ()) filename - |> Db_upgrade.generic_database_upgrade + Xapi_database.Db_xml.From.file (Datamodel_schema.of_datamodel ()) filename + |> Xapi_database.Db_upgrade.generic_database_upgrade in - let db_ref = Some (Db_ref.in_memory (ref (ref db))) in + let db_ref = Some (Xapi_database.Db_ref.in_memory (ref (ref db))) in create_readonly_session ~__context ~uname:"db-from-file" ~db_ref diff --git a/ocaml/xapi/xapi_session.mli b/ocaml/xapi/xapi_session.mli index 422afd46cc3..2dc98429f3e 100644 --- a/ocaml/xapi/xapi_session.mli +++ b/ocaml/xapi/xapi_session.mli @@ -78,7 +78,7 @@ val get_top : __context:Context.t -> self:API.ref_session -> API.ref_session val create_readonly_session : __context:Context.t -> uname:string - -> db_ref:Db_ref.t option + -> db_ref:Xapi_database.Db_ref.t option -> API.ref_session val create_from_db_file : diff --git a/ocaml/xapi/xapi_sr.ml b/ocaml/xapi/xapi_sr.ml index 0508f5384c5..f692f524050 100644 --- a/ocaml/xapi/xapi_sr.ml +++ b/ocaml/xapi/xapi_sr.ml @@ -25,7 +25,8 @@ module Unixext = Xapi_stdext_unix.Unixext let finally = Xapi_stdext_pervasives.Pervasiveext.finally -open Db_filter_types +module Redo_log = Xapi_database.Redo_log +open Xapi_database.Db_filter_types open API open Client @@ -461,7 +462,6 @@ let assert_sr_not_local_cache ~__context ~sr = () let find_or_create_rrd_vdi ~__context ~sr = - let open Db_filter_types in match Db.VDI.get_refs_where ~__context ~expr: diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index b44c8bf5916..5d4cc834750 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -15,7 +15,7 @@ * @group XenAPI functions *) -open Db_filter_types +open Xapi_database.Db_filter_types open API open Client @@ -26,29 +26,7 @@ open Client open Record_util -let all_ops : API.storage_operations_set = - [ - `scan - ; `destroy - ; `forget - ; `plug - ; `unplug - ; `vdi_create - ; `vdi_destroy - ; `vdi_resize - ; `vdi_clone - ; `vdi_snapshot - ; `vdi_mirror - ; `vdi_enable_cbt - ; `vdi_disable_cbt - ; `vdi_data_destroy - ; `vdi_list_changed_blocks - ; `vdi_set_on_boot - ; `vdi_introduce - ; `update - ; `pbd_create - ; `pbd_destroy - ] +let all_ops = API.storage_operations__all (* This list comes from https://github.com/xenserver/xen-api/blob/tampa-bugfix/ocaml/xapi/xapi_sr_operations.ml#L36-L38 *) let all_rpu_ops : API.storage_operations_set = @@ -92,7 +70,6 @@ let sm_cap_table : (API.storage_operations * _) list = type table = (API.storage_operations, (string * string list) option) Hashtbl.t let features_of_sr_internal ~__context ~_type = - let open Db_filter_types in match Db.SM.get_internal_records_where ~__context ~expr:(Eq (Field "type", Literal _type)) diff --git a/ocaml/xapi/xapi_subject.ml b/ocaml/xapi/xapi_subject.ml index f5939b5b5bd..5c1cdd69a5d 100644 --- a/ocaml/xapi/xapi_subject.ml +++ b/ocaml/xapi/xapi_subject.ml @@ -245,14 +245,10 @@ let remove_from_roles ~__context ~self ~role = ) let query_subject_information_from_db ~__context identifier = + let open Xapi_database.Db_filter_types in match Db.Subject.get_records_where ~__context - ~expr: - (Db_filter_types.Eq - ( Db_filter_types.Field "subject_identifier" - , Db_filter_types.Literal identifier - ) - ) + ~expr:(Eq (Field "subject_identifier", Literal identifier)) with | [] -> raise Auth_signature.Subject_cannot_be_resolved diff --git a/ocaml/xapi/xapi_tunnel.ml b/ocaml/xapi/xapi_tunnel.ml index affd5583a2b..1fb8a83b097 100644 --- a/ocaml/xapi/xapi_tunnel.ml +++ b/ocaml/xapi/xapi_tunnel.ml @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -open Db_filter_types +open Xapi_database.Db_filter_types let choose_tunnel_device_name ~__context ~host = (* list all the tunnel access PIFs on this host *) diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index ac989551b85..6a2fa244c84 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -104,7 +104,7 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) let sr_type = Db.SR.get_type ~__context ~self:sr in let is_tools_sr = Db.SR.get_is_tools_sr ~__context ~self:sr in (* Check to see if any PBDs are attached *) - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let pbds_attached = match pbd_records with | [] -> @@ -560,7 +560,7 @@ let cancel_tasks ~__context ~self ~all_tasks_in_db ~task_ids = (* This function updates xapi's database for a single VDI. The row will be created if it doesn't exist *) let update_vdi_db ~__context ~sr newvdi = - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let expr = And ( Eq @@ -625,13 +625,27 @@ let create ~__context ~name_label ~name_description ~sR ~virtual_size ~_type | `cbt_metadata -> "cbt_metadata" in + (* special case: we want to use a specific UUID for Pool Meta Data + Backup *) + let uuid_ = + match (_type, name_label) with + | `user, "Pool Metadata Backup" -> + let sr = Db.SR.get_uuid ~__context ~self:sR in + let uuid = Uuidx.(Hash.string sr |> to_string) in + info "%s: using deterministic UUID for '%s' VDI: %s" __FUNCTION__ + name_label uuid ; + Some uuid + | _ -> + None + in let open Storage_access in let task = Context.get_task_id __context in let open Storage_interface in let vdi_info = { Storage_interface.default_vdi_info with - name_label + uuid= uuid_ + ; name_label ; name_description ; ty= vdi_type ; read_only @@ -1017,7 +1031,7 @@ let destroy_and_data_destroy_common ~__context ~self ) vbds ; (* If VDI destroyed is suspend VDI of VM then set the suspend_VDI field as null ref *) - let open Db_filter_types in + let open Xapi_database.Db_filter_types in Db.VM.get_refs_where ~__context ~expr:(Eq (Field "suspend_VDI", Literal (Ref.string_of self))) |> List.iter (fun self -> @@ -1427,7 +1441,7 @@ let _get_nbd_info ~__context ~self ~get_server_certificate = let hosts_with_attached_pbds = Db.PBD.get_refs_where ~__context ~expr: - Db_filter_types.( + Xapi_database.Db_filter_types.( And ( Eq (Field "SR", Literal (Ref.string_of sr)) , Eq (Field "currently_attached", Literal "true") @@ -1455,7 +1469,7 @@ let _get_nbd_info ~__context ~self ~get_server_certificate = let attached_pifs = Db.PIF.get_refs_where ~__context ~expr: - Db_filter_types.( + Xapi_database.Db_filter_types.( And ( Eq (Field "host", Literal (Ref.string_of host)) , Eq (Field "currently_attached", Literal "true") diff --git a/ocaml/xapi/xapi_vdi_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml index 2e3355ef1f4..0fe39c68c26 100644 --- a/ocaml/xapi/xapi_vdi_helpers.ml +++ b/ocaml/xapi/xapi_vdi_helpers.ml @@ -16,7 +16,8 @@ *) open Client -open Db_cache_types +open Xapi_database.Db_cache_types +module Redo_log = Xapi_database.Redo_log let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute @@ -26,26 +27,7 @@ module D = Debug.Make (struct let name = "xapi_vdi_helpers" end) open D -let all_ops : API.vdi_operations_set = - [ - `blocked - ; `clone - ; `copy - ; `data_destroy - ; `destroy - ; `disable_cbt - ; `enable_cbt - ; `force_unlock - ; `forget - ; `generate_config - ; `list_changed_blocks - ; `mirror - ; `resize - ; `resize_online - ; `set_on_boot - ; `snapshot - ; `update - ] +let all_ops = API.vdi_operations__all (* CA-26514: Block operations on 'unmanaged' VDIs *) let assert_managed ~__context ~vdi = @@ -144,7 +126,7 @@ let enable_database_replication ~__context ~get_vdi_callback = let device = Db.VBD.get_device ~__context ~self:vbd in try Redo_log.enable_block_and_flush - (Context.database_of __context |> Db_ref.get_database) + (Context.database_of __context |> Xapi_database.Db_ref.get_database) log ("/dev/" ^ device) ; Hashtbl.add metadata_replication vdi (vbd, log) ; let vbd_uuid = Db.VBD.get_uuid ~__context ~self:vbd in @@ -202,18 +184,20 @@ 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 = Db_ref.in_memory (ref (ref db)) in + let db_ref = Xapi_database.Db_ref.in_memory (ref (ref 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. *) (* Reindex database to make sure is_valid_ref works. *) let ( ++ ) f g x = f (g x) in - Db_ref.update_database db_ref - (Db_upgrade.generic_database_upgrade - ++ Database.reindex - ++ Db_backend.blow_away_non_persistent_fields - (Datamodel_schema.of_datamodel ()) - ) ; + Xapi_database.( + Db_ref.update_database db_ref + (Db_upgrade.generic_database_upgrade + ++ Database.reindex + ++ Db_backend.blow_away_non_persistent_fields + (Datamodel_schema.of_datamodel ()) + ) + ) ; db_ref in with_lock database_open_mutex (fun () -> diff --git a/ocaml/xapi/xapi_vgpu_type.ml b/ocaml/xapi/xapi_vgpu_type.ml index 24a7ae29762..9656aa8f959 100644 --- a/ocaml/xapi/xapi_vgpu_type.ml +++ b/ocaml/xapi/xapi_vgpu_type.ml @@ -162,7 +162,7 @@ let find_and_update ~__context vgpu_type = let fail () = failwith "Error: Multiple vGPU types exist with the same configuration." in - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let new_expr = Eq (Field "identifier", Literal identifier_string) in let old_expr = And @@ -1041,7 +1041,7 @@ module Nvidia_compat = struct let create_compat_config_file __context = try - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let host_driver_version = Vendor_nvidia.get_host_driver_version () in let host_driver_supports_multiple = Vendor_nvidia.host_driver_supports_multi_vgpu ~host_driver_version diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 5144ef7ef7a..751f987a6da 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -366,10 +366,10 @@ let copy ~__context ~vm ~preserve_mac_address vif = ~ipv6_addresses:all.API.vIF_ipv6_addresses ~ipv6_gateway:all.API.vIF_ipv6_gateway in - let proxies = - Db.PVS_proxy.get_records_where ~__context - ~expr:Db_filter_types.(Eq (Field "VIF", Literal (Ref.string_of vif))) + let expr = + Xapi_database.Db_filter_types.(Eq (Field "VIF", Literal (Ref.string_of vif))) in + let proxies = Db.PVS_proxy.get_records_where ~__context ~expr in List.iter (fun (_, proxy) -> try diff --git a/ocaml/xapi/xapi_vlan.ml b/ocaml/xapi/xapi_vlan.ml index 4038cf83793..2e2b13191cf 100644 --- a/ocaml/xapi/xapi_vlan.ml +++ b/ocaml/xapi/xapi_vlan.ml @@ -91,17 +91,12 @@ let create ~__context ~tagged_PIF ~tag ~network = ) ; let device = pif_rec.API.pIF_device in let vlans = + let open Xapi_database.Db_filter_types in Db.VLAN.get_records_where ~__context ~expr: - (Db_filter_types.And - ( Db_filter_types.Eq - ( Db_filter_types.Field "tagged_PIF" - , Db_filter_types.Literal (Ref.string_of tagged_PIF) - ) - , Db_filter_types.Eq - ( Db_filter_types.Field "tag" - , Db_filter_types.Literal (Int64.to_string tag) - ) + (And + ( Eq (Field "tagged_PIF", Literal (Ref.string_of tagged_PIF)) + , Eq (Field "tag", Literal (Int64.to_string tag)) ) ) in diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index e0de06045e1..8632cc1ca35 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -592,9 +592,6 @@ let create ~__context ~name_label ~name_description ~power_state ~user_version ~shutdown_delay ~order ~suspend_SR ~version ~generation_id ~hardware_platform_version ~has_vendor_device ~reference_label ~domain_type ~nVRAM : API.ref_VM = - if has_vendor_device then - Pool_features.assert_enabled ~__context - ~f:Features.PCI_device_for_auto_update ; (* Add random mac_seed if there isn't one specified already *) let other_config = let gen_mac_seed () = Uuidx.to_string (Uuidx.make ()) in @@ -1571,19 +1568,9 @@ let import ~__context ~url ~sr ~full_restore ~force = let query_services ~__context ~self:_ = raise Api_errors.(Server_error (not_implemented, ["query_services"])) -let assert_can_set_has_vendor_device ~__context ~self ~value = - if - value - (* Do the check even for templates, because snapshots are templates and - * we allow restoration of a VM from a snapshot. *) - then - Pool_features.assert_enabled ~__context - ~f:Features.PCI_device_for_auto_update ; - Xapi_vm_lifecycle.assert_initial_power_state_is ~__context ~self - ~expected:`Halted - let set_has_vendor_device ~__context ~self ~value = - assert_can_set_has_vendor_device ~__context ~self ~value ; + Xapi_vm_lifecycle.assert_initial_power_state_is ~__context ~self + ~expected:`Halted ; Db.VM.set_has_vendor_device ~__context ~self ~value ; update_vm_virtual_hardware_platform_version ~__context ~vm:self diff --git a/ocaml/xapi/xapi_vm.mli b/ocaml/xapi/xapi_vm.mli index c349ff8dcb0..22ee1aeb3b2 100644 --- a/ocaml/xapi/xapi_vm.mli +++ b/ocaml/xapi/xapi_vm.mli @@ -401,9 +401,6 @@ val call_plugin : val set_has_vendor_device : __context:Context.t -> self:API.ref_VM -> value:bool -> unit -val assert_can_set_has_vendor_device : - __context:Context.t -> self:API.ref_VM -> value:bool -> unit - val import : __context:Context.t -> url:string diff --git a/ocaml/xapi/xapi_vm_clone.ml b/ocaml/xapi/xapi_vm_clone.ml index 169d0b3d987..997dc5cfdb4 100644 --- a/ocaml/xapi/xapi_vm_clone.ml +++ b/ocaml/xapi/xapi_vm_clone.ml @@ -244,10 +244,8 @@ let snapshot_metadata ~__context ~vm ~is_a_snapshot = else "" -(* return a new VM record, in appropriate power state and having the good metrics. *) -(* N.B. always check VM.has_vendor_device and Features.PCI_device_for_auto_update before calling this, - * as is done before the single existing call to this function. - * If ever we need to expose this function in the .mli file then we should do the check in the function. *) +(* return a new VM record, in appropriate power state and having the + good metrics. *) let copy_vm_record ?snapshot_info_record ~__context ~vm ~disk_op ~new_name ~new_power_state () = let all = Db.VM.get_record_internal ~__context ~self:vm in @@ -448,13 +446,6 @@ let clone ?snapshot_info_record ?(ignore_vdis = []) disk_op ~__context ~vm vbds in - (* Check licence permission before copying disks, since the copy can take - a long time. We always allow snapshotting a VM, but check before - clone/copy of an existing snapshot or template. *) - if Db.VM.get_has_vendor_device ~__context ~self:vm && not is_a_snapshot - then - Pool_features.assert_enabled ~__context - ~f:Features.PCI_device_for_auto_update ; (* driver params to be passed to storage backend clone operations. *) let driver_params = make_driver_params () in (* backend cloning operations first *) diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index 538dda7bb01..d8b9855686e 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -71,9 +71,6 @@ let set_actions_after_crash ~__context ~self ~value = let set_is_a_template ~__context ~self ~value = (* We define a 'set_is_a_template false' as 'install time' *) info "VM.set_is_a_template('%b')" value ; - if Db.VM.get_has_vendor_device ~__context ~self then - Pool_features.assert_enabled ~__context - ~f:Features.PCI_device_for_auto_update ; let m = Db.VM.get_metrics ~__context ~self in ( if not value then try @@ -152,28 +149,6 @@ let update_vm_virtual_hardware_platform_version ~__context ~vm = Db.VM.set_hardware_platform_version ~__context ~self:vm ~value:visibly_required_version -let create_from_record_without_checking_licence_feature_for_vendor_device - ~__context rpc session_id vm_record = - let mk_vm r = - Client.Client.VM.create_from_record ~rpc ~session_id - ~value:{r with API.vM_suspend_VDI= Ref.null; API.vM_power_state= `Halted} - in - let has_vendor_device = vm_record.API.vM_has_vendor_device in - if - has_vendor_device - && not - (Pool_features.is_enabled ~__context - Features.PCI_device_for_auto_update - ) - then ( - (* Avoid the licence feature check which is enforced in VM.create (and create_from_record). *) - let vm = mk_vm {vm_record with API.vM_has_vendor_device= false} in - Db.VM.set_has_vendor_device ~__context ~self:vm ~value:true ; - update_vm_virtual_hardware_platform_version ~__context ~vm ; - vm - ) else - mk_vm vm_record - let destroy ~__context ~self = (* Used to be a call to hard shutdown here, but this will be redundant *) (* given the call to 'assert_operation_valid' *) diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index d90da39619e..ccee66500cd 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -749,49 +749,41 @@ let vtpm_update_allowed_operations ~__context ~self = let allowed = match state with `Halted -> ops | _ -> [] in Db.VTPM.set_allowed_operations ~__context ~self ~value:allowed +let ignored_ops = + [ + `create_template + ; `power_state_reset + ; `csvm + ; `get_boot_record + ; `send_sysrq + ; `send_trigger + ; `query_services + ; `shutdown + ; `call_plugin + ; `changing_memory_live + ; `awaiting_memory_live + ; `changing_memory_limits + ; `changing_shadow_memory_live + ; `changing_VCPUs + ; `assert_operation_valid + ; `data_source_op + ; `update_allowed_operations + ; `import + ; `reverting + ] + +let allowable_ops = + List.filter (fun op -> not (List.mem op ignored_ops)) API.vm_operations__all + let update_allowed_operations ~__context ~self = - let check_operation_error = check_operation_error ~__context ~ref:self in let check accu op = - match check_operation_error ~op ~strict:true with + match check_operation_error ~__context ~ref:self ~op ~strict:true with | None -> op :: accu - | _ -> + | Some _err -> accu in - let allowed = - List.fold_left check [] - [ - `snapshot - ; `copy - ; `clone - ; `revert - ; `checkpoint - ; `snapshot_with_quiesce - ; `start - ; `start_on - ; `pause - ; `unpause - ; `clean_shutdown - ; `clean_reboot - ; `hard_shutdown - ; `hard_reboot - ; `suspend - ; `resume - ; `resume_on - ; `export - ; `destroy - ; `provision - ; `changing_VCPUs_live - ; `pool_migrate - ; `migrate_send - ; `make_into_template - ; `changing_static_range - ; `changing_shadow_memory - ; `changing_dynamic_range - ; `changing_NVRAM - ; `create_vtpm - ] - in + let allowed = List.fold_left check [] allowable_ops in (* FIXME: need to be able to deal with rolling-upgrade for orlando as well *) let allowed = if Helpers.rolling_upgrade_in_progress ~__context then diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 13d112fd3ce..425de03a5a2 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -1720,9 +1720,6 @@ let assert_can_migrate ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~options try bool_of_string (List.assoc "force" options) with _ -> false in let copy = try bool_of_string (List.assoc "copy" options) with _ -> false in - if copy && Db.VM.get_has_vendor_device ~__context ~self:vm then - Pool_features.assert_enabled ~__context - ~f:Features.PCI_device_for_auto_update ; let source_host_ref = let host = Db.VM.get_resident_on ~__context ~self:vm in if host <> Ref.null then @@ -1975,7 +1972,7 @@ let vdi_pool_migrate ~__context ~vdi ~sr ~options = let management_if = Xapi_inventory.lookup Xapi_inventory._management_interface in - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let networks = Db.Network.get_records_where ~__context ~expr:(Eq (Field "bridge", Literal management_if)) diff --git a/ocaml/xapi/xapi_vm_placement.ml b/ocaml/xapi/xapi_vm_placement.ml index 90b1b9806a1..ec8c184595b 100644 --- a/ocaml/xapi/xapi_vm_placement.ml +++ b/ocaml/xapi/xapi_vm_placement.ml @@ -15,7 +15,7 @@ * @group Virtual-Machine Management *) -open Db_filter_types +open Xapi_database.Db_filter_types open Vm_placement (* === Snapshot constructors ================================================ *) diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index b533aef5da4..747fd68deb3 100644 --- a/ocaml/xapi/xapi_vm_snapshot.ml +++ b/ocaml/xapi/xapi_vm_snapshot.ml @@ -20,6 +20,7 @@ module Listext = Xapi_stdext_std.Listext.List module D = Debug.Make (struct let name = "xapi_vm_snapshot" end) +module Xs = Ezxenstore_core.Xenstore open D (*************************************************************************************************) @@ -39,21 +40,20 @@ let snapshot ~__context ~vm ~new_name ~ignore_vdis = (* Quiesced snapshot *) (*************************************************************************************************) (* xenstore paths *) -let control_path ~xs ~domid x = - xs.Xenstore.Xs.getdomainpath domid ^ "/control/" ^ x +let control_path ~xs ~domid x = xs.Xs.getdomainpath domid ^ "/control/" ^ x let snapshot_path ~xs ~domid x = - xs.Xenstore.Xs.getdomainpath domid ^ "/control/snapshot/" ^ x + xs.Xs.getdomainpath domid ^ "/control/snapshot/" ^ x let snapshot_cleanup_path ~xs ~domid = - xs.Xenstore.Xs.getdomainpath domid ^ "/control/snapshot" + xs.Xs.getdomainpath domid ^ "/control/snapshot" (* check if [flag] is set in the control_path of the VM [vm]. This looks like this code is a kind *) (* of duplicate of the one in {!xal.ml}, {!events.ml} and {!xapi_guest_agent.ml} which are looking *) (* dynamically if there is a change in this part of the VM's xenstore tree. However, at the moment *) (* always allowing the operation and checking if it is enabled when it is triggered is sufficient. *) let is_flag_set ~xs ~flag ~domid ~vm = - try xs.Xenstore.Xs.read (control_path ~xs ~domid flag) = "1" + try xs.Xs.read (control_path ~xs ~domid flag) = "1" with e -> debug "Exception while reading %s flag of VM %s (domain %i): %s" flag (Ref.string_of vm) domid (Printexc.to_string e) ; @@ -167,7 +167,9 @@ 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 Db_cache.get db : Db_interface.DB_ACCESS) in + let module DB = + (val Xapi_database.Db_cache.get db : Xapi_database.Db_interface.DB_ACCESS) + in List.iter (fun (key, value) -> let value = Option.value ~default:value (List.assoc_opt key overrides) in @@ -267,7 +269,7 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = 2) Find all snapshots with the same snapshot_of 3) Update each of these snapshots so that their snapshot_of points to the new cloned disk. *) - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let snapshot_of = Db.VDI.get_snapshot_of ~__context ~self:snap_disk in let all_snaps_in_tree = Db.VDI.get_refs_where ~__context @@ -541,23 +543,27 @@ let create_vm_from_snapshot ~__context ~snapshot = let old_vm = Db.VM.get_snapshot_of ~__context ~self:snapshot in try let snapshots = - Db.VM.get_records_where ~__context - ~expr: - (Db_filter_types.Eq - ( Db_filter_types.Field "snapshot_of" - , Db_filter_types.Literal (Ref.string_of old_vm) - ) - ) + let expr = + Xapi_database.Db_filter_types.( + Eq (Field "snapshot_of", Literal (Ref.string_of old_vm)) + ) + in + Db.VM.get_records_where ~__context ~expr in let snap_metadata = Db.VM.get_snapshot_metadata ~__context ~self:snapshot in let snap_metadata = Helpers.vm_string_to_assoc snap_metadata in let vm_uuid = List.assoc Db_names.uuid snap_metadata in let snap_record = Db.VM.get_record ~__context ~self:snapshot in + let snap_record = + { + snap_record with + API.vM_suspend_VDI= Ref.null + ; API.vM_power_state= `Halted + } + in Helpers.call_api_functions ~__context (fun rpc session_id -> let new_vm = - Xapi_vm_helpers - .create_from_record_without_checking_licence_feature_for_vendor_device - ~__context rpc session_id snap_record + Client.VM.create_from_record ~rpc ~session_id ~value:snap_record in try Db.VM.set_uuid ~__context ~self:new_vm ~value:vm_uuid ; diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index ac92853d104..23801ba7ba5 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -119,7 +119,7 @@ let disk_of_vdi ~__context ~self = let vdi_of_disk ~__context x = match String.split ~limit:2 '/' x with | [sr_uuid; location] -> ( - let open Db_filter_types in + let open Xapi_database.Db_filter_types in let sr = Db.SR.get_by_uuid ~__context ~uuid:sr_uuid in match Db.VDI.get_records_where ~__context @@ -3278,7 +3278,7 @@ let events_from_xapi () = let timeout = 30. +. api_timeout - +. !Db_globs.master_connection_reset_timeout + +. !Xapi_database.Db_globs.master_connection_reset_timeout in let timebox_rpc = Helpers.make_timeboxed_rpc ~__context timeout diff --git a/ocaml/xapi/xha_metadata_vdi.ml b/ocaml/xapi/xha_metadata_vdi.ml index d824bf6a493..d2142c30d6a 100644 --- a/ocaml/xapi/xha_metadata_vdi.ml +++ b/ocaml/xapi/xha_metadata_vdi.ml @@ -19,6 +19,7 @@ module D = Debug.Make (struct let name = "xha_metadata_vdi" end) open D open Client +module Redo_log = Xapi_database.Redo_log let create ~__context ~sr = Helpers.call_api_functions ~__context (fun rpc session_id -> @@ -82,6 +83,7 @@ let deactivate_and_detach_existing ~__context = (** Attempt to flush the database to the metadata VDI *) let flush_database ~__context log = + let open Xapi_database in try Redo_log.flush_db_to_redo_log (Db_ref.get_database (Db_backend.make ())) log with _ -> false diff --git a/ocaml/xapi/xha_statefile.ml b/ocaml/xapi/xha_statefile.ml index 357ad1bd6b2..abcae2d1697 100644 --- a/ocaml/xapi/xha_statefile.ml +++ b/ocaml/xapi/xha_statefile.ml @@ -18,6 +18,7 @@ module D = Debug.Make (struct let name = "xha_statefile" end) open D +module Redo_log = Xapi_database.Redo_log (** Reason associated with the static VDI attach, to help identify these later *) let reason = "HA statefile" @@ -108,7 +109,7 @@ let check_sr_can_host_statefile ~__context ~sr ~cluster_stack = Cluster_stack_constraints.assert_sr_compatible ~__context ~cluster_stack ~sr ; (* Check the exported capabilities of the SR's SM plugin *) let srtype = Db.SR.get_type ~__context ~self:sr in - let open Db_filter_types in + let open Xapi_database.Db_filter_types in match Db.SM.get_internal_records_where ~__context ~expr:(Eq (Field "type", Literal srtype)) diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index 42b0823d9c2..c38e712f74b 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -1,6 +1,7 @@ (library (name rrdd_libs_internal) (wrapped false) + (modes best) (modules (:standard \ xcp_rrdd)) (libraries astring diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 4f696085d6d..faa2c7f0076 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -361,9 +361,11 @@ let dss_loadavg () = ) ] -let count_running_domain domains = +let count_power_state_running_domains domains = List.fold_left - (fun count (dom, _, _) -> if dom.Xenctrl.running then count + 1 else count) + (fun count (dom, _, _) -> + if not dom.Xenctrl.paused then count + 1 else count + ) 0 domains let dss_hostload xc domains = @@ -386,7 +388,7 @@ let dss_hostload xc domains = ) 0 domains in - let running_domains = count_running_domain domains in + let running_domains = count_power_state_running_domains domains in let load_per_cpu = float_of_int load /. float_of_int pcpus in [ @@ -793,7 +795,7 @@ let domain_snapshot xc = the original and the final uuid to xenstore *) let uuid_from_key key = let path = Printf.sprintf "/vm/%s/%s" uuid key in - try Xenstore.(with_xs (fun xs -> xs.read path)) + 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 diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml index 844ad7f8a17..c718a033d0f 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml @@ -20,7 +20,7 @@ open Blktap3_stats module Process = Process (struct let name = "xcp-rrdd-iostat" end) open Process -open Xenstore +open Ezxenstore_core.Xenstore let with_xc_and_xs f = Xenctrl.with_intf (fun xc -> with_xs (fun xs -> f xc xs)) @@ -124,7 +124,7 @@ let update_vdi_to_vm_map () = xs.Xs.read (Printf.sprintf "%s/sm-data/vdi-uuid" vbd) in let device = xs.Xs.read (Printf.sprintf "%s/dev" vbd) in - D.info "Found VDI %s at device %s in VM %s, device id %d" + D.debug "Found VDI %s at device %s in VM %s, device id %d" vdi device vm devid ; Some (vdi, (vm, device, devid)) with Xs_protocol.Enoent _ -> @@ -456,7 +456,7 @@ let exec_tap_ctl_list () : ((string * string) * int) list = | None -> () | Some reason -> - D.info "Updating VDI-to-VM map because %s" reason ; + D.debug "Updating VDI-to-VM map because %s" reason ; update_vdi_to_vm_map () ) ; previous_map := pid_and_minor_to_sr_and_vdi ; diff --git a/ocaml/xen-api-client/lwt/dune b/ocaml/xen-api-client/lwt/dune index f07183058dc..306a170d0c4 100644 --- a/ocaml/xen-api-client/lwt/dune +++ b/ocaml/xen-api-client/lwt/dune @@ -22,6 +22,5 @@ xen-api-client xmlm ) - (wrapped false) ) diff --git a/ocaml/xen-api-client/lwt_examples/list_vms.ml b/ocaml/xen-api-client/lwt_examples/list_vms.ml index 40730ef4473..1e5bb7e83a6 100644 --- a/ocaml/xen-api-client/lwt_examples/list_vms.ml +++ b/ocaml/xen-api-client/lwt_examples/list_vms.ml @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -open Xen_api_lwt_unix +open Xen_api_client_lwt.Xen_api_lwt_unix open Lwt.Syntax let uri = ref "http://127.0.0.1/jsonrpc" diff --git a/ocaml/xen-api-client/lwt_examples/upload_disk.ml b/ocaml/xen-api-client/lwt_examples/upload_disk.ml index e7043e35db9..2ccb62d8eef 100644 --- a/ocaml/xen-api-client/lwt_examples/upload_disk.ml +++ b/ocaml/xen-api-client/lwt_examples/upload_disk.ml @@ -13,8 +13,10 @@ *) open Lwt -open Xen_api_lwt_unix +open Xen_api_client_lwt.Xen_api_lwt_unix open Lwt.Syntax +module Disk = Xen_api_client_lwt.Disk +module Data_channel = Xen_api_client_lwt.Data_channel let uri = ref "http://127.0.0.1/jsonrpc" diff --git a/ocaml/xen-api-client/lwt_examples/watch_metrics.ml b/ocaml/xen-api-client/lwt_examples/watch_metrics.ml index ae881fb296e..11e5dea3b48 100644 --- a/ocaml/xen-api-client/lwt_examples/watch_metrics.ml +++ b/ocaml/xen-api-client/lwt_examples/watch_metrics.ml @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -open Xen_api_lwt_unix +open Xen_api_client_lwt.Xen_api_lwt_unix open Lwt.Syntax let uri = ref "http://127.0.0.1/jsonrpc" diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index ec883f3deed..0eb6ef5ac1b 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -65,74 +65,6 @@ let diagnose_error f = exit 1 ) -let usage () = - Printf.fprintf stderr - "%s [args] - send commands to the xenops daemon\n" Sys.argv.(0) ; - Printf.fprintf stderr "%s add - add a VM from \n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s list [verbose] - query the states of known VMs\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s remove - forget about a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s start [paused] - start a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s pause - pause a VM\n" Sys.argv.(0) ; - Printf.fprintf stderr "%s unpause - unpause a VM\n" Sys.argv.(0) ; - Printf.fprintf stderr "%s shutdown - shutdown a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s reboot - reboot a VM\n" Sys.argv.(0) ; - Printf.fprintf stderr "%s suspend - suspend a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s resume - resume a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s migrate - migrate a VM to \n" Sys.argv.(0) ; - Printf.fprintf stderr - "%s vbd-list - query the states of a VM's block devices\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s console-list - query the states of a VM's consoles\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s pci-add - associate the PCI device \ - with \n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s pci-remove - disassociate the PCI device \ - with \n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s pci-list - query the states of a VM's PCI devices\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s cd-insert - insert a CD into a VBD\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s cd-eject - eject a CD from a VBD\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s export-metadata - export metadata associated with \n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s export-metadata-xm - export metadata associated with in xm \ - format\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s delay