gnu/packages/virtualization.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015, 2016, 2017, 2018 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2016, 2017, 2018. 2019, 2020, 2021 Efraim Flashner <efraim@flashner.co.il>
   5 ;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
   6 ;;; Copyright © 2017 Alex Vong <alexvong1995@gmail.com>
   7 ;;; Copyright © 2017 Andy Patterson <ajpatter@uwaterloo.ca>
   8 ;;; Copyright © 2017, 2018, 2019 Rutger Helling <rhelling@mykolab.com>
   9 ;;; Copyright © 2017–2021 Tobias Geerinckx-Rice <me@tobias.gr>
  10 ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
  11 ;;; Copyright © 2018 Sou Bunnbu <iyzsong@member.fsf.org>
  12 ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
  13 ;;; Copyright © 2019 Guy Fleury Iteriteka <hoonandon@gmail.com>
  14 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
  15 ;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
  16 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
  17 ;;; Copyright © 2020, 2021 Marius Bakke <mbakke@fastmail.com>
  18 ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  19 ;;; Copyright © 2020 Brett Gilio <brettg@gnu.org>
  20 ;;; Copyright © 2021 Leo Famulari <leo@famulari.name>
  21 ;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com>
  22 ;;; Copyright © 2021 Dion Mendel <guix@dm9.info>
  23 ;;; Copyright © 2021 Andrew Whatson <whatson@gmail.com>
  24 ;;; Copyright © 2021 Vincent Legoll <vincent.legoll@gmail.com>
  25 ;;; Copyright © 2021 Petr Hodina <phodina@protonmail.com>
  26 ;;; Copyright © 2021 Raghav Gururajan <rg@raghavgururajan.name>
  27 ;;;
  28 ;;; This file is part of GNU Guix.
  29 ;;;
  30 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  31 ;;; under the terms of the GNU General Public License as published by
  32 ;;; the Free Software Foundation; either version 3 of the License, or (at
  33 ;;; your option) any later version.
  34 ;;;
  35 ;;; GNU Guix is distributed in the hope that it will be useful, but
  36 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  37 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  38 ;;; GNU General Public License for more details.
  39 ;;;
  40 ;;; You should have received a copy of the GNU General Public License
  41 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  42
  43 (define-module (gnu packages virtualization)
  44   #:use-module (gnu packages)
  45   #:use-module (gnu packages acl)
  46   #:use-module (gnu packages admin)
  47   #:use-module (gnu packages assembly)
  48   #:use-module (gnu packages attr)
  49   #:use-module (gnu packages autotools)
  50   #:use-module (gnu packages backup)
  51   #:use-module (gnu packages base)
  52   #:use-module (gnu packages bash)
  53   #:use-module (gnu packages bison)
  54   #:use-module (gnu packages build-tools)
  55   #:use-module (gnu packages check)
  56   #:use-module (gnu packages cluster)
  57   #:use-module (gnu packages cmake)
  58   #:use-module (gnu packages compression)
  59   #:use-module (gnu packages cross-base)
  60   #:use-module (gnu packages curl)
  61   #:use-module (gnu packages cyrus-sasl)
  62   #:use-module (gnu packages debian)
  63   #:use-module (gnu packages disk)
  64   #:use-module (gnu packages dns)
  65   #:use-module (gnu packages docbook)
  66   #:use-module (gnu packages documentation)
  67   #:use-module (gnu packages figlet)
  68   #:use-module (gnu packages firmware)
  69   #:use-module (gnu packages flex)
  70   #:use-module (gnu packages fontutils)
  71   #:use-module (gnu packages freedesktop)
  72   #:use-module (gnu packages gettext)
  73   #:use-module (gnu packages gl)
  74   #:use-module (gnu packages glib)
  75   #:use-module (gnu packages gnome)
  76   #:use-module (gnu packages gnupg)
  77   #:use-module (gnu packages golang)
  78   #:use-module (gnu packages graphviz)
  79   #:use-module (gnu packages gtk)
  80   #:use-module (gnu packages haskell)
  81   #:use-module (gnu packages haskell-apps)
  82   #:use-module (gnu packages haskell-check)
  83   #:use-module (gnu packages haskell-crypto)
  84   #:use-module (gnu packages haskell-web)
  85   #:use-module (gnu packages haskell-xyz)
  86   #:use-module (gnu packages image)
  87   #:use-module (gnu packages libbsd)
  88   #:use-module (gnu packages libusb)
  89   #:use-module (gnu packages linux)
  90   #:use-module (gnu packages m4)
  91   #:use-module (gnu packages ncurses)
  92   #:use-module (gnu packages nettle)
  93   #:use-module (gnu packages networking)
  94   #:use-module (gnu packages ninja)
  95   #:use-module (gnu packages onc-rpc)
  96   #:use-module (gnu packages package-management)
  97   #:use-module (gnu packages perl)
  98   #:use-module (gnu packages pcre)
  99   #:use-module (gnu packages pkg-config)
 100   #:use-module (gnu packages polkit)
 101   #:use-module (gnu packages protobuf)
 102   #:use-module (gnu packages python)
 103   #:use-module (gnu packages python-build)
 104   #:use-module (gnu packages python-check)
 105   #:use-module (gnu packages python-crypto)
 106   #:use-module (gnu packages python-web)
 107   #:use-module (gnu packages python-xyz)
 108   #:use-module (gnu packages pulseaudio)
 109   #:use-module (gnu packages readline)
 110   #:use-module (gnu packages rsync)
 111   #:use-module (gnu packages selinux)
 112   #:use-module (gnu packages sdl)
 113   #:use-module (gnu packages sphinx)
 114   #:use-module (gnu packages spice)
 115   #:use-module (gnu packages ssh)
 116   #:use-module (gnu packages texinfo)
 117   #:use-module (gnu packages textutils)
 118   #:use-module (gnu packages tls)
 119   #:use-module (gnu packages web)
 120   #:use-module (gnu packages wget)
 121   #:use-module (gnu packages xdisorg)
 122   #:use-module (gnu packages xml)
 123   #:use-module (gnu packages xorg)
 124   #:use-module (guix build-system cmake)
 125   #:use-module (guix build-system gnu)
 126   #:use-module (guix build-system go)
 127   #:use-module (guix build-system meson)
 128   #:use-module (guix build-system python)
 129   #:use-module (guix build-system trivial)
 130   #:use-module (guix download)
 131   #:use-module (guix git-download)
 132   #:use-module ((guix licenses) #:prefix license:)
 133   #:use-module (guix packages)
 134   #:use-module (guix utils)
 135   #:use-module (srfi srfi-1)
 136   #:use-module (srfi srfi-26)
 137   #:use-module (ice-9 match))
 138
 139 (define (qemu-patch commit file-name sha256-bv)
 140   "Return an origin for COMMIT."
 141   (origin
 142     (method url-fetch)
 143     (uri (string-append
 144           "http://git.qemu.org/?p=qemu.git;a=commitdiff_plain;h="
 145           commit))
 146     (hash (content-hash sha256-bv sha256))
 147     (file-name file-name)))
 148
 149 (define-public qemu
 150   (package
 151     (name "qemu")
 152     (version "6.1.0")
 153     (source
 154      (origin
 155        (method url-fetch)
 156        (uri (string-append "https://download.qemu.org/qemu-"
 157                            version ".tar.xz"))
 158        (sha256
 159         (base32
 160          "15iw7982g6vc4jy1l9kk1z9sl5bm1bdbwr74y7nvwjs1nffhig7f"))
 161        (patches (search-patches "qemu-CVE-2021-20203.patch"
 162                                 "qemu-build-info-manual.patch"))
 163        (modules '((guix build utils)))
 164        (snippet
 165         '(begin
 166            ;; Delete the bundled meson copy.
 167            (delete-file-recursively "meson")))))
 168     (outputs '("out" "static" "doc"))   ;5.3 MiB of HTML docs
 169     (build-system gnu-build-system)
 170     (arguments
 171      ;; FIXME: Disable tests on i686 to work around
 172      ;; <https://bugs.gnu.org/40527>.
 173      `(#:tests? ,(or (%current-target-system)
 174                      (not (string=? "i686-linux" (%current-system))))
 175        #:configure-flags
 176        (let ((gcc (search-input-file %build-inputs "/bin/gcc"))
 177              (out (assoc-ref %outputs "out")))
 178          (list (string-append "--cc=" gcc)
 179                ;; Some architectures insist on using HOST_CC.
 180                (string-append "--host-cc=" gcc)
 181                (string-append "--prefix=" out)
 182                "--sysconfdir=/etc"
 183                (string-append "--smbd=" out "/libexec/samba-wrapper")
 184                "--disable-debug-info"   ;for space considerations
 185                ;; The binaries need to be linked against -lrt.
 186                (string-append "--extra-ldflags=-lrt")))
 187        ;; Make build and test output verbose to facilitate investigation upon failure.
 188        #:make-flags '("V=1")
 189        #:modules ((srfi srfi-1)
 190                   (srfi srfi-26)
 191                   (ice-9 ftw)
 192                   (ice-9 match)
 193                   ,@%gnu-build-system-modules)
 194        #:phases
 195        (modify-phases %standard-phases
 196          (add-after 'unpack 'extend-test-time-outs
 197            (lambda _
 198              ;; These tests can time out on heavily-loaded and/or slow storage.
 199              (substitute* (cons* "tests/qemu-iotests/common.qemu"
 200                                  (find-files "tests/qemu-iotests" "^[0-9]+$"))
 201                (("QEMU_COMM_TIMEOUT=[0-9]+" match)
 202                 (string-append match "9")))))
 203          (add-after 'unpack 'disable-unusable-tests
 204            (lambda _
 205              (substitute* "tests/unit/meson.build"
 206                ;; Comment out the test-qga test, which needs /sys and
 207                ;; fails within the build environment.
 208                (("tests.*test-qga.*$" all)
 209                 (string-append "# " all))
 210                ;; Comment out the test-char test, which needs networking and
 211                ;; fails within the build environment.
 212                ((".*'test-char':.*" all)
 213                 (string-append "# " all)))))
 214          (add-after 'patch-source-shebangs 'patch-embedded-shebangs
 215            (lambda _
 216              ;; Ensure the executables created by these source files reference
 217              ;; /bin/sh from the store so they work inside the build container.
 218              (substitute* '("block/cloop.c" "migration/exec.c"
 219                             "net/tap.c" "tests/qtest/libqtest.c"
 220                             "tests/qtest/vhost-user-blk-test.c")
 221                (("/bin/sh") (which "sh")))
 222              (substitute* "tests/qemu-iotests/testenv.py"
 223                (("#!/usr/bin/env python3")
 224                 (string-append "#!" (which "python3"))))))
 225          (add-before 'configure 'fix-optionrom-makefile
 226            (lambda _
 227              ;; Work around the inability of the rules defined in this
 228              ;; Makefile to locate the firmware files (e.g.: No rule to make
 229              ;; target 'multiboot.bin') by extending the VPATH.
 230              (substitute* "pc-bios/optionrom/Makefile"
 231                (("^VPATH = \\$\\(SRC_DIR\\)")
 232                 "VPATH = $(SRC_DIR):$(TOPSRC_DIR)/pc-bios"))))
 233          ;; XXX ./configure is being re-run at beginning of build phase...
 234          (replace 'configure
 235            (lambda* (#:key inputs outputs configure-flags #:allow-other-keys)
 236              ;; The `configure' script doesn't understand some of the
 237              ;; GNU options.  Thus, add a new phase that's compatible.
 238              (let ((out (assoc-ref outputs "out")))
 239                (setenv "SHELL" (which "bash"))
 240                ;; Ensure config.status gets the correct shebang off the bat.
 241                ;; The build system gets confused if we change it later and
 242                ;; attempts to re-run the whole configuration, and fails.
 243                (substitute* "configure"
 244                  (("#!/bin/sh")
 245                   (string-append "#!" (which "sh"))))
 246                (mkdir-p "b/qemu")
 247                (chdir "b/qemu")
 248                (apply invoke "../../configure" configure-flags))))
 249          ;; Configure, build and install QEMU user-emulation static binaries.
 250          (add-after 'configure 'configure-user-static
 251            (lambda* (#:key inputs outputs #:allow-other-keys)
 252              (let* ((gcc (search-input-file inputs "/bin/gcc"))
 253                     (static (assoc-ref outputs "static"))
 254                     ;; This is the common set of configure flags; it is
 255                     ;; duplicated here to isolate this phase from manipulations
 256                     ;; to the #:configure-flags build argument, as done in
 257                     ;; derived packages such as qemu-minimal.
 258                     (configure-flags (list (string-append "--cc=" gcc)
 259                                            (string-append "--host-cc=" gcc)
 260                                            "--sysconfdir=/etc"
 261                                            "--disable-debug-info")))
 262                (mkdir-p "../user-static")
 263                (with-directory-excursion "../user-static"
 264                  (apply invoke "../../configure"
 265                         "--static"
 266                         "--disable-docs" ;already built
 267                         "--disable-system"
 268                         "--enable-linux-user"
 269                         (string-append "--prefix=" static)
 270                         configure-flags)))))
 271          (add-after 'build 'build-user-static
 272            (lambda args
 273              (with-directory-excursion "../user-static"
 274                (apply (assoc-ref %standard-phases 'build) args))))
 275          (add-after 'install 'install-user-static
 276            (lambda* (#:key outputs #:allow-other-keys)
 277              (let* ((static (assoc-ref outputs "static"))
 278                     (bin (string-append static "/bin")))
 279                (with-directory-excursion "../user-static"
 280                  (for-each (cut install-file <> bin)
 281                            (append-map (cut find-files <> "^qemu-" #:stat stat)
 282                                        (scandir "."
 283                                                 (cut string-suffix?
 284                                                      "-linux-user" <>))))))))
 285          ;; Create a wrapper for Samba. This allows QEMU to use Samba without
 286          ;; pulling it in as an input. Note that you need to explicitly install
 287          ;; Samba in your Guix profile for Samba support.
 288          (add-after 'install 'create-samba-wrapper
 289            (lambda* (#:key inputs outputs #:allow-other-keys)
 290              (let* ((out    (assoc-ref outputs "out"))
 291                     (libexec (string-append out "/libexec")))
 292                (call-with-output-file "samba-wrapper"
 293                  (lambda (port)
 294                    (format port "#!/bin/sh
 295 exec smbd $@")))
 296                (chmod "samba-wrapper" #o755)
 297                (install-file "samba-wrapper" libexec))))
 298          (add-after 'install 'move-html-doc
 299            (lambda* (#:key inputs outputs #:allow-other-keys)
 300              (let* ((out (assoc-ref outputs "out"))
 301                     (doc (assoc-ref outputs "doc"))
 302                     (qemu-doc (string-append doc "/share/doc/qemu-" ,version)))
 303                (mkdir-p qemu-doc)
 304                (rename-file (string-append out "/share/doc/qemu")
 305                             (string-append qemu-doc "/html"))))))))
 306     (inputs                             ; TODO: Add optional inputs.
 307      `(("alsa-lib" ,alsa-lib)
 308        ("attr" ,attr)
 309        ("glib" ,glib)
 310        ("gtk+" ,gtk+)
 311        ("libaio" ,libaio)
 312        ("libattr" ,attr)
 313        ("libcacard" ,libcacard)  ; smartcard support
 314        ("libcap-ng" ,libcap-ng)  ; virtfs support requires libcap-ng & libattr
 315        ("libdrm" ,libdrm)
 316        ("libepoxy" ,libepoxy)
 317        ("libjpeg" ,libjpeg-turbo)
 318        ("libpng" ,libpng)
 319        ("libseccomp" ,libseccomp)
 320        ("libusb" ,libusb)               ;USB pass-through support
 321        ("mesa" ,mesa)
 322        ("ncurses" ,ncurses)
 323        ;; ("pciutils" ,pciutils)
 324        ("pixman" ,pixman)
 325        ("pulseaudio" ,pulseaudio)
 326        ("sdl2" ,sdl2)
 327        ("spice" ,spice)
 328        ("usbredir" ,usbredir)
 329        ("util-linux" ,util-linux)
 330        ("vde2" ,vde2)
 331        ("virglrenderer" ,virglrenderer)
 332        ("zlib" ,zlib)))
 333     (native-inputs `(("gettext" ,gettext-minimal)
 334                      ("glib:bin" ,glib "bin") ; gtester, etc.
 335                      ("perl" ,perl)
 336                      ("flex" ,flex)
 337                      ("bison" ,bison)
 338                      ("meson" ,meson)
 339                      ("ninja" ,ninja)
 340                      ("pkg-config" ,pkg-config)
 341                      ("python-wrapper" ,python-wrapper)
 342                      ("python-sphinx" ,python-sphinx)
 343                      ("python-sphinx-rtd-theme" ,python-sphinx-rtd-theme)
 344                      ("texinfo" ,texinfo)
 345                      ;; The following static libraries are required to build
 346                      ;; the static output of QEMU.
 347                      ("glib:static" ,glib "static")
 348                      ("pcre:static" ,pcre "static")
 349                      ("zlib:static" ,zlib "static")))
 350     (home-page "https://www.qemu.org")
 351     (synopsis "Machine emulator and virtualizer")
 352     (description
 353      "QEMU is a generic machine emulator and virtualizer.
 354
 355 When used as a machine emulator, QEMU can run OSes and programs made for one
 356 machine (e.g. an ARM board) on a different machine---e.g., your own PC.  By
 357 using dynamic translation, it achieves very good performance.
 358
 359 When used as a virtualizer, QEMU achieves near native performances by
 360 executing the guest code directly on the host CPU.  QEMU supports
 361 virtualization when executing under the Xen hypervisor or using
 362 the KVM kernel module in Linux.  When using KVM, QEMU can virtualize x86,
 363 server and embedded PowerPC, and S390 guests.")
 364
 365     ;; Many files are GPLv2+, but some are GPLv2-only---e.g., `memory.c'.
 366     (license license:gpl2)
 367
 368     ;; Several tests fail on MIPS; see <http://hydra.gnu.org/build/117914>.
 369     (supported-systems (fold delete %supported-systems
 370                              '("mips64el-linux" "i586-gnu")))))
 371
 372 (define-public qemu-minimal
 373   ;; QEMU without GUI support, only supporting the host's architecture
 374   (package
 375     (inherit qemu)
 376     (name "qemu-minimal")
 377     (outputs '("out" "doc"))
 378     (synopsis
 379      "Machine emulator and virtualizer (without GUI) for the host architecture")
 380     (arguments
 381      (substitute-keyword-arguments (package-arguments qemu)
 382        ((#:configure-flags configure-flags '(list))
 383         ;; Restrict to the host's architecture.
 384         (let* ((system (or (%current-target-system)
 385                            (%current-system)))
 386                (target-list-arg
 387                 (match system
 388                   ((? (cut string-prefix? "i686" <>))
 389                    "--target-list=i386-softmmu")
 390                   ((? (cut string-prefix? "x86_64" <>))
 391                    "--target-list=i386-softmmu,x86_64-softmmu")
 392                   ((? (cut string-prefix? "mips64" <>))
 393                    (string-append "--target-list=mips-softmmu,mipsel-softmmu,"
 394                                   "mips64-softmmu,mips64el-softmmu"))
 395                   ((? (cut string-prefix? "mips" <>))
 396                    "--target-list=mips-softmmu,mipsel-softmmu")
 397                   ((? (cut string-prefix? "aarch64" <>))
 398                    "--target-list=arm-softmmu,aarch64-softmmu")
 399                   ((? (cut string-prefix? "arm" <>))
 400                    "--target-list=arm-softmmu")
 401                   ((? (cut string-prefix? "alpha" <>))
 402                    "--target-list=alpha-softmmu")
 403                   ((? (cut string-prefix? "powerpc64" <>))
 404                    "--target-list=ppc-softmmu,ppc64-softmmu")
 405                   ((? (cut string-prefix? "powerpc" <>))
 406                    "--target-list=ppc-softmmu")
 407                   ((? (cut string-prefix? "s390" <>))
 408                    "--target-list=s390x-softmmu")
 409                   ((? (cut string-prefix? "riscv" <>))
 410                    "--target-list=riscv32-softmmu,riscv64-softmmu")
 411                   (else       ; An empty list actually builds all the targets.
 412                    '()))))
 413           `(cons ,target-list-arg ,configure-flags)))
 414        ((#:phases phases)
 415         `(modify-phases ,phases
 416            (delete 'configure-user-static)
 417            (delete 'build-user-static)
 418            (delete 'install-user-static)))))
 419
 420     ;; Remove dependencies on optional libraries, notably GUI libraries.
 421     (native-inputs (fold alist-delete (package-native-inputs qemu)
 422                          '("gettext" "glib:static" "pcre:static" "zlib:static")))
 423     (inputs (fold alist-delete (package-inputs qemu)
 424                   '("libusb" "mesa" "sdl2" "spice" "virglrenderer" "gtk+"
 425                     "usbredir" "libdrm" "libepoxy" "pulseaudio" "vde2"
 426                     "libcacard")))))
 427
 428 (define (system->qemu-target system)
 429   (cond
 430    ((string-prefix? "i686" system)
 431     "qemu-system-i386")
 432    ((string-prefix? "arm" system)
 433     "qemu-system-arm")
 434    (else
 435     (string-append "qemu-system-" (match (string-split system #\-)
 436                                     ((arch kernel) arch)
 437                                     (_ system))))))
 438
 439 (define-public libx86emu
 440   (package
 441     (name "libx86emu")
 442     (version "3.1")
 443     (home-page "https://github.com/wfeldt/libx86emu")
 444     (source
 445      (origin
 446        (method git-fetch)
 447        (uri
 448         (git-reference
 449          (url home-page)
 450          (commit version)))
 451        (file-name (git-file-name name version))
 452        (modules
 453         '((guix build utils)))
 454        (snippet
 455         `(begin
 456            ;; Remove git2log program file.
 457            (delete-file "git2log")
 458            ;; Remove variables that depends on git2log.
 459            (substitute* "Makefile"
 460              (("GIT2LOG.*=.*$") "")
 461              (("GITDEPS.*=.*$") "")
 462              (("BRANCH.*=.*$") ""))
 463            #t))
 464        (sha256
 465         (base32 "104xqc6nj9rpi7knl3dfqvasf087hlz2n5yndb1iycw35a6j509b"))))
 466     (build-system gnu-build-system)
 467     (arguments
 468      `(#:test-target "test"
 469        #:phases
 470        (modify-phases %standard-phases
 471          (add-after 'unpack 'patch
 472            (lambda* (#:key outputs #:allow-other-keys)
 473              (let* ((out (assoc-ref outputs "out"))
 474                     (include (string-append out "/include"))
 475                     (lib (string-append out "/lib")))
 476                ;; Correct the values of version and install directories.
 477                (substitute* "Makefile"
 478                  (("VERSION.*=.*$")
 479                   (string-append "VERSION := "
 480                                  ,version "\n"))
 481                  (("PREFIX.*=.*$")
 482                   (string-append "PREFIX := " out "\n"))
 483                  (("MAJOR_VERSION.*=.*$")
 484                   (string-append "MAJOR_VERSION := "
 485                                  ,(version-major version) "\n"))
 486                  (("LIBDIR.*=.*$")
 487                   (string-append "LIBDIR = " lib "\n"))
 488                  (("/usr/include") include)))))
 489          (delete 'configure))))         ; no configure script
 490     (native-inputs
 491      `(("nasm" ,nasm)
 492        ("perl" ,perl)))
 493     (synopsis "Library for x86 emulation")
 494     (description "Libx86emu is a small library to emulate x86 instructions.  The
 495 focus here is not a complete emulation but to cover enough for typical
 496 firmware blobs.  You can
 497 @enumerate
 498 @item intercept any memory access or directly map real memory ranges
 499 @item intercept any i/o access, map real i/o ports, or block any real i/o
 500 @item intercept any interrupt
 501 @item add a hook to run after each instruction
 502 @item recognize a special x86 instruction that can trigger logging
 503 @item use integrated logging
 504 @end enumerate")
 505     (license (license:x11-style "file://LICENSE"))))
 506
 507 (define-public ganeti
 508   (package
 509     (name "ganeti")
 510     (version "3.0.1")
 511     (source (origin
 512               (method git-fetch)
 513               (uri (git-reference
 514                     (url "https://github.com/ganeti/ganeti")
 515                     (commit (string-append "v" version))))
 516               (sha256
 517                (base32 "1i7gx0sdx9316fnldbv738s0ihym1370nhc1chk0biandkl8vvq0"))
 518               (file-name (git-file-name name version))
 519               (patches (search-patches "ganeti-shepherd-support.patch"
 520                                        "ganeti-shepherd-master-failover.patch"
 521                                        "ganeti-sphinx-compat.patch"
 522                                        "ganeti-haskell-compat.patch"
 523                                        "ganeti-haskell-pythondir.patch"
 524                                        "ganeti-disable-version-symlinks.patch"))))
 525     (build-system gnu-build-system)
 526     (arguments
 527      `(#:imported-modules (,@%gnu-build-system-modules
 528                            (guix build haskell-build-system)
 529                            (guix build python-build-system))
 530        #:modules (,@%gnu-build-system-modules
 531                   ((guix build haskell-build-system) #:prefix haskell:)
 532                   (srfi srfi-1)
 533                   (srfi srfi-26)
 534                   (ice-9 match)
 535                   (ice-9 rdelim))
 536
 537        ;; The default test target includes a lot of checks that are only really
 538        ;; relevant for developers such as NEWS file checking, line lengths, etc.
 539        ;; We are only interested in the "py-tests" and "hs-tests" targets: this
 540        ;; is the closest we've got even though it includes a little more.
 541        #:test-target "check-TESTS"
 542
 543        #:configure-flags
 544        (list "--localstatedir=/var"
 545              "--sharedstatedir=/var"
 546              "--sysconfdir=/etc"
 547              "--enable-haskell-tests"
 548
 549              ;; By default, the build system installs everything to versioned
 550              ;; directories such as $libdir/3.0 and relies on a $libdir/default
 551              ;; symlink pointed from /etc/ganeti/{lib,share} to actually function.
 552              ;; This is done to accommodate installing multiple versions in
 553              ;; parallel, but is of little use to us as Guix users can just
 554              ;; roll back and forth.  Thus, disable it for simplicity.
 555              "--disable-version-links"
 556
 557              ;; Ganeti can optionally take control over SSH host keys and
 558              ;; distribute them to nodes as they are added, and also rotate keys
 559              ;; with 'gnt-cluster renew-crypto --new-ssh-keys'.  Thus it needs to
 560              ;; know how to restart the SSH daemon.
 561              "--with-sshd-restart-command='herd restart ssh-daemon'"
 562
 563              ;; Look for OS definitions in this directory by default.  It can
 564              ;; be changed in the cluster configuration.
 565              "--with-os-search-path=/run/current-system/profile/share/ganeti/os"
 566
 567              ;; The default QEMU executable to use.  We don't use the package
 568              ;; here because this entry is stored in the cluster configuration.
 569              (string-append "--with-kvm-path=/run/current-system/profile/bin/"
 570                             ,(system->qemu-target (%current-system))))
 571        #:phases
 572        (modify-phases %standard-phases
 573          (add-after 'unpack 'patch-version-constraints
 574            (lambda _
 575              ;; Loosen version constraints for compatibility with Stackage 18.10.
 576              (substitute* "cabal/ganeti.template.cabal"
 577                (("(.*base64-bytestring.*) < 1\\.1" _ match)
 578                 (string-append match " < 1.2"))
 579                (("(.*QuickCheck.*) < 2\\.14" _ match)
 580                 (string-append match " < 2.15")))))
 581          (add-after 'unpack 'create-vcs-version
 582            (lambda _
 583              ;; If we are building from a git checkout, we need to create a
 584              ;; 'vcs-version' file manually because the build system does
 585              ;; not have access to the git repository information.
 586              (unless (file-exists? "vcs-version")
 587                (call-with-output-file "vcs-version"
 588                  (lambda (port)
 589                    (format port "v~a~%" ,version))))))
 590          (add-after 'unpack 'patch-absolute-file-names
 591            (lambda _
 592              (substitute* '("lib/utils/process.py"
 593                             "lib/utils/text.py"
 594                             "src/Ganeti/Constants.hs"
 595                             "src/Ganeti/HTools/CLI.hs"
 596                             "test/py/ganeti.config_unittest.py"
 597                             "test/py/ganeti.hooks_unittest.py"
 598                             "test/py/ganeti.utils.process_unittest.py"
 599                             "test/py/ganeti.utils.text_unittest.py"
 600                             "test/py/ganeti.utils.wrapper_unittest.py")
 601                (("/bin/sh") (which "sh"))
 602                (("/bin/bash") (which "bash"))
 603                (("/usr/bin/env") (which "env"))
 604                (("/bin/true") (which "true")))
 605
 606              ;; This script is called by the node daemon at startup to perform
 607              ;; sanity checks on the cluster IP addresses, and it is also used
 608              ;; in a master-failover scenario.  Add absolute references to
 609              ;; avoid propagating these executables.
 610              (substitute* "tools/master-ip-setup"
 611                (("arping") (which "arping"))
 612                (("ndisc6") (which "ndisc6"))
 613                (("fping") (which "fping"))
 614                (("grep") (which "grep"))
 615                (("ip addr") (string-append (which "ip") " addr")))))
 616          (add-after 'unpack 'override-builtin-PATH
 617            (lambda _
 618              ;; Ganeti runs OS install scripts and similar with a built-in
 619              ;; hard coded PATH.  Patch so it works on Guix System.
 620              (substitute* "src/Ganeti/Constants.hs"
 621                (("/sbin:/bin:/usr/sbin:/usr/bin")
 622                 "/run/setuid-programs:/run/current-system/profile/sbin:\
 623 /run/current-system/profile/bin"))))
 624          (add-after 'bootstrap 'patch-sphinx-version-detection
 625            (lambda _
 626              ;; The build system runs 'sphinx-build --version' to verify that
 627              ;; the Sphinx is recent enough, but does not expect the
 628              ;; .sphinx-build-real executable name created by the Sphinx wrapper.
 629              (substitute* "configure"
 630                (("\\$SPHINX --version 2>&1")
 631                 "$SPHINX --version 2>&1 \
 632 | sed 's/.sphinx-build-real/sphinx-build/g'"))))
 633
 634          ;; The build system invokes Cabal and GHC, which do not work with
 635          ;; GHC_PACKAGE_PATH: <https://github.com/haskell/cabal/issues/3728>.
 636          ;; Tweak the build system to do roughly what haskell-build-system does.
 637          (add-before 'configure 'configure-haskell
 638            (assoc-ref haskell:%standard-phases 'setup-compiler))
 639          (add-after 'configure 'do-not-use-GHC_PACKAGE_PATH
 640            (lambda _
 641              (unsetenv "GHC_PACKAGE_PATH")
 642              (substitute* "Makefile"
 643                (("\\$\\(CABAL\\)")
 644                 "$(CABAL) --package-db=../package.conf.d")
 645                (("\\$\\(GHC\\)")
 646                 "$(GHC) -package-db=../package.conf.d"))))
 647          (add-after 'configure 'make-ghc-use-shared-libraries
 648            (lambda _
 649              (substitute* "Makefile"
 650                (("HFLAGS =") "HFLAGS = -dynamic -fPIC"))))
 651          (add-after 'configure 'fix-installation-directories
 652            (lambda _
 653              (substitute* "Makefile"
 654                ;; Do not attempt to create /var during install.
 655                (("\\$\\(DESTDIR\\)\\$\\{localstatedir\\}")
 656                 "$(DESTDIR)${prefix}${localstatedir}")
 657                ;; Similarly, do not attempt to install the sample ifup scripts
 658                ;; to /etc/ganeti.
 659                (("\\$\\(DESTDIR\\)\\$\\(ifupdir\\)")
 660                 "$(DESTDIR)${prefix}$(ifupdir)"))))
 661          (add-before 'build 'adjust-tests
 662            (lambda _
 663              ;; Disable tests that can not run.  Do it early to prevent
 664              ;; touching the Makefile later and triggering a needless rebuild.
 665              (substitute* "Makefile"
 666                ;; These tests expect the presence of a 'root' user (via
 667                ;; ganeti/runtime.py), which fails in the build environment.
 668                (("test/py/ganeti\\.asyncnotifier_unittest\\.py") "")
 669                (("test/py/ganeti\\.backend_unittest\\.py") "")
 670                (("test/py/ganeti\\.daemon_unittest\\.py") "")
 671                (("test/py/ganeti\\.tools\\.ensure_dirs_unittest\\.py") "")
 672                (("test/py/ganeti\\.utils\\.io_unittest-runasroot\\.py") "")
 673                ;; Disable the bash_completion test, as it requires the full
 674                ;; bash instead of bash-minimal.
 675                (("test/py/bash_completion\\.bash")
 676                 "")
 677                ;; This test requires networking.
 678                (("test/py/import-export_unittest\\.bash")
 679                 ""))))
 680          (add-after 'build 'build-bash-completions
 681            (lambda _
 682              (setenv "PYTHONPATH" ".")
 683              (invoke "./autotools/build-bash-completion")
 684              (unsetenv "PYTHONPATH")))
 685          (add-before 'check 'pre-check
 686            (lambda* (#:key inputs #:allow-other-keys)
 687              ;; Set TZDIR so that time zones are found.
 688              (setenv "TZDIR" (search-input-directory inputs "share/zoneinfo"))
 689
 690              (substitute* "test/py/ganeti.utils.process_unittest.py"
 691                ;; This test attempts to run an executable with
 692                ;; RunCmd(..., reset_env=True), which fails because the default
 693                ;; PATH from Constants.hs does not exist in the build container.
 694                ((".*def testResetEnv.*" all)
 695                 (string-append "  @unittest.skipIf(True, "
 696                                "\"cannot reset env in the build container\")\n"
 697                                all))
 698
 699                ;; XXX: Somehow this test fails in the build container, but
 700                ;; works in 'guix environment -C', even without /bin/sh?
 701                ((".*def testPidFile.*" all)
 702                 (string-append "  @unittest.skipIf(True, "
 703                                "\"testPidFile fails in the build container\")\n"
 704                                all)))
 705
 706              ;; XXX: Why are these links not added automatically.
 707              (with-directory-excursion "test/hs"
 708                (for-each (lambda (file)
 709                            (symlink "../../src/htools" file))
 710                          '("hspace" "hscan" "hinfo" "hbal" "hroller"
 711                            "hcheck" "hail" "hsqueeze")))))
 712          (add-after 'install 'install-bash-completions
 713            (lambda* (#:key outputs #:allow-other-keys)
 714              (let* ((out (assoc-ref outputs "out"))
 715                     (compdir (string-append out "/etc/bash_completion.d")))
 716                (mkdir-p compdir)
 717                (copy-file "doc/examples/bash_completion"
 718                           (string-append compdir "/ganeti"))
 719                ;; The one file contains completions for many different
 720                ;; executables.  Create symlinks for found completions.
 721                (with-directory-excursion compdir
 722                  (for-each
 723                   (lambda (prog) (symlink "ganeti" prog))
 724                   (call-with-input-file "ganeti"
 725                     (lambda (port)
 726                       (let loop ((line (read-line port))
 727                                  (progs '()))
 728                         (if (eof-object? line)
 729                             progs
 730                             (if (string-prefix? "complete" line)
 731                                 (loop (read-line port)
 732                                       ;; Extract "prog" from lines of the form:
 733                                       ;; "complete -F _prog -o filenames prog".
 734                                       ;; Note that 'burnin' is listed with the
 735                                       ;; absolute file name, which is why we
 736                                       ;; run everything through 'basename'.
 737                                       (match (string-split line #\ )
 738                                         ((commands ... prog)
 739                                          (cons (basename prog) progs))))
 740                                 (loop (read-line port) progs)))))))))))
 741          ;; Wrap all executables with GUIX_PYTHONPATH.  We can't borrow
 742          ;; the phase from python-build-system because we also need to wrap
 743          ;; the scripts in $out/lib/ganeti such as "node-daemon-setup".
 744          (add-after 'install 'wrap
 745            (lambda* (#:key outputs #:allow-other-keys)
 746              (let* ((out (assoc-ref outputs "out"))
 747                     (sbin (string-append out "/sbin"))
 748                     (lib (string-append out "/lib")))
 749                (define (shell-script? file)
 750                  (call-with-ascii-input-file file
 751                    (lambda (port)
 752                      (let ((shebang (false-if-exception (read-line port))))
 753                        (and shebang
 754                             (string-prefix? "#!" shebang)
 755                             (or (string-contains shebang "/bin/bash")
 756                                 (string-contains shebang "/bin/sh")))))))
 757
 758                (define* (wrap? file #:rest _)
 759                  ;; Do not wrap shell scripts because some are meant to be
 760                  ;; sourced, which breaks if they are wrapped.  We do wrap
 761                  ;; the Haskell executables because some call out to Python
 762                  ;; directly.
 763                  (and (executable-file? file)
 764                       (not (symbolic-link? file))
 765                       (not (shell-script? file))))
 766
 767                (for-each (lambda (file)
 768                            (wrap-program file
 769                              `("GUIX_PYTHONPATH" ":" prefix
 770                                (,(getenv "GUIX_PYTHONPATH")))))
 771                          (append-map (cut find-files <> wrap?)
 772                                      (list (string-append lib "/ganeti")
 773                                            sbin)))))))))
 774     (native-inputs
 775      `(("haskell" ,ghc)
 776        ("cabal" ,cabal-install)
 777        ("m4" ,m4)
 778
 779        ;; These inputs are necessary to bootstrap the package, because we
 780        ;; have patched the build system.
 781        ("autoconf" ,autoconf)
 782        ("automake" ,automake)
 783
 784        ;; For the documentation.
 785        ("python-docutils" ,python-docutils)
 786        ("sphinx" ,python-sphinx)
 787        ("pandoc" ,pandoc)
 788        ("dot" ,graphviz)
 789
 790        ;; Test dependencies.
 791        ("fakeroot" ,fakeroot)
 792        ("ghc-temporary" ,ghc-temporary)
 793        ("ghc-test-framework" ,ghc-test-framework)
 794        ("ghc-test-framework-hunit" ,ghc-test-framework-hunit)
 795        ("ghc-test-framework-quickcheck2" ,ghc-test-framework-quickcheck2)
 796        ("python-mock" ,python-mock)
 797        ("python-pyyaml" ,python-pyyaml)
 798        ("openssh" ,openssh)
 799        ("procps" ,procps)
 800        ("shelltestrunner" ,shelltestrunner)
 801        ("tzdata" ,tzdata-for-tests)))
 802     (inputs
 803      `(("arping" ,iputils)              ;must be the iputils version
 804        ("curl" ,curl)
 805        ("fping" ,fping)
 806        ("iproute2" ,iproute)
 807        ("ndisc6" ,ndisc6)
 808        ("socat" ,socat)
 809        ("qemu" ,qemu-minimal)           ;for qemu-img
 810        ("ghc-attoparsec" ,ghc-attoparsec)
 811        ("ghc-base64-bytestring" ,ghc-base64-bytestring)
 812        ("ghc-cryptonite" ,ghc-cryptonite)
 813        ("ghc-curl" ,ghc-curl)
 814        ("ghc-hinotify" ,ghc-hinotify)
 815        ("ghc-hslogger" ,ghc-hslogger)
 816        ("ghc-json" ,ghc-json)
 817        ("ghc-lens" ,ghc-lens)
 818        ("ghc-lifted-base" ,ghc-lifted-base)
 819        ("ghc-network" ,ghc-network)
 820        ("ghc-old-time" ,ghc-old-time)
 821        ("ghc-psqueue" ,ghc-psqueue)
 822        ("ghc-regex-pcre" ,ghc-regex-pcre)
 823        ("ghc-utf8-string" ,ghc-utf8-string)
 824        ("ghc-zlib" ,ghc-zlib)
 825
 826        ;; For the optional metadata daemon.
 827        ("ghc-snap-core" ,ghc-snap-core)
 828        ("ghc-snap-server" ,ghc-snap-server)
 829
 830        ("python" ,python)
 831        ("python-pyopenssl" ,python-pyopenssl)
 832        ("python-simplejson" ,python-simplejson)
 833        ("python-pyparsing" ,python-pyparsing)
 834        ("python-pyinotify" ,python-pyinotify)
 835        ("python-pycurl" ,python-pycurl)
 836        ("python-bitarray" ,python-bitarray)
 837        ("python-paramiko" ,python-paramiko)
 838        ("python-psutil" ,python-psutil)))
 839     (home-page "https://www.ganeti.org/")
 840     (synopsis "Cluster-based virtual machine management system")
 841     (description
 842      "Ganeti is a virtual machine management tool built on top of existing
 843 virtualization technologies such as Xen or KVM.  Ganeti controls:
 844
 845 @itemize @bullet
 846 @item Disk creation management;
 847 @item Operating system installation for instances (in co-operation with
 848 OS-specific install scripts); and
 849 @item Startup, shutdown, and failover between physical systems.
 850 @end itemize
 851
 852 Ganeti is designed to facilitate cluster management of virtual servers and
 853 to provide fast and simple recovery after physical failures, using
 854 commodity hardware.")
 855     (license license:bsd-2)))
 856
 857 (define-public ganeti-instance-guix
 858   (package
 859     (name "ganeti-instance-guix")
 860     (version "0.6")
 861     (home-page "https://github.com/mbakke/ganeti-instance-guix")
 862     (source (origin
 863               (method git-fetch)
 864               (uri (git-reference (url home-page) (commit version)))
 865               (file-name (git-file-name name version))
 866               (sha256
 867                (base32
 868                 "0aa08irpcpns6mhjgsplc5f0p8ab1qcr9ah1gj5z66kxgqyflzrp"))))
 869     (build-system gnu-build-system)
 870     (arguments
 871      '(#:configure-flags '("--sysconfdir=/etc" "--localstatedir=/var")))
 872     (native-inputs
 873      `(("autoconf" ,autoconf)
 874        ("automake" ,automake)))
 875     (inputs
 876      `(("util-linux" ,util-linux)
 877        ("qemu-img" ,qemu-minimal)))
 878     (synopsis "Guix OS integration for Ganeti")
 879     (description
 880      "This package provides a guest OS definition for Ganeti that uses
 881 Guix to build virtual machines.")
 882     (license license:gpl3+)))
 883
 884 (define-public ganeti-instance-debootstrap
 885   (package
 886     (name "ganeti-instance-debootstrap")
 887     ;; We need two commits on top of the latest release for compatibility
 888     ;; with newer sfdisk, as well as gnt-network integration.
 889     (version "0.16-2-ge145396")
 890     (home-page "https://github.com/ganeti/instance-debootstrap")
 891     (source (origin
 892               (method git-fetch)
 893               (uri (git-reference (url home-page) (commit version)))
 894               (file-name (git-file-name name version))
 895               (sha256
 896                (base32
 897                 "0f2isw9d8lawzj21rrq1q9xhq8xfa65rqbhqmrn59z201x9q1336"))))
 898     (build-system gnu-build-system)
 899     (arguments
 900      '(#:configure-flags '("--sysconfdir=/etc" "--localstatedir=/var")
 901        #:phases (modify-phases %standard-phases
 902                   (add-after 'unpack 'add-absolute-references
 903                     (lambda _
 904                       (substitute* "common.sh.in"
 905                         (("/sbin/blkid") (which "blkid"))
 906                         (("kpartx -")
 907                          (string-append (which "kpartx") " -")))
 908                       (substitute* "import"
 909                         (("restore -r")
 910                          (string-append (which "restore") " -r")))
 911                       (substitute* "export"
 912                         (("dump -0")
 913                          (string-append (which "dump") " -0")))
 914                       (substitute* "create"
 915                         (("debootstrap") (which "debootstrap"))
 916                         (("`which run-parts`") (which "run-parts"))
 917                         ;; Here we actually need to hard code /bin/passwd
 918                         ;; because it's called via chroot, which fails if
 919                         ;; "/bin" is not in PATH.
 920                         (("passwd") "/bin/passwd"))
 921                       #t))
 922                   (add-after 'unpack 'set-dpkg-arch
 923                     (lambda* (#:key system #:allow-other-keys)
 924                       ;; The create script passes --arch to debootstrap,
 925                       ;; and defaults to `dpkg --print-architecture` when
 926                       ;; ARCH is not set in variant.conf.  Hard code the
 927                       ;; build-time architecture to avoid the dpkg dependency.
 928                       (let ((dpkg-arch
 929                              (cond ((string-prefix? "x86_64" system)
 930                                     "amd64")
 931                                    ((string-prefix? "i686" system)
 932                                     "i386")
 933                                    ((string-prefix? "aarch64" system)
 934                                     "arm64")
 935                                    (else (car (string-split system #\-))))))
 936                         (substitute* "create"
 937                           (("`dpkg --print-architecture`")
 938                            dpkg-arch))
 939                         #t)))
 940                   (add-after 'configure 'adjust-Makefile
 941                     (lambda _
 942                       ;; Do not attempt to create /etc/ganeti/instance-debootstrap
 943                       ;; and /etc/default/ganeti-instance-debootstrap during install.
 944                       ;; They are created by the Ganeti service.
 945                       (substitute* "Makefile"
 946                         (("\\$\\(variantsdir\\)")
 947                          "$(prefix)/etc/ganeti/instance-debootstrap/variants")
 948                         (("\\$\\(defaultsdir\\)")
 949                          "$(prefix)/etc/default/ganeti-instance-debootstrap"))
 950                       #t))
 951                   (add-after 'install 'make-variants.list-symlink
 952                     (lambda* (#:key outputs #:allow-other-keys)
 953                       ;; The Ganeti OS API mandates a variants.list file that
 954                       ;; describes all supported "variants" of this OS.
 955                       ;; Guix generates this file, so make the original file
 956                       ;; a symlink to it.
 957                       (with-directory-excursion (string-append
 958                                                  (assoc-ref outputs "out")
 959                                                  "/share/ganeti/os/debootstrap")
 960                         (delete-file "variants.list")
 961                         (symlink "/etc/ganeti/instance-debootstrap/variants/variants.list"
 962                                  "variants.list"))
 963                       #t)))))
 964     (native-inputs
 965      `(("autoconf" ,autoconf)
 966        ("automake" ,automake)))
 967     (inputs
 968      `(("debianutils" ,debianutils)
 969        ("debootstrap" ,debootstrap)
 970        ("dump" ,dump)
 971        ("kpartx" ,multipath-tools)
 972        ("util-linux" ,util-linux)))
 973     (synopsis "Debian OS integration for Ganeti")
 974     (description
 975      "This package provides a guest OS definition for Ganeti.  It installs
 976 Debian or a derivative using @command{debootstrap}.")
 977     (license license:gpl2+)))
 978
 979 (define-public libosinfo
 980   (package
 981     (name "libosinfo")
 982     (version "1.7.1")
 983     (source
 984      (origin
 985        (method url-fetch)
 986        (uri (string-append "https://releases.pagure.org/libosinfo/libosinfo-"
 987                            version ".tar.xz"))
 988        (sha256
 989         (base32
 990          "1s97sv24bybggjx6hgqba2qdqz3ivfpd4cmkh4zm5y59sim109mv"))))
 991     (build-system meson-build-system)
 992     (arguments
 993      `(#:configure-flags
 994        (list (string-append "-Dwith-usb-ids-path="
 995                             (assoc-ref %build-inputs "usb.ids"))
 996              (string-append "-Dwith-pci-ids-path="
 997                             (assoc-ref %build-inputs "pci.ids")))
 998        #:phases
 999        (modify-phases %standard-phases
1000          (add-after 'unpack 'patch-osinfo-path
1001            (lambda* (#:key inputs #:allow-other-keys)
1002              (substitute* "osinfo/osinfo_loader.c"
1003                (("path = DATA_DIR.*")
1004                 (string-append "path = \"" (assoc-ref inputs "osinfo-db")
1005                                "/share/osinfo\";")))
1006              #t)))))
1007     (inputs
1008      `(("libsoup" ,libsoup)
1009        ("libxml2" ,libxml2)
1010        ("libxslt" ,libxslt)
1011        ("osinfo-db" ,osinfo-db)))
1012     (native-inputs
1013      `(("glib" ,glib "bin")  ; glib-mkenums, etc.
1014        ("gobject-introspection" ,gobject-introspection)
1015        ("gtk-doc" ,gtk-doc/stable)
1016        ("vala" ,vala)
1017        ("intltool" ,intltool)
1018        ("pkg-config" ,pkg-config)
1019        ("pci.ids"
1020         ,(origin
1021            (method url-fetch)
1022            (uri "https://github.com/pciutils/pciids/raw/ad02084f0bc143e3c15e31a6152a3dfb1d7a3156/pci.ids")
1023            (sha256
1024             (base32
1025              "0kfhpj5rnh24hz2714qhfmxk281vwc2w50sm73ggw5d15af7zfsw"))))
1026        ("usb.ids"
1027         ,(origin
1028            (method url-fetch)
1029            (uri "https://svn.code.sf.net/p/linux-usb/repo/trunk/htdocs/usb.ids?r=2681")
1030            (file-name "usb.ids")
1031            (sha256
1032             (base32
1033              "1m6yhvz5k8aqzxgk7xj3jkk8frl1hbv0h3vgj4wbnvnx79qnvz3r"))))))
1034     (home-page "https://libosinfo.org/")
1035     (synopsis "Operating system information database")
1036     (description "libosinfo is a GObject based library API for managing
1037 information about operating systems, hypervisors and the (virtual) hardware
1038 devices they can support.  It includes a database containing device metadata
1039 and provides APIs to match/identify optimal devices for deploying an operating
1040 system on a hypervisor.  Via GObject Introspection, the API is available in
1041 all common programming languages.  Vala bindings are also provided.")
1042     ;; The library files are released under LGPLv2.1 or later; the source
1043     ;; files in the "tools" directory are released under GPLv2+.
1044     (license (list license:lgpl2.1+ license:gpl2+))))
1045
1046 (define-public lxc
1047   (package
1048     (name "lxc")
1049     (version "4.0.10")
1050     (source (origin
1051               (method url-fetch)
1052               (uri (string-append
1053                     "https://linuxcontainers.org/downloads/lxc/lxc-"
1054                     version ".tar.gz"))
1055               (sha256
1056                (base32
1057                 "1sgsic9dzj3wv2k5bx2vhcgappivhp1glkqfc2yrgr6jas052351"))))
1058     (build-system gnu-build-system)
1059     (native-inputs
1060      `(("pkg-config" ,pkg-config)
1061        ("docbook2x" ,docbook2x)))
1062     (inputs
1063      `(("gnutls" ,gnutls)
1064        ("libcap" ,libcap)
1065        ("libseccomp" ,libseccomp)
1066        ("libselinux" ,libselinux)))
1067     (arguments
1068      `(#:configure-flags
1069        (list (string-append "--docdir=" (assoc-ref %outputs "out")
1070                             "/share/doc/" ,name "-" ,version)
1071              "--sysconfdir=/etc"
1072              "--localstatedir=/var")
1073        #:phases
1074        (modify-phases %standard-phases
1075          (replace 'install
1076            (lambda* (#:key outputs #:allow-other-keys)
1077              (let* ((out         (assoc-ref outputs "out"))
1078                     (bashcompdir (string-append out "/etc/bash_completion.d")))
1079                (invoke "make" "install"
1080                        (string-append "bashcompdir=" bashcompdir)
1081                        ;; Don't install files into /var and /etc.
1082                        "LXCPATH=/tmp/var/lib/lxc"
1083                        "localstatedir=/tmp/var"
1084                        "sysconfdir=/tmp/etc"
1085                        "sysconfigdir=/tmp/etc/default")))))))
1086     (synopsis "Linux container tools")
1087     (home-page "https://linuxcontainers.org/")
1088     (description
1089      "LXC is a userspace interface for the Linux kernel containment features.
1090 Through a powerful API and simple tools, it lets Linux users easily create and
1091 manage system or application containers.")
1092     (license license:lgpl2.1+)))
1093
1094 (define-public lxcfs
1095   (package
1096     (name "lxcfs")
1097     (version "4.0.9")
1098     (home-page "https://github.com/lxc/lxcfs")
1099     (source (origin
1100               (method git-fetch)
1101               (uri (git-reference (url home-page)
1102                                   (commit (string-append "lxcfs-" version))))
1103               (file-name (git-file-name name version))
1104               (sha256
1105                (base32
1106                 "0zx58lair8hwi4bxm5h7i8n1j5fcdgw5cr6f4wk9qhks0sr5dip5"))))
1107     (arguments
1108      '(#:configure-flags '("--localstatedir=/var")))
1109     (native-inputs
1110      `(("autoconf" ,autoconf)
1111        ("automake" ,automake)
1112        ("libtool" ,libtool)
1113        ("pkg-config" ,pkg-config)))
1114     (inputs
1115      `(("fuse" ,fuse)))
1116     (build-system gnu-build-system)
1117     (synopsis "FUSE-based file system for LXC")
1118     (description "LXCFS is a small FUSE file system written with the intention
1119 of making Linux containers feel more like a virtual machine.
1120 It started as a side project of LXC but can be used by any run-time.")
1121     (license license:lgpl2.1+)))
1122
1123 (define-public lxd
1124   (package
1125     (name "lxd")
1126     (version "4.17")
1127     (source (origin
1128               (method url-fetch)
1129               (uri (string-append
1130                     "https://github.com/lxc/lxd/releases/download/"
1131                     "lxd-" version "/lxd-" version ".tar.gz"))
1132               (sha256
1133                (base32
1134                 "1kzmgyg5kw3zw9qa6jabld6rmb53b6yy69h7y9znsdlf74jllljl"))))
1135     (build-system go-build-system)
1136     (arguments
1137      `(#:import-path "github.com/lxc/lxd"
1138        #:tests? #f ;; tests fail due to missing /var, cgroups, etc.
1139        #:modules ((guix build go-build-system)
1140                   (guix build union)
1141                   (guix build utils)
1142                   (srfi srfi-1))
1143        #:phases
1144        (modify-phases %standard-phases
1145          (add-after 'unpack 'unpack-dist
1146            (lambda* (#:key import-path #:allow-other-keys)
1147              (with-directory-excursion (string-append "src/" import-path)
1148                ;; remove the link back to the top level
1149                (delete-file (string-append "_dist/src/" import-path))
1150                ;; move all the deps into the src directory
1151                (copy-recursively "_dist/src" "../../.."))
1152              #t))
1153          (replace 'build
1154            (lambda* (#:key import-path #:allow-other-keys)
1155              (with-directory-excursion (string-append "src/" import-path)
1156                (invoke "make" "build" "CC=gcc" "TAG_SQLITE3=libsqlite3")
1157                #t)))
1158          (replace 'check
1159            (lambda* (#:key tests? import-path #:allow-other-keys)
1160              (when tests?
1161                (with-directory-excursion (string-append "src/" import-path)
1162                  (invoke "make" "check" "CC=gcc" "TAG_SQLITE3=libsqlite3")))
1163              #t))
1164          (replace 'install
1165            (lambda* (#:key inputs outputs import-path #:allow-other-keys)
1166              (let* ((out (assoc-ref outputs "out"))
1167                     (bin-dir
1168                      (string-append out "/bin/"))
1169                     (doc-dir
1170                      (string-append out "/share/doc/lxd-" ,version))
1171                     (completions-dir
1172                      (string-append out "/share/bash-completion/completions")))
1173                (with-directory-excursion (string-append "src/" import-path)
1174                  ;; wrap lxd with runtime dependencies
1175                  (wrap-program (string-append bin-dir "lxd")
1176                    `("PATH" ":" prefix
1177                      ,(fold (lambda (input paths)
1178                               (let* ((in (assoc-ref inputs input))
1179                                      (bin (string-append in "/bin"))
1180                                      (sbin (string-append in "/sbin")))
1181                                 (append (filter file-exists?
1182                                                 (list bin sbin)) paths)))
1183                             '()
1184                             '("bash" "acl" "rsync" "tar" "xz" "btrfs-progs"
1185                               "gzip" "dnsmasq" "squashfs-tools" "iproute2"
1186                               "criu" "iptables"))))
1187                  ;; remove unwanted binaries
1188                  (for-each (lambda (prog)
1189                              (delete-file (string-append bin-dir prog)))
1190                            '("deps" "macaroon-identity" "generate"))
1191                  ;; install documentation
1192                  (for-each (lambda (file)
1193                              (install-file file doc-dir))
1194                            (find-files "doc"))
1195                  ;; install bash completion
1196                  (rename-file "scripts/bash/lxd-client" "scripts/bash/lxd")
1197                  (install-file "scripts/bash/lxd" completions-dir)))
1198              #t)))))
1199     (native-inputs
1200      `(;; test dependencies:
1201        ;; ("go-github-com-rogpeppe-godeps" ,go-github-com-rogpeppe-godeps)
1202        ;; ("go-github-com-tsenart-deadcode" ,go-github-com-tsenart-deadcode)
1203        ;; ("go-golang-org-x-lint" ,go-golang-org-x-lint)
1204        ("pkg-config" ,pkg-config)))
1205     (inputs
1206      `(("acl" ,acl)
1207        ("eudev" ,eudev)
1208        ("libdqlite" ,libdqlite)
1209        ("libraft" ,libraft)
1210        ("libcap" ,libcap)
1211        ("lxc" ,lxc)
1212        ;; runtime dependencies:
1213        ("bash" ,bash-minimal)
1214        ("rsync" ,rsync)
1215        ("tar" ,tar)
1216        ("xz" ,xz)
1217        ("btrfs-progs" ,btrfs-progs)
1218        ("gzip" ,gzip)
1219        ("dnsmasq" ,dnsmasq)
1220        ("squashfs-tools" ,squashfs-tools)
1221        ("iproute2" ,iproute)
1222        ("criu" ,criu)
1223        ("iptables" ,iptables)))
1224     (synopsis "Daemon based on liblxc offering a REST API to manage containers")
1225     (home-page "https://linuxcontainers.org/lxd/")
1226     (description "LXD is a next generation system container manager.  It
1227 offers a user experience similar to virtual machines but using Linux
1228 containers instead.  It's image based with pre-made images available for a
1229 wide number of Linux distributions and is built around a very powerful, yet
1230 pretty simple, REST API.")
1231     (license license:asl2.0)))
1232
1233 (define-public libvirt
1234   (package
1235     (name "libvirt")
1236     (version "7.6.0")
1237     (source
1238      (origin
1239        (method url-fetch)
1240        (uri (string-append "https://libvirt.org/sources/libvirt-"
1241                            version ".tar.xz"))
1242        (sha256
1243         (base32 "0hb1fq0yx41n36c3n1a54b5p37n0m7abs917d76v7aqas03735lg"))
1244        (patches (search-patches "libvirt-add-install-prefix.patch"))))
1245     (build-system meson-build-system)
1246     (arguments
1247      `(#:configure-flags
1248        (list "-Ddriver_qemu=enabled"
1249              "-Dqemu_user=nobody"
1250              "-Dqemu_group=kvm"
1251              "-Dstorage_disk=enabled"
1252              "-Dstorage_dir=enabled"
1253              "-Dpolkit=enabled"
1254              ;; XXX The default, but required to make -Dsasl ‘stick’.
1255              ;; See <https://gitlab.com/libvirt/libvirt/-/issues/185>
1256              "-Ddriver_remote=enabled"
1257              "-Dnls=enabled"            ;translations
1258              (string-append "-Ddocdir=" (assoc-ref %outputs "out") "/share/doc/"
1259                             ,name "-" ,version)
1260              "-Dbash_completion=enabled"
1261              (string-append "-Dinstall_prefix=" (assoc-ref %outputs "out"))
1262              "--sysconfdir=/etc"
1263              "--localstatedir=/var")
1264        #:phases
1265        (modify-phases %standard-phases
1266          (add-after 'unpack 'skip-directory-confusion
1267            (lambda _
1268              ;; Don't try to install an (unused) /var outside of the store.
1269              (substitute* "scripts/meson-install-dirs.py"
1270                (("destdir = .*")
1271                 "destdir = '/tmp'"))))
1272          (add-before 'configure 'disable-broken-tests
1273            (lambda _
1274              (let ((tests (list "commandtest"           ; hangs idly
1275                                 "qemuxml2argvtest"      ; fails
1276                                 "virnetsockettest")))   ; tries to network
1277                (substitute* "tests/meson.build"
1278                  (((format #f ".*'name': '(~a)'.*" (string-join tests "|")))
1279                   ""))))))))
1280     (inputs
1281      `(("acl" ,acl)
1282        ("attr" ,attr)
1283        ("fuse" ,fuse)
1284        ("libxml2" ,libxml2)
1285        ("eudev" ,eudev)
1286        ("libpciaccess" ,libpciaccess)
1287        ("gnutls" ,gnutls)
1288        ("dbus" ,dbus)
1289        ("libpcap" ,libpcap)
1290        ("libnl" ,libnl)
1291        ("libssh2" ,libssh2)             ;optional
1292        ("libtirpc" ,libtirpc)           ;for <rpc/rpc.h>
1293        ("libuuid" ,util-linux "lib")
1294        ("lvm2" ,lvm2)                   ;for libdevmapper
1295        ("curl" ,curl)
1296        ("openssl" ,openssl)
1297        ("readline" ,readline)
1298        ("cyrus-sasl" ,cyrus-sasl)
1299        ("libyajl" ,libyajl)
1300        ("audit" ,audit)
1301        ("dmidecode" ,dmidecode)
1302        ("dnsmasq" ,dnsmasq)
1303        ("ebtables" ,ebtables)
1304        ("parted" ,parted)
1305        ("iproute" ,iproute)
1306        ("iptables" ,iptables)))
1307     (native-inputs
1308      `(("bash-completion" ,bash-completion)
1309        ("gettext" ,gettext-minimal)
1310        ("xsltproc" ,libxslt)
1311        ("perl" ,perl)
1312        ("pkg-config" ,pkg-config)
1313        ("polkit" ,polkit)
1314        ("python" ,python-wrapper)
1315        ("python-docutils" ,python-docutils) ;for rst2html
1316        ("rpcsvc-proto" ,rpcsvc-proto)))     ;for rpcgen
1317     (home-page "https://libvirt.org")
1318     (synopsis "Simple API for virtualization")
1319     (description "Libvirt is a C toolkit to interact with the virtualization
1320 capabilities of recent versions of Linux.  The library aims at providing long
1321 term stable C API initially for the Xen paravirtualization but should be able
1322 to integrate other virtualization mechanisms if needed.")
1323     (license license:lgpl2.1+)))
1324
1325 (define-public libvirt-glib
1326   (package
1327     (name "libvirt-glib")
1328     (version "4.0.0")
1329     (source (origin
1330               (method url-fetch)
1331               (uri (string-append "ftp://libvirt.org/libvirt/glib/"
1332                                   "libvirt-glib-" version ".tar.xz"))
1333               (sha256
1334                (base32
1335                 "1gdcvqz88qkp402zra9csc6391f2xki1270x683n6ixakl3gf8w4"))))
1336     (build-system meson-build-system)
1337     (inputs
1338      `(("openssl" ,openssl)
1339        ("cyrus-sasl" ,cyrus-sasl)
1340        ("lvm2" ,lvm2)                   ; for libdevmapper
1341        ("libyajl" ,libyajl)))
1342     (native-inputs
1343      `(("pkg-config" ,pkg-config)
1344        ("intltool" ,intltool)
1345        ("glib" ,glib "bin")
1346        ("vala" ,vala)))
1347     (propagated-inputs
1348      ;; ‘Required:’ by the installed .pc files.
1349      `(("glib" ,glib)
1350        ("libvirt" ,libvirt)
1351        ("libxml2" ,libxml2)
1352        ("gobject-introspection" ,gobject-introspection)))
1353     (home-page "https://libvirt.org")
1354     (synopsis "GLib wrapper around libvirt")
1355     (description "libvirt-glib wraps the libvirt library to provide a
1356 high-level object-oriented API better suited for glib-based applications, via
1357 three libraries:
1358
1359 @enumerate
1360 @item libvirt-glib - GLib main loop integration & misc helper APIs
1361 @item libvirt-gconfig - GObjects for manipulating libvirt XML documents
1362 @item libvirt-gobject - GObjects for managing libvirt objects
1363 @end enumerate
1364 ")
1365     (license license:lgpl2.1+)))
1366
1367 (define-public python-libvirt
1368   (package
1369     (name "python-libvirt")
1370     (version "7.3.0")
1371     (source
1372      (origin
1373        (method url-fetch)
1374        (uri (string-append "https://libvirt.org/sources/python/libvirt-python-"
1375                            version ".tar.gz"))
1376        (sha256
1377         (base32 "15pn8610ybf03xff3vbz3apz2ph42k2kh6k19r020l9nvc6jcv37"))))
1378     (build-system python-build-system)
1379     (arguments
1380      `(#:phases
1381        (modify-phases %standard-phases
1382          (replace 'check
1383            (lambda* (#:key inputs outputs tests? #:allow-other-keys)
1384              (when tests?
1385                ;; No reason to explicity invoke Python on a wrapped pytest.
1386                (substitute* "setup.py"
1387                  (("sys\\.executable, pytest") "pytest"))
1388                (add-installed-pythonpath inputs outputs)
1389                (setenv "LIBVIRT_API_COVERAGE" "whynot")
1390                (invoke "python" "setup.py" "test")))))))
1391     (inputs
1392      `(("libvirt" ,libvirt)))
1393     (propagated-inputs
1394      `(("python-lxml" ,python-lxml)))
1395     (native-inputs
1396      `(("pkg-config" ,pkg-config)
1397        ("python-pytest" ,python-pytest)))
1398     (home-page "https://libvirt.org")
1399     (synopsis "Python bindings to libvirt")
1400     (description "This package provides Python bindings to the libvirt
1401 virtualization library.")
1402     (license license:lgpl2.1+)))
1403
1404 (define-public virt-manager
1405   (package
1406     (name "virt-manager")
1407     (version "3.2.0")
1408     (source (origin
1409               (method url-fetch)
1410               (uri (string-append "https://virt-manager.org/download/sources"
1411                                   "/virt-manager/virt-manager-"
1412                                   version ".tar.gz"))
1413               (sha256
1414                (base32
1415                 "11kvpzcmyir91qz0dsnk7748jbb4wr8mrc744w117qc91pcy6vrb"))))
1416     (build-system python-build-system)
1417     (arguments
1418      `(#:use-setuptools? #f          ; uses custom distutils 'install' command
1419        #:tests? #f                      ; TODO The tests currently fail
1420                                         ; RuntimeError: Loop condition wasn't
1421                                         ; met
1422        #:imported-modules ((guix build glib-or-gtk-build-system)
1423                            ,@%python-build-system-modules)
1424        #:modules ((ice-9 match)
1425                   (srfi srfi-26)
1426                   (guix build python-build-system)
1427                   ((guix build glib-or-gtk-build-system) #:prefix glib-or-gtk:)
1428                   (guix build utils))
1429        #:phases
1430        (modify-phases %standard-phases
1431          (add-after 'unpack 'fix-setup
1432            (lambda* (#:key outputs #:allow-other-keys)
1433              (substitute* "virtinst/buildconfig.py"
1434                (("/usr") (assoc-ref outputs "out")))
1435              #t))
1436          (add-after 'unpack 'fix-default-uri
1437            (lambda* (#:key inputs #:allow-other-keys)
1438              ;; Xen is not available for now - so only patch qemu.
1439              (substitute* "virtManager/createconn.py"
1440                (("/usr(/bin/qemu-system-[a-zA-Z0-9_-]+)" _ suffix)
1441                 (search-input-file inputs suffix)))
1442              #t))
1443          (add-before 'wrap 'wrap-with-GI_TYPELIB_PATH
1444            (lambda* (#:key inputs outputs #:allow-other-keys)
1445              (let* ((bin       (string-append (assoc-ref outputs "out") "/bin"))
1446                     (bin-files (find-files bin ".*"))
1447                     (paths     (map (match-lambda
1448                                       ((output . directory)
1449                                        (let* ((girepodir (string-append
1450                                                           directory
1451                                                           "/lib/girepository-1.0")))
1452                                          (if (file-exists? girepodir)
1453                                              girepodir #f))))
1454                                     inputs)))
1455                (for-each (lambda (file)
1456                            (format #t "wrapping ~a\n" file)
1457                            (wrap-program file
1458                              `("GI_TYPELIB_PATH" ":" prefix
1459                                ,(filter identity paths))))
1460                          bin-files))
1461              #t))
1462          (replace 'check
1463            (lambda* (#:key tests? #:allow-other-keys)
1464              (when tests?
1465                (setenv "HOME" "/tmp")
1466                (setenv "XDG_CACHE_HOME" "/tmp")
1467                (system "Xvfb :1 &")
1468                (setenv "DISPLAY" ":1")
1469                ;; Dogtail requires that Assistive Technology support be enabled
1470                (setenv "GTK_MODULES" "gail:atk-bridge")
1471                (invoke "dbus-run-session" "--" "pytest" "--uitests"))
1472              #t))
1473          (add-after 'install 'glib-or-gtk-compile-schemas
1474            (assoc-ref glib-or-gtk:%standard-phases 'glib-or-gtk-compile-schemas))
1475          (add-after 'wrap 'glib-or-gtk-wrap
1476            (assoc-ref glib-or-gtk:%standard-phases 'glib-or-gtk-wrap)))))
1477     (inputs
1478      `(("dconf" ,dconf)
1479        ("gtk+" ,gtk+)
1480        ("gtk-vnc" ,gtk-vnc)
1481        ("gtksourceview" ,gtksourceview)
1482        ("libvirt" ,libvirt)
1483        ("libvirt-glib" ,libvirt-glib)
1484        ("libosinfo" ,libosinfo)
1485        ("vte" ,vte)
1486        ("python-libvirt" ,python-libvirt)
1487        ("python-requests" ,python-requests)
1488        ("python-pycairo" ,python-pycairo)
1489        ("python-pygobject" ,python-pygobject)
1490        ("python-libxml2" ,python-libxml2)
1491        ("spice-gtk" ,spice-gtk)))
1492     ;; virt-manager searches for qemu-img or kvm-img in the PATH.
1493     (propagated-inputs
1494      `(("qemu" ,qemu)))
1495     (native-inputs
1496      `(("glib" ,glib "bin")             ; glib-compile-schemas
1497        ("gobject-introspection" ,gobject-introspection)
1498        ("gtk+" ,gtk+ "bin")             ; gtk-update-icon-cache
1499        ("perl" ,perl)                   ; pod2man
1500        ("intltool" ,intltool)
1501        ("rst2man" ,python-docutils)
1502        ;; The following are required for running the tests
1503        ;; ("python-pytest" ,python-pytest)
1504        ;; ("python-dogtail" ,python-dogtail)
1505        ;; ("xvfb" ,xorg-server-for-tests)
1506        ;; ("dbus" ,dbus)
1507        ;; ("at-spi2-core" ,at-spi2-core)
1508        ;; ("gsettings-desktop-schemas" ,gsettings-desktop-schemas)
1509        ))
1510     (home-page "https://virt-manager.org/")
1511     (synopsis "Manage virtual machines")
1512     (description
1513      "The virt-manager application is a desktop user interface for managing
1514 virtual machines through libvirt.  It primarily targets KVM VMs, but also
1515 manages Xen and LXC (Linux containers).  It presents a summary view of running
1516 domains, their live performance and resource utilization statistics.")
1517     (license license:gpl2+)))
1518
1519 (define-public criu
1520   (package
1521     (name "criu")
1522     (version "3.16")
1523     (source (origin
1524               (method url-fetch)
1525               (uri (string-append "https://download.openvz.org/criu/criu-"
1526                                   version ".tar.bz2"))
1527               (sha256
1528                (base32
1529                 "13x4s7nms3ckb016d03icdsrw4k6f7i33qz9n84fzhmibm0grj70"))))
1530     (build-system gnu-build-system)
1531     (arguments
1532      `(#:test-target "test"
1533        #:tests? #f ; tests require mounting as root
1534        #:make-flags
1535        (list (string-append "PREFIX=" (assoc-ref %outputs "out"))
1536              (string-append "LIBDIR=" (assoc-ref %outputs "out")
1537                             "/lib")
1538              (string-append "ASCIIDOC="
1539                             (search-input-file %build-inputs
1540                                                "/bin/asciidoc"))
1541              (string-append "XMLTO="
1542                             (search-input-file %build-input
1543                                                "/bin/xmlto")))
1544        #:phases
1545        (modify-phases %standard-phases
1546          (replace 'configure
1547            (lambda* (#:key inputs #:allow-other-keys)
1548              ;; The includes for libnl are located in a sub-directory.
1549              (setenv "C_INCLUDE_PATH"
1550                      (string-append
1551                       (search-input-directory inputs "/include/libnl3")
1552                       ":" (or (getenv "C_INCLUDE_PATH") "")))))
1553          (add-after 'configure 'fix-documentation
1554            (lambda* (#:key inputs outputs #:allow-other-keys)
1555              (substitute* "Documentation/Makefile"
1556                (("-m custom.xsl")
1557                 (string-append
1558                  "-m custom.xsl --skip-validation -x "
1559                  (assoc-ref inputs "docbook-xsl") "/xml/xsl/"
1560                  ,(package-name docbook-xsl) "-"
1561                  ,(package-version docbook-xsl)
1562                  "/manpages/docbook.xsl")))))
1563          (add-after 'unpack 'hardcode-variables
1564            (lambda* (#:key inputs #:allow-other-keys)
1565              ;; Hardcode arm version detection
1566              (substitute* "Makefile"
1567                (("ARMV.*:=.*") "ARMV := 7\n"))
1568              ;; We are currently using python-2
1569              (substitute* "crit/Makefile"
1570                (("\\$\\(PYTHON\\)") "python2"))
1571              (substitute* "lib/Makefile"
1572                (("\\$\\(PYTHON\\)")
1573                 (search-input-file inputs "/bin/python")))))
1574          (add-before 'build 'fix-symlink
1575            (lambda* (#:key inputs #:allow-other-keys)
1576              ;; The file 'images/google/protobuf/descriptor.proto' points to
1577              ;; /usr/include/..., which obviously does not exist.
1578              (let* ((file "google/protobuf/descriptor.proto")
1579                     (target (string-append "images/" file))
1580                     (source (search-input-file
1581                              inputs
1582                              (string-append "include/" file))))
1583                (delete-file target)
1584                (symlink source target))))
1585          (add-after 'install 'wrap
1586            (lambda* (#:key inputs outputs #:allow-other-keys)
1587              ;; Make sure 'crit' runs with the correct PYTHONPATH.
1588              (let* ((out (assoc-ref outputs "out"))
1589                     (path (string-append out
1590                                          "/lib/python"
1591                                          (string-take (string-take-right
1592                                                        (assoc-ref inputs "python") 5) 3)
1593                                          "/site-packages:"
1594                                          (or (getenv "GUIX_PYTHONPATH") ""))))
1595                (wrap-program (string-append out "/bin/crit")
1596                  `("GUIX_PYTHONPATH" ":" prefix (,path))))))
1597          (add-after 'install 'delete-static-libraries
1598            ;; Not building/installing these at all doesn't seem to be supported.
1599            (lambda* (#:key outputs #:allow-other-keys)
1600              (let ((out (assoc-ref outputs "out")))
1601                (for-each delete-file (find-files out "\\.a$"))))))))
1602     (inputs
1603      `(("protobuf" ,protobuf)
1604        ("python" ,python-2)
1605        ("python2-protobuf" ,python2-protobuf)
1606        ("python2-ipaddr" ,python2-ipaddr)
1607        ("iproute" ,iproute)
1608        ("libaio" ,libaio)
1609        ("libcap" ,libcap)
1610        ("libnet" ,libnet)
1611        ("libnl" ,libnl)
1612        ("libbsd" ,libbsd)
1613        ("nftables" ,nftables)))
1614     (native-inputs
1615      `(("pkg-config" ,pkg-config)
1616        ("perl" ,perl)
1617        ("protobuf-c" ,protobuf-c)
1618        ("asciidoc" ,asciidoc)
1619        ("xmlto" ,xmlto)
1620        ("docbook-xml" ,docbook-xml)
1621        ("docbook-xsl" ,docbook-xsl)))
1622     (home-page "https://criu.org")
1623     (synopsis "Checkpoint and restore in user space")
1624     (description "Using this tool, you can freeze a running application (or
1625 part of it) and checkpoint it to a hard drive as a collection of files.  You
1626 can then use the files to restore and run the application from the point it
1627 was frozen at.  The distinctive feature of the CRIU project is that it is
1628 mainly implemented in user space.")
1629     ;; The project is licensed under GPLv2; files in the lib/ directory are
1630     ;; LGPLv2.1.
1631     (license (list license:gpl2 license:lgpl2.1))))
1632
1633 (define-public qmpbackup
1634   (package
1635     (name "qmpbackup")
1636     (version "0.2")
1637     (source (origin
1638               (method git-fetch)
1639               (uri (git-reference
1640                      (url "https://github.com/abbbi/qmpbackup")
1641                      (commit version)))
1642               (file-name (git-file-name name version))
1643               (sha256
1644                (base32
1645                 "0swhp5byz44brhyis1a39p11fyn9q84xz5q6v2fah29r7d71kmmx"))))
1646     (build-system python-build-system)
1647     (arguments
1648      `(#:python ,python-2))
1649     (home-page "https://github.com/abbbi/qmpbackup")
1650     (synopsis "Backup and restore QEMU machines")
1651     (description "qmpbackup is designed to create and restore full and
1652 incremental backups of running QEMU virtual machines via QMP, the QEMU
1653 Machine Protocol.")
1654     (license license:gpl3+)))
1655
1656 (define-public looking-glass-client
1657   (let ((commit "182c4752d57690da7f99d5e788de9b8baea33895"))
1658     (package
1659      (name "looking-glass-client")
1660      (version (string-append "a12-" (string-take commit 7)))
1661      (source
1662       (origin
1663        (method git-fetch)
1664        (uri (git-reference (url "https://github.com/gnif/LookingGlass")
1665                            (commit commit)))
1666        (file-name (git-file-name name version))
1667        (sha256
1668         (base32
1669          "02bq46ndmzq9cihazzn7xq1x7q5nzm7iw4l9lqzihxcxp9famkhw"))
1670        (modules '((guix build utils)))
1671        (snippet
1672         '(begin
1673            ;; Do not create binaries optimized for the CPU of the build machine,
1674            ;; for reproducibility and compatibility.  TODO: in the next version
1675            ;; of looking glass, this is exposed as a CMake configure option.
1676            (substitute* "client/CMakeLists.txt"
1677              (("-march=native")
1678               ""))
1679            #t))))
1680      (build-system cmake-build-system)
1681      (inputs `(("fontconfig" ,fontconfig)
1682                ("glu" ,glu)
1683                ("mesa" ,mesa)
1684                ("openssl" ,openssl)
1685                ("sdl2" ,sdl2)
1686                ("sdl2-ttf" ,sdl2-ttf)
1687                ("spice-protocol" ,spice-protocol)
1688                ("wayland" ,wayland)))
1689      (native-inputs `(("libconfig" ,libconfig)
1690                       ("nettle" ,nettle)
1691                       ("pkg-config" ,pkg-config)))
1692      (arguments
1693       `(#:tests? #f ;; No tests are available.
1694         #:make-flags '("CC=gcc")
1695         #:phases (modify-phases %standard-phases
1696                    (add-before 'configure 'chdir-to-client
1697                      (lambda* (#:key outputs #:allow-other-keys)
1698                        (chdir "client")
1699                        #t))
1700                    (add-after 'chdir-to-client 'add-missing-include
1701                      (lambda _
1702                        ;; Mimic upstream commit b9797529893, required since the
1703                        ;; update to Mesa 19.2.
1704                        (substitute* "renderers/egl/shader.h"
1705                          (("#include <stdbool\\.h>")
1706                           "#include <stdbool.h>\n#include <stddef.h>"))
1707                        #t))
1708                    (replace 'install
1709                      (lambda* (#:key outputs #:allow-other-keys)
1710                        (install-file "looking-glass-client"
1711                                      (string-append (assoc-ref outputs "out")
1712                                                     "/bin"))
1713                        #t)))))
1714      (home-page "https://looking-glass.hostfission.com")
1715      (synopsis "KVM Frame Relay (KVMFR) implementation")
1716      (description "Looking Glass allows the use of a KVM (Kernel-based Virtual
1717 Machine) configured for VGA PCI Pass-through without an attached physical
1718 monitor, keyboard or mouse.  It displays the VM's rendered contents on your main
1719 monitor/GPU.")
1720      ;; This package requires SSE instructions.
1721      (supported-systems '("i686-linux" "x86_64-linux"))
1722      (license license:gpl2+))))
1723
1724 (define-public runc
1725   (package
1726     (name "runc")
1727     (version "1.0.0-rc93")
1728     (source (origin
1729               (method url-fetch)
1730               (uri (string-append
1731                     "https://github.com/opencontainers/runc/releases/"
1732                     "download/v" version "/runc.tar.xz"))
1733               (file-name (string-append name "-" version ".tar.xz"))
1734               (sha256
1735                (base32
1736                 "0b90r1bkvlqli53ca1yc1l488dba0isd3i6l7nlhszxi8p7hzvkh"))))
1737     (build-system go-build-system)
1738     (arguments
1739      '(#:import-path "github.com/opencontainers/runc"
1740        #:install-source? #f
1741        ;; XXX: 20/139 tests fail due to missing /var, cgroups and apparmor in
1742        ;; the build environment.
1743        #:tests? #f
1744        #:phases
1745        (modify-phases %standard-phases
1746          (replace 'build
1747            (lambda* (#:key import-path #:allow-other-keys)
1748              (with-directory-excursion (string-append "src/" import-path)
1749                (invoke "make" "all" "man"))))
1750          (replace 'check
1751            (lambda* (#:key tests? #:allow-other-keys)
1752              (when tests?
1753                (invoke "make" "localunittest"))))
1754          (replace 'install
1755            (lambda* (#:key import-path outputs #:allow-other-keys)
1756              (with-directory-excursion (string-append "src/" import-path)
1757                (let ((out (assoc-ref outputs "out")))
1758                  (invoke "make" "install" "install-bash" "install-man"
1759                          (string-append "PREFIX=" out)))))))))
1760     (native-inputs
1761      `(("go-md2man" ,go-github-com-go-md2man)
1762        ("pkg-config" ,pkg-config)))
1763     (inputs
1764      `(("libseccomp" ,libseccomp)))
1765     (synopsis "Open container initiative runtime")
1766     (home-page "https://opencontainers.org/")
1767     (description
1768      "@command{runc} is a command line client for running applications
1769 packaged according to the
1770 @uref{https://github.com/opencontainers/runtime-spec/blob/master/spec.md, Open
1771 Container Initiative (OCI) format} and is a compliant implementation of the
1772 Open Container Initiative specification.")
1773     (license license:asl2.0)))
1774
1775 (define-public umoci
1776   (package
1777     (name "umoci")
1778     (version "0.4.7")
1779     (source
1780      (origin
1781        (method url-fetch)
1782        (uri (string-append
1783              "https://github.com/opencontainers/umoci/releases/download/v"
1784              version "/umoci.tar.xz"))
1785        (file-name (string-append "umoci-" version ".tar.xz"))
1786        (sha256
1787         (base32 "0fvljj9k4f83wbqzd8nbijz0p1zaq633f8yxyvl5sy3wjf03ffk9"))))
1788     (build-system go-build-system)
1789     (arguments
1790      '(#:import-path "github.com/opencontainers/umoci"
1791        #:install-source? #f
1792        #:phases
1793        (modify-phases %standard-phases
1794          (replace 'unpack
1795            (lambda* (#:key source import-path #:allow-other-keys)
1796              ;; Unpack the tarball into 'umoci' instead of "runc-${version}".
1797              (let ((dest (string-append "src/" import-path)))
1798                (mkdir-p dest)
1799                (invoke "tar" "-C" (string-append "src/" import-path)
1800                        "--strip-components=1"
1801                        "-xvf" source))))
1802          (replace 'build
1803            (lambda* (#:key import-path #:allow-other-keys)
1804              (with-directory-excursion (string-append "src/" import-path)
1805                ;; TODO: build manpages with 'go-md2man'.
1806                (invoke "make" "SHELL=bash"))))
1807          (replace 'install
1808            (lambda* (#:key import-path outputs #:allow-other-keys)
1809              (let* ((out (assoc-ref outputs "out"))
1810                     (bindir (string-append out "/bin")))
1811                (install-file (string-append "src/" import-path "/umoci")
1812                              bindir)
1813                #t))))))
1814     (home-page "https://umo.ci/")
1815     (synopsis "Tool for modifying Open Container images")
1816     (description
1817      "@command{umoci} is a tool that allows for high-level modification of an
1818 Open Container Initiative (OCI) image layout and its tagged images.")
1819     (license license:asl2.0)))
1820
1821 (define-public skopeo
1822   (package
1823     (name "skopeo")
1824     (version "1.2.3")
1825     (source (origin
1826               (method git-fetch)
1827               (uri (git-reference
1828                     (url "https://github.com/containers/skopeo")
1829                     (commit (string-append "v" version))))
1830               (file-name (git-file-name name version))
1831               (sha256
1832                (base32
1833                 "0n22sdif437ddg5ch0ipwim3fg0n6ihc9bfi52qkhy3r1grz04hs"))))
1834     (build-system go-build-system)
1835     (native-inputs
1836      `(("pkg-config" ,pkg-config)
1837        ("go-github-com-go-md2man" ,go-github-com-go-md2man)))
1838     (inputs
1839      `(("btrfs-progs" ,btrfs-progs)
1840        ("eudev" ,eudev)
1841        ("libassuan" ,libassuan)
1842        ("libselinux" ,libselinux)
1843        ("libostree" ,libostree)
1844        ("lvm2" ,lvm2)
1845        ("glib" ,glib)
1846        ("gpgme" ,gpgme)))
1847     (arguments
1848      '(#:import-path "github.com/containers/skopeo"
1849        #:install-source? #f
1850        #:tests? #f                                ; The tests require Docker
1851        #:phases
1852        (modify-phases %standard-phases
1853          (replace 'build
1854            (lambda* (#:key import-path #:allow-other-keys)
1855              (with-directory-excursion (string-append "src/" import-path)
1856                (invoke "make" "bin/skopeo"))))
1857          (add-after 'build 'build-docs
1858            (lambda* (#:key import-path #:allow-other-keys)
1859              (with-directory-excursion (string-append "src/" import-path)
1860                (invoke "make" "docs"))))
1861          (replace 'install
1862            (lambda* (#:key import-path outputs #:allow-other-keys)
1863              (with-directory-excursion (string-append "src/" import-path)
1864                (let ((out (assoc-ref outputs "out")))
1865                  (install-file "default-policy.json"
1866                                (string-append out "/etc/containers"))
1867                  (invoke "make" "install-binary" "install-completions" "install-docs"
1868                          (string-append "PREFIX=" out)))))))))
1869     (home-page "https://github.com/containers/skopeo")
1870     (synopsis "Interact with container images and container image registries")
1871     (description
1872      "@command{skopeo} is a command line utility providing various operations
1873 with container images and container image registries.  It can:
1874 @enumerate
1875
1876 @item Copy container images between various containers image stores,
1877 converting them as necessary.
1878
1879 @item Convert a Docker schema 2 or schema 1 container image to an OCI image.
1880
1881 @item Inspect a repository on a container registry without needlessly pulling
1882 the image.
1883
1884 @item Sign and verify container images.
1885
1886 @item Delete container images from a remote container registry.
1887
1888 @end enumerate")
1889     (license license:asl2.0)))
1890
1891 (define-public python-vagrant
1892   (package
1893     (name "python-vagrant")
1894     (version "0.5.15")
1895     (source
1896       (origin
1897         (method url-fetch)
1898         (uri (pypi-uri "python-vagrant" version))
1899         (sha256
1900          (base32
1901           "1ikrh6canhcxg5y7pzmkcnnydikppv7s6sm9prfx90nk0ac8m6mg"))))
1902     (build-system python-build-system)
1903     (arguments
1904      '(#:tests? #f)) ; tests involve running vagrant.
1905     (home-page "https://github.com/todddeluca/python-vagrant")
1906     (synopsis "Python bindings for Vagrant")
1907     (description
1908      "Python-vagrant is a Python module that provides a thin wrapper around the
1909 @code{vagrant} command line executable, allowing programmatic control of Vagrant
1910 virtual machines.")
1911     (license license:expat)))
1912
1913 (define-public bubblewrap
1914   (package
1915     (name "bubblewrap")
1916     (version "0.4.1")
1917     (source (origin
1918               (method url-fetch)
1919               (uri (string-append "https://github.com/containers/bubblewrap/"
1920                                   "releases/download/v" version "/bubblewrap-"
1921                                   version ".tar.xz"))
1922               (sha256
1923                (base32
1924                 "00ycgi6q2yngh06bnz50wkvar6r2jnjf3j158grhi9k13jdrpimr"))))
1925     (build-system gnu-build-system)
1926     (arguments
1927      `(#:phases
1928        (modify-phases %standard-phases
1929          (add-after 'unpack 'fix-test
1930            (lambda* (#:key outputs #:allow-other-keys)
1931              ;; Tests try to access /var/tmp, which is not possible in our build
1932              ;; environment.  Let's give them another directory.
1933              ;; /tmp gets overriden in some tests, so we need another directory.
1934              ;; the only possibility is the output directory.
1935              (let ((tmp-dir (string-append (assoc-ref outputs "out") "/tmp")))
1936                (mkdir-p tmp-dir)
1937                (substitute* "tests/test-run.sh"
1938                  (("/var/tmp") tmp-dir)
1939                  ;; Tests create a temporary python script, so fix its shebang.
1940                  (("/usr/bin/env python") (which "python"))
1941                  ;; Some tests try to access /usr, but that doesn't exist.
1942                  ;; Give them /gnu instead.
1943                  (("/usr") "/gnu")
1944                  (("--ro-bind /bin /bin") "--ro-bind /gnu /bin")
1945                  (("--ro-bind /sbin /sbin") "--ro-bind /gnu /sbin")
1946                  (("--ro-bind /lib /lib") "--ro-bind /gnu /lib")
1947                  (("  */bin/bash") (which "bash"))
1948                  (("/bin/sh") (which "sh"))
1949                  (("findmnt") (which "findmnt"))))
1950              #t))
1951          ;; Remove the directory we gave to tests to have a clean package.
1952          (add-after 'check 'remove-tmp-dir
1953            (lambda* (#:key outputs #:allow-other-keys)
1954              (delete-file-recursively (string-append (assoc-ref outputs "out") "/tmp"))
1955              #t)))))
1956     (inputs
1957      `(("libcap" ,libcap)))
1958     (native-inputs
1959      `(("python" ,python-wrapper)
1960        ("util-linux" ,util-linux)))
1961     (home-page "https://github.com/containers/bubblewrap")
1962     (synopsis "Unprivileged sandboxing tool")
1963     (description "Bubblewrap is aimed at running applications in a sandbox,
1964 restricting their access to parts of the operating system or user data such as
1965 the home directory.  Bubblewrap always creates a new mount namespace, and the
1966 user can specify exactly what parts of the file system should be made visible
1967 in the sandbox.  These directories are mounted with the @code{nodev} option
1968 by default and can be made read-only.")
1969     (license license:lgpl2.0+)))
1970
1971 (define-public bochs
1972   (package
1973     (name "bochs")
1974     (version "2.7")
1975     (source
1976      (origin
1977        (method url-fetch)
1978        (uri (string-append "https://sourceforge.net/projects/bochs/files/bochs/"
1979                            version "/bochs-" version ".tar.gz"))
1980        (sha256
1981         (base32 "0ymiwnfqg5npq2dk9ngidbbfn3qw8z6i491finhcaan7zldsn450"))))
1982     (build-system gnu-build-system)
1983     (arguments
1984      `(#:tests? #f))                    ; no tests exist
1985     (inputs
1986      `(("libxrandr" ,libxrandr)))
1987     (home-page "http://bochs.sourceforge.net/")
1988     (synopsis "Emulator for x86 PC")
1989     (description
1990      "Bochs is an emulator which can emulate Intel x86 CPU, common I/O
1991 devices, and a custom BIOS.  It can also be compiled to emulate many different
1992 x86 CPUs, from early 386 to the most recent x86-64 Intel and AMD processors.
1993 Bochs can run most Operating Systems inside the emulation including Linux,
1994 DOS or Microsoft Windows.")
1995     (license license:lgpl2.0+)))
1996
1997 (define-public xen
1998   (package
1999     (name "xen")
2000     (version "4.14.1")
2001     (source (origin
2002               (method git-fetch)
2003               (uri (git-reference
2004                     (url "git://xenbits.xenproject.org/xen.git")
2005                     (commit (string-append "RELEASE-" version))))
2006               (file-name (git-file-name name version))
2007               (sha256
2008                (base32
2009                 "1r90rvypw76ya9clqw5p02gm1k8hxz73f7gr95ca778nnzvb7xjw"))))
2010     (build-system gnu-build-system)
2011     (arguments
2012      `(#:configure-flags
2013        (list "--enable-rpath"
2014              "--disable-qemu-traditional" ; It tries to do "git clone"
2015              "--disable-rombios" ; would try to "git clone" via etherboot.
2016              ;; TODO: Re-enable stubdom (it's "more secure" to use it).
2017              "--disable-stubdom" ; tries to "git clone" old patched newlib.
2018              (string-append "--with-initddir="
2019                             (assoc-ref %outputs "out")
2020                             "/etc/init.d")
2021              (string-append "--with-system-qemu="
2022                             (assoc-ref %build-inputs "qemu")
2023                             "/bin/qemu-system-i386")
2024              (string-append "--with-system-seabios="
2025                             (assoc-ref %build-inputs "seabios")
2026                             "/share/firmware/bios.bin")
2027              (string-append "--with-system-ovmf="
2028                             (assoc-ref %build-inputs "ovmf")
2029                             "/share/firmware/ovmf_ia32.bin"))
2030        #:make-flags (list "-j" "1"
2031                           "XEN_BUILD_DATE=Thu Jan  1 01:00:01 CET 1970"
2032                           "XEN_BUILD_TIME=01:00:01"
2033                           "XEN_BUILD_HOST="
2034                           "ETHERBOOT_NICS="
2035                           "SMBIOS_REL_DATE=01/01/1970"
2036                           "VGABIOS_REL_DATE=01 Jan 1970"
2037                           ; QEMU_TRADITIONAL_LOC
2038                           ; QEMU_UPSTREAM_LOC
2039                           "SYSCONFIG_DIR=/tmp/etc/default"
2040                           (string-append "BASH_COMPLETION_DIR="
2041                                          (assoc-ref %outputs "out")
2042                                          "/etc/bash_completion.d")
2043                           (string-append "BOOT_DIR="
2044                                          (assoc-ref %outputs "out")
2045                                          "/boot")
2046                           (string-append "DEBUG_DIR="
2047                                          (assoc-ref %outputs "out")
2048                                          "/lib/debug")
2049                           (string-append "EFI_DIR="
2050                                          (assoc-ref %outputs "out")
2051                                          "/lib/efi") ; TODO lib64 ?
2052                           "MINIOS_UPSTREAM_URL="
2053                           ;(string-append "DISTDIR="
2054                           ;               (assoc-ref %outputs "out"))
2055 )
2056        #:test-target "test"
2057        #:phases
2058        (modify-phases %standard-phases
2059         (add-after 'unpack 'unpack-mini-os
2060           (lambda* (#:key inputs #:allow-other-keys)
2061             (copy-recursively (assoc-ref inputs "mini-os") "extras/mini-os")
2062             #t))
2063         (add-after 'unpack-mini-os 'patch
2064           (lambda* (#:key inputs outputs #:allow-other-keys)
2065             (substitute* "tools/firmware/Rules.mk"
2066              (("override XEN_TARGET_ARCH = x86_32")
2067               (string-append "override XEN_TARGET_ARCH = x86_32
2068 override CC = " (assoc-ref inputs "cross-gcc") "/bin/i686-linux-gnu-gcc"))
2069              (("^CFLAGS =$")
2070               (string-append "CFLAGS=-I" (assoc-ref inputs "cross-libc")
2071                              "/include\n")))
2072             (substitute* "config/x86_32.mk"
2073              (("CFLAGS += -m32 -march=i686")
2074               (string-append "CFLAGS += -march=i686 -I"
2075                              (assoc-ref inputs "cross-libc")
2076                              "/include")))
2077             ;; /var is not in /gnu/store , so don't try to create it.
2078             (substitute* '("tools/Makefile"
2079                            "tools/xenstore/Makefile"
2080                            "tools/xenpaging/Makefile")
2081              (("\\$\\(INSTALL_DIR\\) .*XEN_(DUMP|LOG|RUN|LIB|PAGING)_DIR.*")
2082               "\n")
2083              (("\\$\\(INSTALL_DIR\\) .*XEN_(RUN|LIB)_STORED.*")
2084               "\n"))
2085             ;; Prevent xen from creating /etc .
2086             (substitute* "tools/examples/Makefile"
2087              ((" install-readmes") "")
2088              ((" install-configs") ""))
2089             ;; Set rpath.
2090             (substitute* "tools/pygrub/setup.py"
2091              (("library_dirs =")
2092               ; TODO: extra_link_args = ['-Wl,-rpath=/opt/foo'],
2093               (string-append "runtime_library_dirs = ['"
2094                              (assoc-ref outputs "out")
2095                              "/lib'],\nlibrary_dirs =")))
2096             #t))
2097         (add-before 'configure 'patch-xen-script-directory
2098           (lambda* (#:key outputs #:allow-other-keys)
2099             (substitute* '("configure"
2100                            "tools/configure"
2101                            "docs/configure")
2102              (("XEN_SCRIPT_DIR=.*")
2103               (string-append "XEN_SCRIPT_DIR="
2104                              (assoc-ref outputs "out")
2105                              "/etc/xen/scripts")))
2106             #t))
2107         (add-before 'configure 'set-environment-up
2108           (lambda* (#:key make-flags #:allow-other-keys)
2109              (define (cross? x)
2110                (string-contains x "cross-i686-linux"))
2111              (define (filter-environment! filter-predicate
2112                                           environment-variable-names)
2113                (for-each
2114                 (lambda (env-name)
2115                   (let* ((env-value (getenv env-name))
2116                          (search-path (search-path-as-string->list env-value))
2117                          (new-search-path (filter filter-predicate
2118                                                   search-path))
2119                          (new-env-value (list->search-path-as-string
2120                                          new-search-path ":")))
2121                     (setenv env-name new-env-value)))
2122                 environment-variable-names))
2123              (setenv "CROSS_C_INCLUDE_PATH" (getenv "C_INCLUDE_PATH"))
2124              (setenv "CROSS_CPLUS_INCLUDE_PATH" (getenv "CPLUS_INCLUDE_PATH"))
2125              (setenv "CROSS_LIBRARY_PATH" (getenv "LIBRARY_PATH"))
2126              (filter-environment! cross?
2127               '("CROSS_C_INCLUDE_PATH" "CROSS_CPLUS_INCLUDE_PATH"
2128                 "CROSS_LIBRARY_PATH"))
2129              (filter-environment! (lambda (e) (not (cross? e)))
2130               '("C_INCLUDE_PATH" "CPLUS_INCLUDE_PATH"
2131                 "LIBRARY_PATH"))
2132              ;; Guix tries to be helpful and automatically adds
2133              ;; mini-os-git-checkout/include to the include path,
2134              ;; but actually we don't want it to be there (yet).
2135              (filter-environment! (lambda (e)
2136                                     (not
2137                                      (string-contains e
2138                                       "mini-os-git-checkout")))
2139               '("C_INCLUDE_PATH" "CPLUS_INCLUDE_PATH"
2140                 "LIBRARY_PATH"))
2141             (setenv "EFI_VENDOR" "guix")
2142              #t))
2143         (replace 'build
2144           (lambda* (#:key make-flags #:allow-other-keys)
2145             (apply invoke "make" "world" make-flags))))))
2146     (inputs
2147      `(("acpica" ,acpica) ; TODO: patch iasl invocation.
2148        ("bridge-utils" ,bridge-utils) ; TODO: patch invocations.
2149        ("glib" ,glib)
2150        ("iproute" ,iproute) ; TODO: patch invocations.
2151        ("libaio" ,libaio)
2152        ("libx11" ,libx11)
2153        ("libyajl" ,libyajl)
2154        ("ncurses" ,ncurses)
2155        ("openssl" ,openssl)
2156        ("ovmf" ,ovmf)
2157        ("pixman" ,pixman)
2158        ("qemu" ,qemu-minimal)
2159        ("seabios" ,seabios)
2160        ("util-linux" ,util-linux "lib") ; uuid
2161        ; TODO: ocaml-findlib, ocaml-nox.
2162        ("xz" ,xz) ; for liblzma
2163        ("zlib" ,zlib)))
2164     (native-inputs
2165      `(("dev86" ,dev86)
2166        ("bison" ,bison)
2167        ("cmake" ,cmake-minimal)
2168        ("figlet" ,figlet)
2169        ("flex" ,flex)
2170        ("gettext" ,gettext-minimal)
2171        ("libnl" ,libnl)
2172        ("mini-os"
2173        ,(origin
2174          (method git-fetch)
2175          (uri (git-reference
2176                (url "http://xenbits.xen.org/git-http/mini-os.git")
2177                (commit (string-append "xen-RELEASE-" version))))
2178          (sha256
2179           (base32
2180            "1i8pcl19n60i2m9vlg79q3nknpj209c9ic5x10wxaicx45kc107f"))
2181          (file-name "mini-os-git-checkout")))
2182        ("perl" ,perl)
2183        ; TODO: markdown
2184        ("pkg-config" ,pkg-config)
2185        ("python" ,python-2)
2186        ("wget" ,wget)
2187        ("cross-gcc" ,(cross-gcc "i686-linux-gnu"
2188                                 #:xbinutils (cross-binutils "i686-linux-gnu")
2189                                 #:libc (cross-libc "i686-linux-gnu")))
2190        ("cross-libc" ,(cross-libc "i686-linux-gnu")) ; header files
2191        ("cross-libc-static" ,(cross-libc "i686-linux-gnu") "static")))
2192     (home-page "https://xenproject.org/")
2193     (synopsis "Xen Virtual Machine Monitor")
2194     (description "This package provides the Xen Virtual Machine Monitor
2195 which is a hypervisor.")
2196     ;; TODO: Some files are licensed differently.  List those.
2197     (license license:gpl2)
2198     (supported-systems '("i686-linux" "x86_64-linux" "armhf-linux"))))
2199
2200 (define-public osinfo-db-tools
2201   (package
2202     (name "osinfo-db-tools")
2203     (version "1.8.0")
2204     (source (origin
2205               (method url-fetch)
2206               (uri (string-append "https://releases.pagure.org/libosinfo/osinfo-db-tools-"
2207                                   version ".tar.xz"))
2208
2209               (sha256
2210                (base32
2211                 "038q3gzdbkfkhpicj0755mw1q4gbvn57pslpw8n2dp3lds9im0g9"))))
2212     (build-system meson-build-system)
2213     (inputs
2214      `(("libsoup" ,libsoup)
2215        ("libxml2" ,libxml2)
2216        ("libxslt" ,libxslt)
2217        ("json-glib" ,json-glib)
2218        ("libarchive" ,libarchive)))
2219     (native-inputs
2220      `(("perl" ,perl)
2221        ("gobject-introspection" ,gobject-introspection)
2222        ("gettext" ,gettext-minimal)
2223        ("pkg-config" ,pkg-config)
2224        ;; Tests
2225        ("python" ,python)
2226        ("pytest" ,python-pytest)
2227        ("requests" ,python-requests)))
2228     (home-page "https://gitlab.com/libosinfo/osinfo-db-tools")
2229     (synopsis "Tools for managing the osinfo database")
2230     (description "This package contains a set of tools to assist
2231 administrators and developers in managing the database.")
2232     (license license:lgpl2.0+)))
2233
2234 (define-public osinfo-db
2235   (package
2236     (name "osinfo-db")
2237     (version "20210903")
2238     (source (origin
2239               (method url-fetch)
2240               (uri (string-append "https://releases.pagure.org/libosinfo/osinfo-db-"
2241                                   version ".tar.xz"))
2242               (sha256
2243                (base32
2244                 "0d08ffvwdzwr16gv7pz2r7brds5gciirz8ixs97s5ly03grd7rrh"))))
2245     (build-system trivial-build-system)
2246     (arguments
2247      `(#:modules ((guix build utils))
2248        #:builder
2249        (begin
2250          (use-modules (guix build utils))
2251          (let* ((out (assoc-ref %outputs "out"))
2252                 (osinfo-dir (string-append out "/share/osinfo"))
2253                 (source (assoc-ref %build-inputs "source"))
2254                 (osinfo-db-import
2255                  (string-append (assoc-ref %build-inputs "osinfo-db-tools")
2256                                 "/bin/osinfo-db-import")))
2257            (mkdir-p osinfo-dir)
2258            (invoke osinfo-db-import "--dir" osinfo-dir source)))))
2259     (native-inputs
2260      `(("intltool" ,intltool)
2261        ("osinfo-db-tools" ,osinfo-db-tools)))
2262     (home-page "https://gitlab.com/libosinfo/osinfo-db")
2263     (synopsis "Database of information about operating systems")
2264     (description "Osinfo-db provides the database files for use with the
2265 libosinfo library.  It provides information about guest operating systems for
2266 use with virtualization provisioning tools")
2267     (license license:lgpl2.0+)))
2268
2269 (define-public python-transient
2270   (package
2271     (name "python-transient")
2272     (version "0.12")
2273     (source
2274      (origin
2275        (method url-fetch)
2276        (uri (pypi-uri "transient" version))
2277        (sha256
2278         (base32
2279          "148yiqrmcscsi6787y0f27i1y9cf0gcw3mqfv5frhpmsmv62mv5z"))))
2280     (build-system python-build-system)
2281     (arguments
2282      `(#:tests? #f ; Requires behave
2283        #:phases (modify-phases %standard-phases
2284                   (add-after 'unpack 'fix-dependencies
2285                     (lambda _
2286                       (substitute* "setup.py"
2287                         (("==")
2288                          ">="))
2289                       #t)))))
2290     (propagated-inputs
2291      `(("python-beautifultable" ,python-beautifultable)
2292        ("python-click" ,python-click)
2293        ("python-importlib-resources"
2294         ,python-importlib-resources)
2295        ("python-lark-parser" ,python-lark-parser)
2296        ("python-marshmallow" ,python-marshmallow)
2297        ("python-progressbar2" ,python-progressbar2)
2298        ("python-requests" ,python-requests)
2299        ("python-toml" ,python-toml)))
2300     (native-inputs
2301      `(("python-black" ,python-black)
2302        ("python-mypy" ,python-mypy)
2303        ("python-pyhamcrest" ,python-pyhamcrest)
2304        ("python-twine" ,python-twine)))
2305     (home-page
2306      "https://github.com/ALSchwalm/transient")
2307     (synopsis
2308      "QEMU Wrapper written in Python")
2309     (description
2310      "@code{transient} is a wrapper for QEMU allowing the creation of virtual
2311 machines with shared folder, ssh, and disk creation support.")
2312     (license license:expat)))