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                                 "qemu-fix-agent-paths.patch"))
 164        (modules '((guix build utils)))
 165        (snippet
 166         '(begin
 167            ;; Delete the bundled meson copy.
 168            (delete-file-recursively "meson")))))
 169     (outputs '("out" "static" "doc"))   ;5.3 MiB of HTML docs
 170     (build-system gnu-build-system)
 171     (arguments
 172      ;; FIXME: Disable tests on i686 to work around
 173      ;; <https://bugs.gnu.org/40527>.
 174      `(#:tests? ,(or (%current-target-system)
 175                      (not (string=? "i686-linux" (%current-system))))
 176        #:configure-flags
 177        (let ((gcc (search-input-file %build-inputs "/bin/gcc"))
 178              (out (assoc-ref %outputs "out")))
 179          (list (string-append "--cc=" gcc)
 180                ;; Some architectures insist on using HOST_CC.
 181                (string-append "--host-cc=" gcc)
 182                (string-append "--prefix=" out)
 183                "--sysconfdir=/etc"
 184                (string-append "--smbd=" out "/libexec/samba-wrapper")
 185                "--disable-debug-info"   ;for space considerations
 186                ;; The binaries need to be linked against -lrt.
 187                (string-append "--extra-ldflags=-lrt")))
 188        ;; Make build and test output verbose to facilitate investigation upon failure.
 189        #:make-flags '("V=1")
 190        #:modules ((srfi srfi-1)
 191                   (srfi srfi-26)
 192                   (ice-9 ftw)
 193                   (ice-9 match)
 194                   ,@%gnu-build-system-modules)
 195        #:phases
 196        (modify-phases %standard-phases
 197          (add-after 'unpack 'extend-test-time-outs
 198            (lambda _
 199              ;; These tests can time out on heavily-loaded and/or slow storage.
 200              (substitute* (cons* "tests/qemu-iotests/common.qemu"
 201                                  (find-files "tests/qemu-iotests" "^[0-9]+$"))
 202                (("QEMU_COMM_TIMEOUT=[0-9]+" match)
 203                 (string-append match "9")))))
 204          (add-after 'unpack 'disable-unusable-tests
 205            (lambda _
 206              (substitute* "tests/unit/meson.build"
 207                ;; Comment out the test-qga test, which needs /sys and
 208                ;; fails within the build environment.
 209                (("tests.*test-qga.*$" all)
 210                 (string-append "# " all))
 211                ;; Comment out the test-char test, which needs networking and
 212                ;; fails within the build environment.
 213                ((".*'test-char':.*" all)
 214                 (string-append "# " all)))))
 215          (add-after 'patch-source-shebangs 'patch-embedded-shebangs
 216            (lambda _
 217              ;; Ensure the executables created by these source files reference
 218              ;; /bin/sh from the store so they work inside the build container.
 219              (substitute* '("block/cloop.c" "migration/exec.c"
 220                             "net/tap.c" "tests/qtest/libqtest.c"
 221                             "tests/qtest/vhost-user-blk-test.c")
 222                (("/bin/sh") (which "sh")))
 223              (substitute* "tests/qemu-iotests/testenv.py"
 224                (("#!/usr/bin/env python3")
 225                 (string-append "#!" (which "python3"))))))
 226          (add-before 'configure 'fix-optionrom-makefile
 227            (lambda _
 228              ;; Work around the inability of the rules defined in this
 229              ;; Makefile to locate the firmware files (e.g.: No rule to make
 230              ;; target 'multiboot.bin') by extending the VPATH.
 231              (substitute* "pc-bios/optionrom/Makefile"
 232                (("^VPATH = \\$\\(SRC_DIR\\)")
 233                 "VPATH = $(SRC_DIR):$(TOPSRC_DIR)/pc-bios"))))
 234          ;; XXX ./configure is being re-run at beginning of build phase...
 235          (replace 'configure
 236            (lambda* (#:key inputs outputs configure-flags #:allow-other-keys)
 237              ;; The `configure' script doesn't understand some of the
 238              ;; GNU options.  Thus, add a new phase that's compatible.
 239              (let ((out (assoc-ref outputs "out")))
 240                (setenv "SHELL" (which "bash"))
 241                ;; Ensure config.status gets the correct shebang off the bat.
 242                ;; The build system gets confused if we change it later and
 243                ;; attempts to re-run the whole configuration, and fails.
 244                (substitute* "configure"
 245                  (("#!/bin/sh")
 246                   (string-append "#!" (which "sh"))))
 247                (mkdir-p "b/qemu")
 248                (chdir "b/qemu")
 249                (apply invoke "../../configure" configure-flags))))
 250          ;; Configure, build and install QEMU user-emulation static binaries.
 251          (add-after 'configure 'configure-user-static
 252            (lambda* (#:key inputs outputs #:allow-other-keys)
 253              (let* ((gcc (search-input-file inputs "/bin/gcc"))
 254                     (static (assoc-ref outputs "static"))
 255                     ;; This is the common set of configure flags; it is
 256                     ;; duplicated here to isolate this phase from manipulations
 257                     ;; to the #:configure-flags build argument, as done in
 258                     ;; derived packages such as qemu-minimal.
 259                     (configure-flags (list (string-append "--cc=" gcc)
 260                                            (string-append "--host-cc=" gcc)
 261                                            "--sysconfdir=/etc"
 262                                            "--disable-debug-info")))
 263                (mkdir-p "../user-static")
 264                (with-directory-excursion "../user-static"
 265                  (apply invoke "../../configure"
 266                         "--static"
 267                         "--disable-docs" ;already built
 268                         "--disable-system"
 269                         "--enable-linux-user"
 270                         (string-append "--prefix=" static)
 271                         configure-flags)))))
 272          (add-after 'build 'build-user-static
 273            (lambda args
 274              (with-directory-excursion "../user-static"
 275                (apply (assoc-ref %standard-phases 'build) args))))
 276          (add-after 'install 'install-user-static
 277            (lambda* (#:key outputs #:allow-other-keys)
 278              (let* ((static (assoc-ref outputs "static"))
 279                     (bin (string-append static "/bin")))
 280                (with-directory-excursion "../user-static"
 281                  (for-each (cut install-file <> bin)
 282                            (append-map (cut find-files <> "^qemu-" #:stat stat)
 283                                        (scandir "."
 284                                                 (cut string-suffix?
 285                                                      "-linux-user" <>))))))))
 286          ;; Create a wrapper for Samba. This allows QEMU to use Samba without
 287          ;; pulling it in as an input. Note that you need to explicitly install
 288          ;; Samba in your Guix profile for Samba support.
 289          (add-after 'install 'create-samba-wrapper
 290            (lambda* (#:key inputs outputs #:allow-other-keys)
 291              (let* ((out    (assoc-ref outputs "out"))
 292                     (libexec (string-append out "/libexec")))
 293                (call-with-output-file "samba-wrapper"
 294                  (lambda (port)
 295                    (format port "#!/bin/sh
 296 exec smbd $@")))
 297                (chmod "samba-wrapper" #o755)
 298                (install-file "samba-wrapper" libexec))))
 299          (add-after 'install 'move-html-doc
 300            (lambda* (#:key inputs outputs #:allow-other-keys)
 301              (let* ((out (assoc-ref outputs "out"))
 302                     (doc (assoc-ref outputs "doc"))
 303                     (qemu-doc (string-append doc "/share/doc/qemu-" ,version)))
 304                (mkdir-p qemu-doc)
 305                (rename-file (string-append out "/share/doc/qemu")
 306                             (string-append qemu-doc "/html"))))))))
 307     (inputs                             ; TODO: Add optional inputs.
 308      `(("alsa-lib" ,alsa-lib)
 309        ("attr" ,attr)
 310        ("glib" ,glib)
 311        ("gtk+" ,gtk+)
 312        ("libaio" ,libaio)
 313        ("libattr" ,attr)
 314        ("libcacard" ,libcacard)  ; smartcard support
 315        ("libcap-ng" ,libcap-ng)  ; virtfs support requires libcap-ng & libattr
 316        ("libdrm" ,libdrm)
 317        ("libepoxy" ,libepoxy)
 318        ("libjpeg" ,libjpeg-turbo)
 319        ("libpng" ,libpng)
 320        ("libseccomp" ,libseccomp)
 321        ("libusb" ,libusb)               ;USB pass-through support
 322        ("mesa" ,mesa)
 323        ("ncurses" ,ncurses)
 324        ;; ("pciutils" ,pciutils)
 325        ("pixman" ,pixman)
 326        ("pulseaudio" ,pulseaudio)
 327        ("sdl2" ,sdl2)
 328        ("spice" ,spice)
 329        ("usbredir" ,usbredir)
 330        ("util-linux" ,util-linux)
 331        ("vde2" ,vde2)
 332        ("virglrenderer" ,virglrenderer)
 333        ("zlib" ,zlib)))
 334     (native-inputs `(("gettext" ,gettext-minimal)
 335                      ("glib:bin" ,glib "bin") ; gtester, etc.
 336                      ("perl" ,perl)
 337                      ("flex" ,flex)
 338                      ("bison" ,bison)
 339                      ("meson" ,meson)
 340                      ("ninja" ,ninja)
 341                      ("pkg-config" ,pkg-config)
 342                      ("python-wrapper" ,python-wrapper)
 343                      ("python-sphinx" ,python-sphinx)
 344                      ("python-sphinx-rtd-theme" ,python-sphinx-rtd-theme)
 345                      ("texinfo" ,texinfo)
 346                      ;; The following static libraries are required to build
 347                      ;; the static output of QEMU.
 348                      ("glib:static" ,glib "static")
 349                      ("pcre:static" ,pcre "static")
 350                      ("zlib:static" ,zlib "static")))
 351     (home-page "https://www.qemu.org")
 352     (synopsis "Machine emulator and virtualizer")
 353     (description
 354      "QEMU is a generic machine emulator and virtualizer.
 355
 356 When used as a machine emulator, QEMU can run OSes and programs made for one
 357 machine (e.g. an ARM board) on a different machine---e.g., your own PC.  By
 358 using dynamic translation, it achieves very good performance.
 359
 360 When used as a virtualizer, QEMU achieves near native performances by
 361 executing the guest code directly on the host CPU.  QEMU supports
 362 virtualization when executing under the Xen hypervisor or using
 363 the KVM kernel module in Linux.  When using KVM, QEMU can virtualize x86,
 364 server and embedded PowerPC, and S390 guests.")
 365
 366     ;; Many files are GPLv2+, but some are GPLv2-only---e.g., `memory.c'.
 367     (license license:gpl2)
 368
 369     ;; Several tests fail on MIPS; see <http://hydra.gnu.org/build/117914>.
 370     (supported-systems (fold delete %supported-systems
 371                              '("mips64el-linux" "i586-gnu")))))
 372
 373 (define-public qemu-minimal
 374   ;; QEMU without GUI support, only supporting the host's architecture
 375   (package
 376     (inherit qemu)
 377     (name "qemu-minimal")
 378     (outputs '("out" "doc"))
 379     (synopsis
 380      "Machine emulator and virtualizer (without GUI) for the host architecture")
 381     (arguments
 382      (substitute-keyword-arguments (package-arguments qemu)
 383        ((#:configure-flags configure-flags '(list))
 384         ;; Restrict to the host's architecture.
 385         (let* ((system (or (%current-target-system)
 386                            (%current-system)))
 387                (target-list-arg
 388                 (match system
 389                   ((? (cut string-prefix? "i686" <>))
 390                    "--target-list=i386-softmmu")
 391                   ((? (cut string-prefix? "x86_64" <>))
 392                    "--target-list=i386-softmmu,x86_64-softmmu")
 393                   ((? (cut string-prefix? "mips64" <>))
 394                    (string-append "--target-list=mips-softmmu,mipsel-softmmu,"
 395                                   "mips64-softmmu,mips64el-softmmu"))
 396                   ((? (cut string-prefix? "mips" <>))
 397                    "--target-list=mips-softmmu,mipsel-softmmu")
 398                   ((? (cut string-prefix? "aarch64" <>))
 399                    "--target-list=arm-softmmu,aarch64-softmmu")
 400                   ((? (cut string-prefix? "arm" <>))
 401                    "--target-list=arm-softmmu")
 402                   ((? (cut string-prefix? "alpha" <>))
 403                    "--target-list=alpha-softmmu")
 404                   ((? (cut string-prefix? "powerpc64" <>))
 405                    "--target-list=ppc-softmmu,ppc64-softmmu")
 406                   ((? (cut string-prefix? "powerpc" <>))
 407                    "--target-list=ppc-softmmu")
 408                   ((? (cut string-prefix? "s390" <>))
 409                    "--target-list=s390x-softmmu")
 410                   ((? (cut string-prefix? "riscv" <>))
 411                    "--target-list=riscv32-softmmu,riscv64-softmmu")
 412                   (else       ; An empty list actually builds all the targets.
 413                    '()))))
 414           `(cons ,target-list-arg ,configure-flags)))
 415        ((#:phases phases)
 416         `(modify-phases ,phases
 417            (delete 'configure-user-static)
 418            (delete 'build-user-static)
 419            (delete 'install-user-static)))))
 420
 421     ;; Remove dependencies on optional libraries, notably GUI libraries.
 422     (native-inputs (fold alist-delete (package-native-inputs qemu)
 423                          '("gettext" "glib:static" "pcre:static" "zlib:static")))
 424     (inputs (fold alist-delete (package-inputs qemu)
 425                   '("libusb" "mesa" "sdl2" "spice" "virglrenderer" "gtk+"
 426                     "usbredir" "libdrm" "libepoxy" "pulseaudio" "vde2"
 427                     "libcacard")))))
 428
 429 (define (system->qemu-target system)
 430   (cond
 431    ((string-prefix? "i686" system)
 432     "qemu-system-i386")
 433    ((string-prefix? "arm" system)
 434     "qemu-system-arm")
 435    (else
 436     (string-append "qemu-system-" (match (string-split system #\-)
 437                                     ((arch kernel) arch)
 438                                     (_ system))))))
 439
 440 (define-public libx86emu
 441   (package
 442     (name "libx86emu")
 443     (version "3.1")
 444     (home-page "https://github.com/wfeldt/libx86emu")
 445     (source
 446      (origin
 447        (method git-fetch)
 448        (uri
 449         (git-reference
 450          (url home-page)
 451          (commit version)))
 452        (file-name (git-file-name name version))
 453        (modules
 454         '((guix build utils)))
 455        (snippet
 456         `(begin
 457            ;; Remove git2log program file.
 458            (delete-file "git2log")
 459            ;; Remove variables that depends on git2log.
 460            (substitute* "Makefile"
 461              (("GIT2LOG.*=.*$") "")
 462              (("GITDEPS.*=.*$") "")
 463              (("BRANCH.*=.*$") ""))
 464            #t))
 465        (sha256
 466         (base32 "104xqc6nj9rpi7knl3dfqvasf087hlz2n5yndb1iycw35a6j509b"))))
 467     (build-system gnu-build-system)
 468     (arguments
 469      `(#:test-target "test"
 470        #:phases
 471        (modify-phases %standard-phases
 472          (add-after 'unpack 'patch
 473            (lambda* (#:key outputs #:allow-other-keys)
 474              (let* ((out (assoc-ref outputs "out"))
 475                     (include (string-append out "/include"))
 476                     (lib (string-append out "/lib")))
 477                ;; Correct the values of version and install directories.
 478                (substitute* "Makefile"
 479                  (("VERSION.*=.*$")
 480                   (string-append "VERSION := "
 481                                  ,version "\n"))
 482                  (("PREFIX.*=.*$")
 483                   (string-append "PREFIX := " out "\n"))
 484                  (("MAJOR_VERSION.*=.*$")
 485                   (string-append "MAJOR_VERSION := "
 486                                  ,(version-major version) "\n"))
 487                  (("LIBDIR.*=.*$")
 488                   (string-append "LIBDIR = " lib "\n"))
 489                  (("/usr/include") include)))))
 490          (delete 'configure))))         ; no configure script
 491     (native-inputs
 492      `(("nasm" ,nasm)
 493        ("perl" ,perl)))
 494     (synopsis "Library for x86 emulation")
 495     (description "Libx86emu is a small library to emulate x86 instructions.  The
 496 focus here is not a complete emulation but to cover enough for typical
 497 firmware blobs.  You can
 498 @enumerate
 499 @item intercept any memory access or directly map real memory ranges
 500 @item intercept any i/o access, map real i/o ports, or block any real i/o
 501 @item intercept any interrupt
 502 @item add a hook to run after each instruction
 503 @item recognize a special x86 instruction that can trigger logging
 504 @item use integrated logging
 505 @end enumerate")
 506     (license (license:x11-style "file://LICENSE"))))
 507
 508 (define-public ganeti
 509   (package
 510     (name "ganeti")
 511     (version "3.0.1")
 512     (source (origin
 513               (method git-fetch)
 514               (uri (git-reference
 515                     (url "https://github.com/ganeti/ganeti")
 516                     (commit (string-append "v" version))))
 517               (sha256
 518                (base32 "1i7gx0sdx9316fnldbv738s0ihym1370nhc1chk0biandkl8vvq0"))
 519               (file-name (git-file-name name version))
 520               (patches (search-patches "ganeti-shepherd-support.patch"
 521                                        "ganeti-shepherd-master-failover.patch"
 522                                        "ganeti-sphinx-compat.patch"
 523                                        "ganeti-haskell-compat.patch"
 524                                        "ganeti-haskell-pythondir.patch"
 525                                        "ganeti-disable-version-symlinks.patch"))))
 526     (build-system gnu-build-system)
 527     (arguments
 528      `(#:imported-modules (,@%gnu-build-system-modules
 529                            (guix build haskell-build-system)
 530                            (guix build python-build-system))
 531        #:modules (,@%gnu-build-system-modules
 532                   ((guix build haskell-build-system) #:prefix haskell:)
 533                   (srfi srfi-1)
 534                   (srfi srfi-26)
 535                   (ice-9 match)
 536                   (ice-9 rdelim))
 537
 538        ;; The default test target includes a lot of checks that are only really
 539        ;; relevant for developers such as NEWS file checking, line lengths, etc.
 540        ;; We are only interested in the "py-tests" and "hs-tests" targets: this
 541        ;; is the closest we've got even though it includes a little more.
 542        #:test-target "check-TESTS"
 543
 544        #:configure-flags
 545        (list "--localstatedir=/var"
 546              "--sharedstatedir=/var"
 547              "--sysconfdir=/etc"
 548              "--enable-haskell-tests"
 549
 550              ;; By default, the build system installs everything to versioned
 551              ;; directories such as $libdir/3.0 and relies on a $libdir/default
 552              ;; symlink pointed from /etc/ganeti/{lib,share} to actually function.
 553              ;; This is done to accommodate installing multiple versions in
 554              ;; parallel, but is of little use to us as Guix users can just
 555              ;; roll back and forth.  Thus, disable it for simplicity.
 556              "--disable-version-links"
 557
 558              ;; Ganeti can optionally take control over SSH host keys and
 559              ;; distribute them to nodes as they are added, and also rotate keys
 560              ;; with 'gnt-cluster renew-crypto --new-ssh-keys'.  Thus it needs to
 561              ;; know how to restart the SSH daemon.
 562              "--with-sshd-restart-command='herd restart ssh-daemon'"
 563
 564              ;; Look for OS definitions in this directory by default.  It can
 565              ;; be changed in the cluster configuration.
 566              "--with-os-search-path=/run/current-system/profile/share/ganeti/os"
 567
 568              ;; The default QEMU executable to use.  We don't use the package
 569              ;; here because this entry is stored in the cluster configuration.
 570              (string-append "--with-kvm-path=/run/current-system/profile/bin/"
 571                             ,(system->qemu-target (%current-system))))
 572        #:phases
 573        (modify-phases %standard-phases
 574          (add-after 'unpack 'patch-version-constraints
 575            (lambda _
 576              ;; Loosen version constraints for compatibility with Stackage 18.10.
 577              (substitute* "cabal/ganeti.template.cabal"
 578                (("(.*base64-bytestring.*) < 1\\.1" _ match)
 579                 (string-append match " < 1.2"))
 580                (("(.*QuickCheck.*) < 2\\.14" _ match)
 581                 (string-append match " < 2.15")))))
 582          (add-after 'unpack 'create-vcs-version
 583            (lambda _
 584              ;; If we are building from a git checkout, we need to create a
 585              ;; 'vcs-version' file manually because the build system does
 586              ;; not have access to the git repository information.
 587              (unless (file-exists? "vcs-version")
 588                (call-with-output-file "vcs-version"
 589                  (lambda (port)
 590                    (format port "v~a~%" ,version))))))
 591          (add-after 'unpack 'patch-absolute-file-names
 592            (lambda _
 593              (substitute* '("lib/utils/process.py"
 594                             "lib/utils/text.py"
 595                             "src/Ganeti/Constants.hs"
 596                             "src/Ganeti/HTools/CLI.hs"
 597                             "test/py/ganeti.config_unittest.py"
 598                             "test/py/ganeti.hooks_unittest.py"
 599                             "test/py/ganeti.utils.process_unittest.py"
 600                             "test/py/ganeti.utils.text_unittest.py"
 601                             "test/py/ganeti.utils.wrapper_unittest.py")
 602                (("/bin/sh") (which "sh"))
 603                (("/bin/bash") (which "bash"))
 604                (("/usr/bin/env") (which "env"))
 605                (("/bin/true") (which "true")))
 606
 607              ;; This script is called by the node daemon at startup to perform
 608              ;; sanity checks on the cluster IP addresses, and it is also used
 609              ;; in a master-failover scenario.  Add absolute references to
 610              ;; avoid propagating these executables.
 611              (substitute* "tools/master-ip-setup"
 612                (("arping") (which "arping"))
 613                (("ndisc6") (which "ndisc6"))
 614                (("fping") (which "fping"))
 615                (("grep") (which "grep"))
 616                (("ip addr") (string-append (which "ip") " addr")))))
 617          (add-after 'unpack 'override-builtin-PATH
 618            (lambda _
 619              ;; Ganeti runs OS install scripts and similar with a built-in
 620              ;; hard coded PATH.  Patch so it works on Guix System.
 621              (substitute* "src/Ganeti/Constants.hs"
 622                (("/sbin:/bin:/usr/sbin:/usr/bin")
 623                 "/run/setuid-programs:/run/current-system/profile/sbin:\
 624 /run/current-system/profile/bin"))))
 625          (add-after 'bootstrap 'patch-sphinx-version-detection
 626            (lambda _
 627              ;; The build system runs 'sphinx-build --version' to verify that
 628              ;; the Sphinx is recent enough, but does not expect the
 629              ;; .sphinx-build-real executable name created by the Sphinx wrapper.
 630              (substitute* "configure"
 631                (("\\$SPHINX --version 2>&1")
 632                 "$SPHINX --version 2>&1 \
 633 | sed 's/.sphinx-build-real/sphinx-build/g'"))))
 634
 635          ;; The build system invokes Cabal and GHC, which do not work with
 636          ;; GHC_PACKAGE_PATH: <https://github.com/haskell/cabal/issues/3728>.
 637          ;; Tweak the build system to do roughly what haskell-build-system does.
 638          (add-before 'configure 'configure-haskell
 639            (assoc-ref haskell:%standard-phases 'setup-compiler))
 640          (add-after 'configure 'do-not-use-GHC_PACKAGE_PATH
 641            (lambda _
 642              (unsetenv "GHC_PACKAGE_PATH")
 643              (substitute* "Makefile"
 644                (("\\$\\(CABAL\\)")
 645                 "$(CABAL) --package-db=../package.conf.d")
 646                (("\\$\\(GHC\\)")
 647                 "$(GHC) -package-db=../package.conf.d"))))
 648          (add-after 'configure 'make-ghc-use-shared-libraries
 649            (lambda _
 650              (substitute* "Makefile"
 651                (("HFLAGS =") "HFLAGS = -dynamic -fPIC"))))
 652          (add-after 'configure 'fix-installation-directories
 653            (lambda _
 654              (substitute* "Makefile"
 655                ;; Do not attempt to create /var during install.
 656                (("\\$\\(DESTDIR\\)\\$\\{localstatedir\\}")
 657                 "$(DESTDIR)${prefix}${localstatedir}")
 658                ;; Similarly, do not attempt to install the sample ifup scripts
 659                ;; to /etc/ganeti.
 660                (("\\$\\(DESTDIR\\)\\$\\(ifupdir\\)")
 661                 "$(DESTDIR)${prefix}$(ifupdir)"))))
 662          (add-before 'build 'adjust-tests
 663            (lambda _
 664              ;; Disable tests that can not run.  Do it early to prevent
 665              ;; touching the Makefile later and triggering a needless rebuild.
 666              (substitute* "Makefile"
 667                ;; These tests expect the presence of a 'root' user (via
 668                ;; ganeti/runtime.py), which fails in the build environment.
 669                (("test/py/ganeti\\.asyncnotifier_unittest\\.py") "")
 670                (("test/py/ganeti\\.backend_unittest\\.py") "")
 671                (("test/py/ganeti\\.daemon_unittest\\.py") "")
 672                (("test/py/ganeti\\.tools\\.ensure_dirs_unittest\\.py") "")
 673                (("test/py/ganeti\\.utils\\.io_unittest-runasroot\\.py") "")
 674                ;; Disable the bash_completion test, as it requires the full
 675                ;; bash instead of bash-minimal.
 676                (("test/py/bash_completion\\.bash")
 677                 "")
 678                ;; This test requires networking.
 679                (("test/py/import-export_unittest\\.bash")
 680                 ""))))
 681          (add-after 'build 'build-bash-completions
 682            (lambda _
 683              (setenv "PYTHONPATH" ".")
 684              (invoke "./autotools/build-bash-completion")
 685              (unsetenv "PYTHONPATH")))
 686          (add-before 'check 'pre-check
 687            (lambda* (#:key inputs #:allow-other-keys)
 688              ;; Set TZDIR so that time zones are found.
 689              (setenv "TZDIR" (search-input-directory inputs "share/zoneinfo"))
 690
 691              (substitute* "test/py/ganeti.utils.process_unittest.py"
 692                ;; This test attempts to run an executable with
 693                ;; RunCmd(..., reset_env=True), which fails because the default
 694                ;; PATH from Constants.hs does not exist in the build container.
 695                ((".*def testResetEnv.*" all)
 696                 (string-append "  @unittest.skipIf(True, "
 697                                "\"cannot reset env in the build container\")\n"
 698                                all))
 699
 700                ;; XXX: Somehow this test fails in the build container, but
 701                ;; works in 'guix environment -C', even without /bin/sh?
 702                ((".*def testPidFile.*" all)
 703                 (string-append "  @unittest.skipIf(True, "
 704                                "\"testPidFile fails in the build container\")\n"
 705                                all)))
 706
 707              ;; XXX: Why are these links not added automatically.
 708              (with-directory-excursion "test/hs"
 709                (for-each (lambda (file)
 710                            (symlink "../../src/htools" file))
 711                          '("hspace" "hscan" "hinfo" "hbal" "hroller"
 712                            "hcheck" "hail" "hsqueeze")))))
 713          (add-after 'install 'install-bash-completions
 714            (lambda* (#:key outputs #:allow-other-keys)
 715              (let* ((out (assoc-ref outputs "out"))
 716                     (compdir (string-append out "/etc/bash_completion.d")))
 717                (mkdir-p compdir)
 718                (copy-file "doc/examples/bash_completion"
 719                           (string-append compdir "/ganeti"))
 720                ;; The one file contains completions for many different
 721                ;; executables.  Create symlinks for found completions.
 722                (with-directory-excursion compdir
 723                  (for-each
 724                   (lambda (prog) (symlink "ganeti" prog))
 725                   (call-with-input-file "ganeti"
 726                     (lambda (port)
 727                       (let loop ((line (read-line port))
 728                                  (progs '()))
 729                         (if (eof-object? line)
 730                             progs
 731                             (if (string-prefix? "complete" line)
 732                                 (loop (read-line port)
 733                                       ;; Extract "prog" from lines of the form:
 734                                       ;; "complete -F _prog -o filenames prog".
 735                                       ;; Note that 'burnin' is listed with the
 736                                       ;; absolute file name, which is why we
 737                                       ;; run everything through 'basename'.
 738                                       (match (string-split line #\ )
 739                                         ((commands ... prog)
 740                                          (cons (basename prog) progs))))
 741                                 (loop (read-line port) progs)))))))))))
 742          ;; Wrap all executables with GUIX_PYTHONPATH.  We can't borrow
 743          ;; the phase from python-build-system because we also need to wrap
 744          ;; the scripts in $out/lib/ganeti such as "node-daemon-setup".
 745          (add-after 'install 'wrap
 746            (lambda* (#:key outputs #:allow-other-keys)
 747              (let* ((out (assoc-ref outputs "out"))
 748                     (sbin (string-append out "/sbin"))
 749                     (lib (string-append out "/lib")))
 750                (define (shell-script? file)
 751                  (call-with-ascii-input-file file
 752                    (lambda (port)
 753                      (let ((shebang (false-if-exception (read-line port))))
 754                        (and shebang
 755                             (string-prefix? "#!" shebang)
 756                             (or (string-contains shebang "/bin/bash")
 757                                 (string-contains shebang "/bin/sh")))))))
 758
 759                (define* (wrap? file #:rest _)
 760                  ;; Do not wrap shell scripts because some are meant to be
 761                  ;; sourced, which breaks if they are wrapped.  We do wrap
 762                  ;; the Haskell executables because some call out to Python
 763                  ;; directly.
 764                  (and (executable-file? file)
 765                       (not (symbolic-link? file))
 766                       (not (shell-script? file))))
 767
 768                (for-each (lambda (file)
 769                            (wrap-program file
 770                              `("GUIX_PYTHONPATH" ":" prefix
 771                                (,(getenv "GUIX_PYTHONPATH")))))
 772                          (append-map (cut find-files <> wrap?)
 773                                      (list (string-append lib "/ganeti")
 774                                            sbin)))))))))
 775     (native-inputs
 776      `(("haskell" ,ghc)
 777        ("cabal" ,cabal-install)
 778        ("m4" ,m4)
 779
 780        ;; These inputs are necessary to bootstrap the package, because we
 781        ;; have patched the build system.
 782        ("autoconf" ,autoconf)
 783        ("automake" ,automake)
 784
 785        ;; For the documentation.
 786        ("python-docutils" ,python-docutils)
 787        ("sphinx" ,python-sphinx)
 788        ("pandoc" ,pandoc)
 789        ("dot" ,graphviz)
 790
 791        ;; Test dependencies.
 792        ("fakeroot" ,fakeroot)
 793        ("ghc-temporary" ,ghc-temporary)
 794        ("ghc-test-framework" ,ghc-test-framework)
 795        ("ghc-test-framework-hunit" ,ghc-test-framework-hunit)
 796        ("ghc-test-framework-quickcheck2" ,ghc-test-framework-quickcheck2)
 797        ("python-mock" ,python-mock)
 798        ("python-pyyaml" ,python-pyyaml)
 799        ("openssh" ,openssh)
 800        ("procps" ,procps)
 801        ("shelltestrunner" ,shelltestrunner)
 802        ("tzdata" ,tzdata-for-tests)))
 803     (inputs
 804      `(("arping" ,iputils)              ;must be the iputils version
 805        ("curl" ,curl)
 806        ("fping" ,fping)
 807        ("iproute2" ,iproute)
 808        ("ndisc6" ,ndisc6)
 809        ("socat" ,socat)
 810        ("qemu" ,qemu-minimal)           ;for qemu-img
 811        ("ghc-attoparsec" ,ghc-attoparsec)
 812        ("ghc-base64-bytestring" ,ghc-base64-bytestring)
 813        ("ghc-cryptonite" ,ghc-cryptonite)
 814        ("ghc-curl" ,ghc-curl)
 815        ("ghc-hinotify" ,ghc-hinotify)
 816        ("ghc-hslogger" ,ghc-hslogger)
 817        ("ghc-json" ,ghc-json)
 818        ("ghc-lens" ,ghc-lens)
 819        ("ghc-lifted-base" ,ghc-lifted-base)
 820        ("ghc-network" ,ghc-network)
 821        ("ghc-old-time" ,ghc-old-time)
 822        ("ghc-psqueue" ,ghc-psqueue)
 823        ("ghc-regex-pcre" ,ghc-regex-pcre)
 824        ("ghc-utf8-string" ,ghc-utf8-string)
 825        ("ghc-zlib" ,ghc-zlib)
 826
 827        ;; For the optional metadata daemon.
 828        ("ghc-snap-core" ,ghc-snap-core)
 829        ("ghc-snap-server" ,ghc-snap-server)
 830
 831        ("python" ,python)
 832        ("python-pyopenssl" ,python-pyopenssl)
 833        ("python-simplejson" ,python-simplejson)
 834        ("python-pyparsing" ,python-pyparsing)
 835        ("python-pyinotify" ,python-pyinotify)
 836        ("python-pycurl" ,python-pycurl)
 837        ("python-bitarray" ,python-bitarray)
 838        ("python-paramiko" ,python-paramiko)
 839        ("python-psutil" ,python-psutil)))
 840     (home-page "https://www.ganeti.org/")
 841     (synopsis "Cluster-based virtual machine management system")
 842     (description
 843      "Ganeti is a virtual machine management tool built on top of existing
 844 virtualization technologies such as Xen or KVM.  Ganeti controls:
 845
 846 @itemize @bullet
 847 @item Disk creation management;
 848 @item Operating system installation for instances (in co-operation with
 849 OS-specific install scripts); and
 850 @item Startup, shutdown, and failover between physical systems.
 851 @end itemize
 852
 853 Ganeti is designed to facilitate cluster management of virtual servers and
 854 to provide fast and simple recovery after physical failures, using
 855 commodity hardware.")
 856     (license license:bsd-2)))
 857
 858 (define-public ganeti-instance-guix
 859   (package
 860     (name "ganeti-instance-guix")
 861     (version "0.6")
 862     (home-page "https://github.com/mbakke/ganeti-instance-guix")
 863     (source (origin
 864               (method git-fetch)
 865               (uri (git-reference (url home-page) (commit version)))
 866               (file-name (git-file-name name version))
 867               (sha256
 868                (base32
 869                 "0aa08irpcpns6mhjgsplc5f0p8ab1qcr9ah1gj5z66kxgqyflzrp"))))
 870     (build-system gnu-build-system)
 871     (arguments
 872      '(#:configure-flags '("--sysconfdir=/etc" "--localstatedir=/var")))
 873     (native-inputs
 874      `(("autoconf" ,autoconf)
 875        ("automake" ,automake)))
 876     (inputs
 877      `(("util-linux" ,util-linux)
 878        ("qemu-img" ,qemu-minimal)))
 879     (synopsis "Guix OS integration for Ganeti")
 880     (description
 881      "This package provides a guest OS definition for Ganeti that uses
 882 Guix to build virtual machines.")
 883     (license license:gpl3+)))
 884
 885 (define-public ganeti-instance-debootstrap
 886   (package
 887     (name "ganeti-instance-debootstrap")
 888     ;; We need two commits on top of the latest release for compatibility
 889     ;; with newer sfdisk, as well as gnt-network integration.
 890     (version "0.16-2-ge145396")
 891     (home-page "https://github.com/ganeti/instance-debootstrap")
 892     (source (origin
 893               (method git-fetch)
 894               (uri (git-reference (url home-page) (commit version)))
 895               (file-name (git-file-name name version))
 896               (sha256
 897                (base32
 898                 "0f2isw9d8lawzj21rrq1q9xhq8xfa65rqbhqmrn59z201x9q1336"))))
 899     (build-system gnu-build-system)
 900     (arguments
 901      '(#:configure-flags '("--sysconfdir=/etc" "--localstatedir=/var")
 902        #:phases (modify-phases %standard-phases
 903                   (add-after 'unpack 'add-absolute-references
 904                     (lambda _
 905                       (substitute* "common.sh.in"
 906                         (("/sbin/blkid") (which "blkid"))
 907                         (("kpartx -")
 908                          (string-append (which "kpartx") " -")))
 909                       (substitute* "import"
 910                         (("restore -r")
 911                          (string-append (which "restore") " -r")))
 912                       (substitute* "export"
 913                         (("dump -0")
 914                          (string-append (which "dump") " -0")))
 915                       (substitute* "create"
 916                         (("debootstrap") (which "debootstrap"))
 917                         (("`which run-parts`") (which "run-parts"))
 918                         ;; Here we actually need to hard code /bin/passwd
 919                         ;; because it's called via chroot, which fails if
 920                         ;; "/bin" is not in PATH.
 921                         (("passwd") "/bin/passwd"))
 922                       #t))
 923                   (add-after 'unpack 'set-dpkg-arch
 924                     (lambda* (#:key system #:allow-other-keys)
 925                       ;; The create script passes --arch to debootstrap,
 926                       ;; and defaults to `dpkg --print-architecture` when
 927                       ;; ARCH is not set in variant.conf.  Hard code the
 928                       ;; build-time architecture to avoid the dpkg dependency.
 929                       (let ((dpkg-arch
 930                              (cond ((string-prefix? "x86_64" system)
 931                                     "amd64")
 932                                    ((string-prefix? "i686" system)
 933                                     "i386")
 934                                    ((string-prefix? "aarch64" system)
 935                                     "arm64")
 936                                    (else (car (string-split system #\-))))))
 937                         (substitute* "create"
 938                           (("`dpkg --print-architecture`")
 939                            dpkg-arch))
 940                         #t)))
 941                   (add-after 'configure 'adjust-Makefile
 942                     (lambda _
 943                       ;; Do not attempt to create /etc/ganeti/instance-debootstrap
 944                       ;; and /etc/default/ganeti-instance-debootstrap during install.
 945                       ;; They are created by the Ganeti service.
 946                       (substitute* "Makefile"
 947                         (("\\$\\(variantsdir\\)")
 948                          "$(prefix)/etc/ganeti/instance-debootstrap/variants")
 949                         (("\\$\\(defaultsdir\\)")
 950                          "$(prefix)/etc/default/ganeti-instance-debootstrap"))
 951                       #t))
 952                   (add-after 'install 'make-variants.list-symlink
 953                     (lambda* (#:key outputs #:allow-other-keys)
 954                       ;; The Ganeti OS API mandates a variants.list file that
 955                       ;; describes all supported "variants" of this OS.
 956                       ;; Guix generates this file, so make the original file
 957                       ;; a symlink to it.
 958                       (with-directory-excursion (string-append
 959                                                  (assoc-ref outputs "out")
 960                                                  "/share/ganeti/os/debootstrap")
 961                         (delete-file "variants.list")
 962                         (symlink "/etc/ganeti/instance-debootstrap/variants/variants.list"
 963                                  "variants.list"))
 964                       #t)))))
 965     (native-inputs
 966      `(("autoconf" ,autoconf)
 967        ("automake" ,automake)))
 968     (inputs
 969      `(("debianutils" ,debianutils)
 970        ("debootstrap" ,debootstrap)
 971        ("dump" ,dump)
 972        ("kpartx" ,multipath-tools)
 973        ("util-linux" ,util-linux)))
 974     (synopsis "Debian OS integration for Ganeti")
 975     (description
 976      "This package provides a guest OS definition for Ganeti.  It installs
 977 Debian or a derivative using @command{debootstrap}.")
 978     (license license:gpl2+)))
 979
 980 (define-public libosinfo
 981   (package
 982     (name "libosinfo")
 983     (version "1.9.0")
 984     (source
 985      (origin
 986        (method url-fetch)
 987        (uri (string-append "https://releases.pagure.org/libosinfo/libosinfo-"
 988                            version ".tar.xz"))
 989        (sha256
 990         (base32
 991          "0nd360c9ampw8hb6xh5g45q858df2r4jj9q88bcl6gzgaj0l3wxl"))))
 992     (build-system meson-build-system)
 993     (arguments
 994      `(#:configure-flags
 995        (list (string-append "-Dwith-usb-ids-path="
 996                             (assoc-ref %build-inputs "usb.ids"))
 997              (string-append "-Dwith-pci-ids-path="
 998                             (assoc-ref %build-inputs "pci.ids")))
 999        #:phases
1000        (modify-phases %standard-phases
1001          (add-after 'unpack 'patch-osinfo-path
1002            (lambda* (#:key inputs #:allow-other-keys)
1003              (substitute* "osinfo/osinfo_loader.c"
1004                (("path = DATA_DIR.*")
1005                 (string-append "path = \"" (assoc-ref inputs "osinfo-db")
1006                                "/share/osinfo\";"))))))))
1007     (inputs
1008      `(("libsoup" ,libsoup-minimal-2)
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.9.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 "131fyxb05rrcr9ih4mhhjyw3cgsxh5l12vj4y109q9vlynsz5742"))
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     (arguments
1338      `(#:meson ,meson-0.59))          ;KeyError: 'install_dir' with meson 0.60
1339     (inputs
1340      `(("openssl" ,openssl)
1341        ("cyrus-sasl" ,cyrus-sasl)
1342        ("lvm2" ,lvm2)                   ; for libdevmapper
1343        ("libyajl" ,libyajl)))
1344     (native-inputs
1345      `(("pkg-config" ,pkg-config)
1346        ("intltool" ,intltool)
1347        ("glib" ,glib "bin")
1348        ("vala" ,vala)))
1349     (propagated-inputs
1350      ;; ‘Required:’ by the installed .pc files.
1351      `(("glib" ,glib)
1352        ("libvirt" ,libvirt)
1353        ("libxml2" ,libxml2)
1354        ("gobject-introspection" ,gobject-introspection)))
1355     (home-page "https://libvirt.org")
1356     (synopsis "GLib wrapper around libvirt")
1357     (description "libvirt-glib wraps the libvirt library to provide a
1358 high-level object-oriented API better suited for glib-based applications, via
1359 three libraries:
1360
1361 @enumerate
1362 @item libvirt-glib - GLib main loop integration & misc helper APIs
1363 @item libvirt-gconfig - GObjects for manipulating libvirt XML documents
1364 @item libvirt-gobject - GObjects for managing libvirt objects
1365 @end enumerate
1366 ")
1367     (license license:lgpl2.1+)))
1368
1369 (define-public python-libvirt
1370   (package
1371     (name "python-libvirt")
1372     (version "7.3.0")
1373     (source
1374      (origin
1375        (method url-fetch)
1376        (uri (string-append "https://libvirt.org/sources/python/libvirt-python-"
1377                            version ".tar.gz"))
1378        (sha256
1379         (base32 "15pn8610ybf03xff3vbz3apz2ph42k2kh6k19r020l9nvc6jcv37"))))
1380     (build-system python-build-system)
1381     (arguments
1382      `(#:phases
1383        (modify-phases %standard-phases
1384          (replace 'check
1385            (lambda* (#:key inputs outputs tests? #:allow-other-keys)
1386              (when tests?
1387                ;; No reason to explicity invoke Python on a wrapped pytest.
1388                (substitute* "setup.py"
1389                  (("sys\\.executable, pytest") "pytest"))
1390                (add-installed-pythonpath inputs outputs)
1391                (setenv "LIBVIRT_API_COVERAGE" "whynot")
1392                (invoke "python" "setup.py" "test")))))))
1393     (inputs
1394      `(("libvirt" ,libvirt)))
1395     (propagated-inputs
1396      `(("python-lxml" ,python-lxml)))
1397     (native-inputs
1398      `(("pkg-config" ,pkg-config)
1399        ("python-pytest" ,python-pytest)))
1400     (home-page "https://libvirt.org")
1401     (synopsis "Python bindings to libvirt")
1402     (description "This package provides Python bindings to the libvirt
1403 virtualization library.")
1404     (license license:lgpl2.1+)))
1405
1406 (define-public virt-manager
1407   (package
1408     (name "virt-manager")
1409     (version "3.2.0")
1410     (source (origin
1411               (method url-fetch)
1412               (uri (string-append "https://virt-manager.org/download/sources"
1413                                   "/virt-manager/virt-manager-"
1414                                   version ".tar.gz"))
1415               (sha256
1416                (base32
1417                 "11kvpzcmyir91qz0dsnk7748jbb4wr8mrc744w117qc91pcy6vrb"))))
1418     (build-system python-build-system)
1419     (arguments
1420      `(#:use-setuptools? #f          ; uses custom distutils 'install' command
1421        #:tests? #f                      ; TODO The tests currently fail
1422                                         ; RuntimeError: Loop condition wasn't
1423                                         ; met
1424        #:imported-modules ((guix build glib-or-gtk-build-system)
1425                            ,@%python-build-system-modules)
1426        #:modules ((ice-9 match)
1427                   (srfi srfi-26)
1428                   (guix build python-build-system)
1429                   ((guix build glib-or-gtk-build-system) #:prefix glib-or-gtk:)
1430                   (guix build utils))
1431        #:phases
1432        (modify-phases %standard-phases
1433          (add-after 'unpack 'fix-setup
1434            (lambda* (#:key outputs #:allow-other-keys)
1435              (substitute* "virtinst/buildconfig.py"
1436                (("/usr") (assoc-ref outputs "out")))
1437              #t))
1438          (add-after 'unpack 'fix-default-uri
1439            (lambda* (#:key inputs #:allow-other-keys)
1440              ;; Xen is not available for now - so only patch qemu.
1441              (substitute* "virtManager/createconn.py"
1442                (("/usr(/bin/qemu-system-[a-zA-Z0-9_-]+)" _ suffix)
1443                 (search-input-file inputs suffix)))
1444              #t))
1445          (add-before 'wrap 'wrap-with-GI_TYPELIB_PATH
1446            (lambda* (#:key inputs outputs #:allow-other-keys)
1447              (let* ((bin       (string-append (assoc-ref outputs "out") "/bin"))
1448                     (bin-files (find-files bin ".*"))
1449                     (paths     (map (match-lambda
1450                                       ((output . directory)
1451                                        (let* ((girepodir (string-append
1452                                                           directory
1453                                                           "/lib/girepository-1.0")))
1454                                          (if (file-exists? girepodir)
1455                                              girepodir #f))))
1456                                     inputs)))
1457                (for-each (lambda (file)
1458                            (format #t "wrapping ~a\n" file)
1459                            (wrap-program file
1460                              `("GI_TYPELIB_PATH" ":" prefix
1461                                ,(filter identity paths))))
1462                          bin-files))
1463              #t))
1464          (replace 'check
1465            (lambda* (#:key tests? #:allow-other-keys)
1466              (when tests?
1467                (setenv "HOME" "/tmp")
1468                (setenv "XDG_CACHE_HOME" "/tmp")
1469                (system "Xvfb :1 &")
1470                (setenv "DISPLAY" ":1")
1471                ;; Dogtail requires that Assistive Technology support be enabled
1472                (setenv "GTK_MODULES" "gail:atk-bridge")
1473                (invoke "dbus-run-session" "--" "pytest" "--uitests"))
1474              #t))
1475          (add-after 'install 'glib-or-gtk-compile-schemas
1476            (assoc-ref glib-or-gtk:%standard-phases 'glib-or-gtk-compile-schemas))
1477          (add-after 'wrap 'glib-or-gtk-wrap
1478            (assoc-ref glib-or-gtk:%standard-phases 'glib-or-gtk-wrap)))))
1479     (inputs
1480      `(("dconf" ,dconf)
1481        ("gtk+" ,gtk+)
1482        ("gtk-vnc" ,gtk-vnc)
1483        ("gtksourceview" ,gtksourceview)
1484        ("libvirt" ,libvirt)
1485        ("libvirt-glib" ,libvirt-glib)
1486        ("libosinfo" ,libosinfo)
1487        ("vte" ,vte)
1488        ("python-libvirt" ,python-libvirt)
1489        ("python-requests" ,python-requests)
1490        ("python-pycairo" ,python-pycairo)
1491        ("python-pygobject" ,python-pygobject)
1492        ("python-libxml2" ,python-libxml2)
1493        ("spice-gtk" ,spice-gtk)))
1494     ;; virt-manager searches for qemu-img or kvm-img in the PATH.
1495     (propagated-inputs
1496      `(("qemu" ,qemu)))
1497     (native-inputs
1498      `(("glib" ,glib "bin")             ; glib-compile-schemas
1499        ("gobject-introspection" ,gobject-introspection)
1500        ("gtk+" ,gtk+ "bin")             ; gtk-update-icon-cache
1501        ("perl" ,perl)                   ; pod2man
1502        ("intltool" ,intltool)
1503        ("rst2man" ,python-docutils)
1504        ;; The following are required for running the tests
1505        ;; ("python-pytest" ,python-pytest)
1506        ;; ("python-dogtail" ,python-dogtail)
1507        ;; ("xvfb" ,xorg-server-for-tests)
1508        ;; ("dbus" ,dbus)
1509        ;; ("at-spi2-core" ,at-spi2-core)
1510        ;; ("gsettings-desktop-schemas" ,gsettings-desktop-schemas)
1511        ))
1512     (home-page "https://virt-manager.org/")
1513     (synopsis "Manage virtual machines")
1514     (description
1515      "The virt-manager application is a desktop user interface for managing
1516 virtual machines through libvirt.  It primarily targets KVM VMs, but also
1517 manages Xen and LXC (Linux containers).  It presents a summary view of running
1518 domains, their live performance and resource utilization statistics.")
1519     (license license:gpl2+)))
1520
1521 (define-public criu
1522   (package
1523     (name "criu")
1524     (version "3.16.1")
1525     (source
1526      (origin
1527        (method git-fetch)
1528        (uri (git-reference
1529              (url "https://github.com/checkpoint-restore/criu")
1530              (commit (string-append "v" version))))
1531        (file-name (git-file-name name version))
1532        (sha256
1533         (base32 "1riw15197fnrs254jl7wks9x8bdml76kf1vnqkkgyypr13dnq55g"))))
1534     (build-system gnu-build-system)
1535     (arguments
1536      `(#:test-target "test"
1537        #:tests? #f ; tests require mounting as root
1538        #:make-flags
1539        (list (string-append "PREFIX=" (assoc-ref %outputs "out"))
1540              (string-append "LIBDIR=" (assoc-ref %outputs "out")
1541                             "/lib")
1542              (string-append "ASCIIDOC="
1543                             (search-input-file %build-inputs
1544                                                "/bin/asciidoc"))
1545              (string-append "PYTHON=python3")
1546              (string-append "XMLTO="
1547                             (search-input-file %build-input
1548                                                "/bin/xmlto")))
1549        #:phases
1550        (modify-phases %standard-phases
1551          (delete 'configure)            ; no configure script
1552          (add-after 'unpack 'fix-documentation
1553            (lambda* (#:key inputs outputs #:allow-other-keys)
1554              (substitute* "Documentation/Makefile"
1555                (("-m custom.xsl")
1556                 (string-append
1557                  "-m custom.xsl --skip-validation -x "
1558                  (assoc-ref inputs "docbook-xsl") "/xml/xsl/"
1559                  ,(package-name docbook-xsl) "-"
1560                  ,(package-version docbook-xsl)
1561                  "/manpages/docbook.xsl")))))
1562          (add-after 'unpack 'hardcode-variables
1563            (lambda* (#:key inputs #:allow-other-keys)
1564              ;; Hardcode arm version detection
1565              (substitute* "Makefile"
1566                (("ARMV.*:=.*") "ARMV := 7\n"))))
1567          (add-before 'build 'fix-symlink
1568            (lambda* (#:key inputs #:allow-other-keys)
1569              ;; The file 'images/google/protobuf/descriptor.proto' points to
1570              ;; /usr/include/..., which obviously does not exist.
1571              (let* ((file "google/protobuf/descriptor.proto")
1572                     (target (string-append "images/" file))
1573                     (source (search-input-file
1574                              inputs
1575                              (string-append "include/" file))))
1576                (delete-file target)
1577                (symlink source target))))
1578          (add-after 'install 'wrap
1579            (lambda* (#:key inputs outputs #:allow-other-keys)
1580              ;; Make sure 'crit' runs with the correct PYTHONPATH.
1581              (let* ((out  (assoc-ref outputs "out"))
1582                     (site (string-append out "/lib/python"
1583                                          ,(version-major+minor
1584                                            (package-version python))
1585                                          "/site-packages"))
1586                     (path (getenv "GUIX_PYTHONPATH")))
1587                (wrap-program (string-append out "/bin/crit")
1588                  `("GUIX_PYTHONPATH" ":" prefix (,site ,path))))))
1589          (add-after 'install 'delete-static-libraries
1590            ;; Not building/installing these at all doesn't seem to be supported.
1591            (lambda* (#:key outputs #:allow-other-keys)
1592              (let ((out (assoc-ref outputs "out")))
1593                (for-each delete-file (find-files out "\\.a$"))))))))
1594     (inputs
1595      `(("protobuf" ,protobuf)
1596        ("python" ,python)
1597        ("python-protobuf" ,python-protobuf)
1598        ("iproute" ,iproute)
1599        ("libaio" ,libaio)
1600        ("libcap" ,libcap)
1601        ("libnet" ,libnet)
1602        ("libnl" ,libnl)
1603        ("libbsd" ,libbsd)
1604        ("nftables" ,nftables)))
1605     (native-inputs
1606      `(("pkg-config" ,pkg-config)
1607        ("perl" ,perl)
1608        ("protobuf-c" ,protobuf-c)
1609        ("asciidoc" ,asciidoc)
1610        ("xmlto" ,xmlto)
1611        ("docbook-xml" ,docbook-xml)
1612        ("docbook-xsl" ,docbook-xsl)))
1613     (home-page "https://criu.org")
1614     (synopsis "Checkpoint and restore in user space")
1615     (description "Using this tool, you can freeze a running application (or
1616 part of it) and checkpoint it to a hard drive as a collection of files.  You
1617 can then use the files to restore and run the application from the point it
1618 was frozen at.  The distinctive feature of the CRIU project is that it is
1619 mainly implemented in user space.")
1620     ;; The project is licensed under GPLv2; files in the lib/ directory are
1621     ;; LGPLv2.1.
1622     (license (list license:gpl2 license:lgpl2.1))))
1623
1624 (define-public qmpbackup
1625   (package
1626     (name "qmpbackup")
1627     (version "0.2")
1628     (source (origin
1629               (method git-fetch)
1630               (uri (git-reference
1631                      (url "https://github.com/abbbi/qmpbackup")
1632                      (commit version)))
1633               (file-name (git-file-name name version))
1634               (sha256
1635                (base32
1636                 "0swhp5byz44brhyis1a39p11fyn9q84xz5q6v2fah29r7d71kmmx"))))
1637     (build-system python-build-system)
1638     (arguments
1639      `(#:python ,python-2))
1640     (home-page "https://github.com/abbbi/qmpbackup")
1641     (synopsis "Backup and restore QEMU machines")
1642     (description "qmpbackup is designed to create and restore full and
1643 incremental backups of running QEMU virtual machines via QMP, the QEMU
1644 Machine Protocol.")
1645     (license license:gpl3+)))
1646
1647 (define-public looking-glass-client
1648   (let ((commit "182c4752d57690da7f99d5e788de9b8baea33895"))
1649     (package
1650      (name "looking-glass-client")
1651      (version (string-append "a12-" (string-take commit 7)))
1652      (source
1653       (origin
1654        (method git-fetch)
1655        (uri (git-reference (url "https://github.com/gnif/LookingGlass")
1656                            (commit commit)))
1657        (file-name (git-file-name name version))
1658        (sha256
1659         (base32
1660          "02bq46ndmzq9cihazzn7xq1x7q5nzm7iw4l9lqzihxcxp9famkhw"))
1661        (modules '((guix build utils)))
1662        (snippet
1663         '(begin
1664            ;; Do not create binaries optimized for the CPU of the build machine,
1665            ;; for reproducibility and compatibility.  TODO: in the next version
1666            ;; of looking glass, this is exposed as a CMake configure option.
1667            (substitute* "client/CMakeLists.txt"
1668              (("-march=native")
1669               ""))
1670            #t))))
1671      (build-system cmake-build-system)
1672      (inputs `(("fontconfig" ,fontconfig)
1673                ("glu" ,glu)
1674                ("mesa" ,mesa)
1675                ("openssl" ,openssl)
1676                ("sdl2" ,sdl2)
1677                ("sdl2-ttf" ,sdl2-ttf)
1678                ("spice-protocol" ,spice-protocol)
1679                ("wayland" ,wayland)))
1680      (native-inputs `(("libconfig" ,libconfig)
1681                       ("nettle" ,nettle)
1682                       ("pkg-config" ,pkg-config)))
1683      (arguments
1684       `(#:tests? #f ;; No tests are available.
1685         #:make-flags '("CC=gcc")
1686         #:phases (modify-phases %standard-phases
1687                    (add-before 'configure 'chdir-to-client
1688                      (lambda* (#:key outputs #:allow-other-keys)
1689                        (chdir "client")
1690                        #t))
1691                    (add-after 'chdir-to-client 'add-missing-include
1692                      (lambda _
1693                        ;; Mimic upstream commit b9797529893, required since the
1694                        ;; update to Mesa 19.2.
1695                        (substitute* "renderers/egl/shader.h"
1696                          (("#include <stdbool\\.h>")
1697                           "#include <stdbool.h>\n#include <stddef.h>"))
1698                        #t))
1699                    (replace 'install
1700                      (lambda* (#:key outputs #:allow-other-keys)
1701                        (install-file "looking-glass-client"
1702                                      (string-append (assoc-ref outputs "out")
1703                                                     "/bin"))
1704                        #t)))))
1705      (home-page "https://looking-glass.hostfission.com")
1706      (synopsis "KVM Frame Relay (KVMFR) implementation")
1707      (description "Looking Glass allows the use of a KVM (Kernel-based Virtual
1708 Machine) configured for VGA PCI Pass-through without an attached physical
1709 monitor, keyboard or mouse.  It displays the VM's rendered contents on your main
1710 monitor/GPU.")
1711      ;; This package requires SSE instructions.
1712      (supported-systems '("i686-linux" "x86_64-linux"))
1713      (license license:gpl2+))))
1714
1715 (define-public runc
1716   (package
1717     (name "runc")
1718     (version "1.0.0-rc93")
1719     (source (origin
1720               (method url-fetch)
1721               (uri (string-append
1722                     "https://github.com/opencontainers/runc/releases/"
1723                     "download/v" version "/runc.tar.xz"))
1724               (file-name (string-append name "-" version ".tar.xz"))
1725               (sha256
1726                (base32
1727                 "0b90r1bkvlqli53ca1yc1l488dba0isd3i6l7nlhszxi8p7hzvkh"))))
1728     (build-system go-build-system)
1729     (arguments
1730      '(#:import-path "github.com/opencontainers/runc"
1731        #:install-source? #f
1732        ;; XXX: 20/139 tests fail due to missing /var, cgroups and apparmor in
1733        ;; the build environment.
1734        #:tests? #f
1735        #:phases
1736        (modify-phases %standard-phases
1737          (replace 'build
1738            (lambda* (#:key import-path #:allow-other-keys)
1739              (with-directory-excursion (string-append "src/" import-path)
1740                (invoke "make" "all" "man"))))
1741          (replace 'check
1742            (lambda* (#:key tests? #:allow-other-keys)
1743              (when tests?
1744                (invoke "make" "localunittest"))))
1745          (replace 'install
1746            (lambda* (#:key import-path outputs #:allow-other-keys)
1747              (with-directory-excursion (string-append "src/" import-path)
1748                (let ((out (assoc-ref outputs "out")))
1749                  (invoke "make" "install" "install-bash" "install-man"
1750                          (string-append "PREFIX=" out)))))))))
1751     (native-inputs
1752      `(("go-md2man" ,go-github-com-go-md2man)
1753        ("pkg-config" ,pkg-config)))
1754     (inputs
1755      `(("libseccomp" ,libseccomp)))
1756     (synopsis "Open container initiative runtime")
1757     (home-page "https://opencontainers.org/")
1758     (description
1759      "@command{runc} is a command line client for running applications
1760 packaged according to the
1761 @uref{https://github.com/opencontainers/runtime-spec/blob/master/spec.md, Open
1762 Container Initiative (OCI) format} and is a compliant implementation of the
1763 Open Container Initiative specification.")
1764     (license license:asl2.0)))
1765
1766 (define-public umoci
1767   (package
1768     (name "umoci")
1769     (version "0.4.7")
1770     (source
1771      (origin
1772        (method url-fetch)
1773        (uri (string-append
1774              "https://github.com/opencontainers/umoci/releases/download/v"
1775              version "/umoci.tar.xz"))
1776        (file-name (string-append "umoci-" version ".tar.xz"))
1777        (sha256
1778         (base32 "0fvljj9k4f83wbqzd8nbijz0p1zaq633f8yxyvl5sy3wjf03ffk9"))))
1779     (build-system go-build-system)
1780     (arguments
1781      '(#:import-path "github.com/opencontainers/umoci"
1782        #:install-source? #f
1783        #:phases
1784        (modify-phases %standard-phases
1785          (replace 'unpack
1786            (lambda* (#:key source import-path #:allow-other-keys)
1787              ;; Unpack the tarball into 'umoci' instead of "runc-${version}".
1788              (let ((dest (string-append "src/" import-path)))
1789                (mkdir-p dest)
1790                (invoke "tar" "-C" (string-append "src/" import-path)
1791                        "--strip-components=1"
1792                        "-xvf" source))))
1793          (replace 'build
1794            (lambda* (#:key import-path #:allow-other-keys)
1795              (with-directory-excursion (string-append "src/" import-path)
1796                ;; TODO: build manpages with 'go-md2man'.
1797                (invoke "make" "SHELL=bash"))))
1798          (replace 'install
1799            (lambda* (#:key import-path outputs #:allow-other-keys)
1800              (let* ((out (assoc-ref outputs "out"))
1801                     (bindir (string-append out "/bin")))
1802                (install-file (string-append "src/" import-path "/umoci")
1803                              bindir)
1804                #t))))))
1805     (home-page "https://umo.ci/")
1806     (synopsis "Tool for modifying Open Container images")
1807     (description
1808      "@command{umoci} is a tool that allows for high-level modification of an
1809 Open Container Initiative (OCI) image layout and its tagged images.")
1810     (license license:asl2.0)))
1811
1812 (define-public skopeo
1813   (package
1814     (name "skopeo")
1815     (version "1.2.3")
1816     (source (origin
1817               (method git-fetch)
1818               (uri (git-reference
1819                     (url "https://github.com/containers/skopeo")
1820                     (commit (string-append "v" version))))
1821               (file-name (git-file-name name version))
1822               (sha256
1823                (base32
1824                 "0n22sdif437ddg5ch0ipwim3fg0n6ihc9bfi52qkhy3r1grz04hs"))))
1825     (build-system go-build-system)
1826     (native-inputs
1827      `(("pkg-config" ,pkg-config)
1828        ("go-github-com-go-md2man" ,go-github-com-go-md2man)))
1829     (inputs
1830      `(("btrfs-progs" ,btrfs-progs)
1831        ("eudev" ,eudev)
1832        ("libassuan" ,libassuan)
1833        ("libselinux" ,libselinux)
1834        ("libostree" ,libostree)
1835        ("lvm2" ,lvm2)
1836        ("glib" ,glib)
1837        ("gpgme" ,gpgme)))
1838     (arguments
1839      '(#:import-path "github.com/containers/skopeo"
1840        #:install-source? #f
1841        #:tests? #f                                ; The tests require Docker
1842        #:phases
1843        (modify-phases %standard-phases
1844          (replace 'build
1845            (lambda* (#:key import-path #:allow-other-keys)
1846              (with-directory-excursion (string-append "src/" import-path)
1847                (invoke "make" "bin/skopeo"))))
1848          (add-after 'build 'build-docs
1849            (lambda* (#:key import-path #:allow-other-keys)
1850              (with-directory-excursion (string-append "src/" import-path)
1851                (invoke "make" "docs"))))
1852          (replace 'install
1853            (lambda* (#:key import-path outputs #:allow-other-keys)
1854              (with-directory-excursion (string-append "src/" import-path)
1855                (let ((out (assoc-ref outputs "out")))
1856                  (install-file "default-policy.json"
1857                                (string-append out "/etc/containers"))
1858                  (invoke "make" "install-binary" "install-completions" "install-docs"
1859                          (string-append "PREFIX=" out)))))))))
1860     (home-page "https://github.com/containers/skopeo")
1861     (synopsis "Interact with container images and container image registries")
1862     (description
1863      "@command{skopeo} is a command line utility providing various operations
1864 with container images and container image registries.  It can:
1865 @enumerate
1866
1867 @item Copy container images between various containers image stores,
1868 converting them as necessary.
1869
1870 @item Convert a Docker schema 2 or schema 1 container image to an OCI image.
1871
1872 @item Inspect a repository on a container registry without needlessly pulling
1873 the image.
1874
1875 @item Sign and verify container images.
1876
1877 @item Delete container images from a remote container registry.
1878
1879 @end enumerate")
1880     (license license:asl2.0)))
1881
1882 (define-public python-vagrant
1883   (package
1884     (name "python-vagrant")
1885     (version "0.5.15")
1886     (source
1887       (origin
1888         (method url-fetch)
1889         (uri (pypi-uri "python-vagrant" version))
1890         (sha256
1891          (base32
1892           "1ikrh6canhcxg5y7pzmkcnnydikppv7s6sm9prfx90nk0ac8m6mg"))))
1893     (build-system python-build-system)
1894     (arguments
1895      '(#:tests? #f)) ; tests involve running vagrant.
1896     (home-page "https://github.com/todddeluca/python-vagrant")
1897     (synopsis "Python bindings for Vagrant")
1898     (description
1899      "Python-vagrant is a Python module that provides a thin wrapper around the
1900 @code{vagrant} command line executable, allowing programmatic control of Vagrant
1901 virtual machines.")
1902     (license license:expat)))
1903
1904 (define-public bubblewrap
1905   (package
1906     (name "bubblewrap")
1907     (version "0.4.1")
1908     (source (origin
1909               (method url-fetch)
1910               (uri (string-append "https://github.com/containers/bubblewrap/"
1911                                   "releases/download/v" version "/bubblewrap-"
1912                                   version ".tar.xz"))
1913               (sha256
1914                (base32
1915                 "00ycgi6q2yngh06bnz50wkvar6r2jnjf3j158grhi9k13jdrpimr"))))
1916     (build-system gnu-build-system)
1917     (arguments
1918      `(#:phases
1919        (modify-phases %standard-phases
1920          (add-after 'unpack 'fix-test
1921            (lambda* (#:key outputs #:allow-other-keys)
1922              ;; Tests try to access /var/tmp, which is not possible in our build
1923              ;; environment.  Let's give them another directory.
1924              ;; /tmp gets overriden in some tests, so we need another directory.
1925              ;; the only possibility is the output directory.
1926              (let ((tmp-dir (string-append (assoc-ref outputs "out") "/tmp")))
1927                (mkdir-p tmp-dir)
1928                (substitute* "tests/test-run.sh"
1929                  (("/var/tmp") tmp-dir)
1930                  ;; Tests create a temporary python script, so fix its shebang.
1931                  (("/usr/bin/env python") (which "python"))
1932                  ;; Some tests try to access /usr, but that doesn't exist.
1933                  ;; Give them /gnu instead.
1934                  (("/usr") "/gnu")
1935                  (("--ro-bind /bin /bin") "--ro-bind /gnu /bin")
1936                  (("--ro-bind /sbin /sbin") "--ro-bind /gnu /sbin")
1937                  (("--ro-bind /lib /lib") "--ro-bind /gnu /lib")
1938                  (("  */bin/bash") (which "bash"))
1939                  (("/bin/sh") (which "sh"))
1940                  (("findmnt") (which "findmnt"))))
1941              #t))
1942          ;; Remove the directory we gave to tests to have a clean package.
1943          (add-after 'check 'remove-tmp-dir
1944            (lambda* (#:key outputs #:allow-other-keys)
1945              (delete-file-recursively (string-append (assoc-ref outputs "out") "/tmp"))
1946              #t)))))
1947     (inputs
1948      `(("libcap" ,libcap)))
1949     (native-inputs
1950      `(("python" ,python-wrapper)
1951        ("util-linux" ,util-linux)))
1952     (home-page "https://github.com/containers/bubblewrap")
1953     (synopsis "Unprivileged sandboxing tool")
1954     (description "Bubblewrap is aimed at running applications in a sandbox,
1955 restricting their access to parts of the operating system or user data such as
1956 the home directory.  Bubblewrap always creates a new mount namespace, and the
1957 user can specify exactly what parts of the file system should be made visible
1958 in the sandbox.  These directories are mounted with the @code{nodev} option
1959 by default and can be made read-only.")
1960     (license license:lgpl2.0+)))
1961
1962 (define-public bochs
1963   (package
1964     (name "bochs")
1965     (version "2.7")
1966     (source
1967      (origin
1968        (method url-fetch)
1969        (uri (string-append "https://sourceforge.net/projects/bochs/files/bochs/"
1970                            version "/bochs-" version ".tar.gz"))
1971        (sha256
1972         (base32 "0ymiwnfqg5npq2dk9ngidbbfn3qw8z6i491finhcaan7zldsn450"))))
1973     (build-system gnu-build-system)
1974     (arguments
1975      `(#:tests? #f))                    ; no tests exist
1976     (inputs
1977      `(("libxrandr" ,libxrandr)))
1978     (home-page "http://bochs.sourceforge.net/")
1979     (synopsis "Emulator for x86 PC")
1980     (description
1981      "Bochs is an emulator which can emulate Intel x86 CPU, common I/O
1982 devices, and a custom BIOS.  It can also be compiled to emulate many different
1983 x86 CPUs, from early 386 to the most recent x86-64 Intel and AMD processors.
1984 Bochs can run most Operating Systems inside the emulation including Linux,
1985 DOS or Microsoft Windows.")
1986     (license license:lgpl2.0+)))
1987
1988 (define-public xen
1989   (package
1990     (name "xen")
1991     (version "4.14.1")               ; please update the mini-os input as well
1992     (source (origin
1993               (method git-fetch)
1994               (uri (git-reference
1995                     (url "https://xenbits.xen.org/git-http/xen.git")
1996                     (commit (string-append "RELEASE-" version))))
1997               (file-name (git-file-name name version))
1998               (sha256
1999                (base32
2000                 "1r90rvypw76ya9clqw5p02gm1k8hxz73f7gr95ca778nnzvb7xjw"))))
2001     (build-system gnu-build-system)
2002     (arguments
2003      `(#:configure-flags
2004        (list "--enable-rpath"
2005              "--disable-qemu-traditional" ; It tries to do "git clone"
2006              "--disable-rombios" ; would try to "git clone" via etherboot.
2007              ;; TODO: Re-enable stubdom (it's "more secure" to use it).
2008              "--disable-stubdom" ; tries to "git clone" old patched newlib.
2009              (string-append "--with-initddir="
2010                             (assoc-ref %outputs "out")
2011                             "/etc/init.d")
2012              (string-append "--with-system-qemu="
2013                             (assoc-ref %build-inputs "qemu")
2014                             "/bin/qemu-system-i386")
2015              (string-append "--with-system-seabios="
2016                             (assoc-ref %build-inputs "seabios")
2017                             "/share/firmware/bios.bin")
2018              (string-append "--with-system-ovmf="
2019                             (assoc-ref %build-inputs "ovmf")
2020                             "/share/firmware/ovmf_ia32.bin"))
2021        #:make-flags (list "-j" "1"
2022                           "XEN_BUILD_DATE=Thu Jan  1 01:00:01 CET 1970"
2023                           "XEN_BUILD_TIME=01:00:01"
2024                           "XEN_BUILD_HOST="
2025                           "ETHERBOOT_NICS="
2026                           "SMBIOS_REL_DATE=01/01/1970"
2027                           "VGABIOS_REL_DATE=01 Jan 1970"
2028                           ; QEMU_TRADITIONAL_LOC
2029                           ; QEMU_UPSTREAM_LOC
2030                           "SYSCONFIG_DIR=/tmp/etc/default"
2031                           (string-append "BASH_COMPLETION_DIR="
2032                                          (assoc-ref %outputs "out")
2033                                          "/etc/bash_completion.d")
2034                           (string-append "BOOT_DIR="
2035                                          (assoc-ref %outputs "out")
2036                                          "/boot")
2037                           (string-append "DEBUG_DIR="
2038                                          (assoc-ref %outputs "out")
2039                                          "/lib/debug")
2040                           (string-append "EFI_DIR="
2041                                          (assoc-ref %outputs "out")
2042                                          "/lib/efi") ; TODO lib64 ?
2043                           "MINIOS_UPSTREAM_URL="
2044                           ;(string-append "DISTDIR="
2045                           ;               (assoc-ref %outputs "out"))
2046 )
2047        #:test-target "test"
2048        #:phases
2049        (modify-phases %standard-phases
2050         (add-after 'unpack 'unpack-mini-os
2051           (lambda* (#:key inputs #:allow-other-keys)
2052             (copy-recursively (assoc-ref inputs "mini-os") "extras/mini-os")
2053             #t))
2054         (add-after 'unpack-mini-os 'patch
2055           (lambda* (#:key inputs outputs #:allow-other-keys)
2056             (substitute* "tools/firmware/Rules.mk"
2057              (("override XEN_TARGET_ARCH = x86_32")
2058               (string-append "override XEN_TARGET_ARCH = x86_32
2059 override CC = " (assoc-ref inputs "cross-gcc") "/bin/i686-linux-gnu-gcc"))
2060              (("^CFLAGS =$")
2061               (string-append "CFLAGS=-I" (assoc-ref inputs "cross-libc")
2062                              "/include\n")))
2063             (substitute* "config/x86_32.mk"
2064              (("CFLAGS += -m32 -march=i686")
2065               (string-append "CFLAGS += -march=i686 -I"
2066                              (assoc-ref inputs "cross-libc")
2067                              "/include")))
2068             ;; /var is not in /gnu/store , so don't try to create it.
2069             (substitute* '("tools/Makefile"
2070                            "tools/xenstore/Makefile"
2071                            "tools/xenpaging/Makefile")
2072              (("\\$\\(INSTALL_DIR\\) .*XEN_(DUMP|LOG|RUN|LIB|PAGING)_DIR.*")
2073               "\n")
2074              (("\\$\\(INSTALL_DIR\\) .*XEN_(RUN|LIB)_STORED.*")
2075               "\n"))
2076             ;; Prevent xen from creating /etc .
2077             (substitute* "tools/examples/Makefile"
2078              ((" install-readmes") "")
2079              ((" install-configs") ""))
2080             ;; Set rpath.
2081             (substitute* "tools/pygrub/setup.py"
2082              (("library_dirs =")
2083               ; TODO: extra_link_args = ['-Wl,-rpath=/opt/foo'],
2084               (string-append "runtime_library_dirs = ['"
2085                              (assoc-ref outputs "out")
2086                              "/lib'],\nlibrary_dirs =")))
2087             #t))
2088         (add-before 'configure 'patch-xen-script-directory
2089           (lambda* (#:key outputs #:allow-other-keys)
2090             (substitute* '("configure"
2091                            "tools/configure"
2092                            "docs/configure")
2093              (("XEN_SCRIPT_DIR=.*")
2094               (string-append "XEN_SCRIPT_DIR="
2095                              (assoc-ref outputs "out")
2096                              "/etc/xen/scripts")))
2097             #t))
2098         (add-before 'configure 'set-environment-up
2099           (lambda* (#:key make-flags #:allow-other-keys)
2100              (define (cross? x)
2101                (string-contains x "cross-i686-linux"))
2102              (define (filter-environment! filter-predicate
2103                                           environment-variable-names)
2104                (for-each
2105                 (lambda (env-name)
2106                   (let* ((env-value (getenv env-name))
2107                          (search-path (search-path-as-string->list env-value))
2108                          (new-search-path (filter filter-predicate
2109                                                   search-path))
2110                          (new-env-value (list->search-path-as-string
2111                                          new-search-path ":")))
2112                     (setenv env-name new-env-value)))
2113                 environment-variable-names))
2114              (setenv "CROSS_C_INCLUDE_PATH" (getenv "C_INCLUDE_PATH"))
2115              (setenv "CROSS_CPLUS_INCLUDE_PATH" (getenv "CPLUS_INCLUDE_PATH"))
2116              (setenv "CROSS_LIBRARY_PATH" (getenv "LIBRARY_PATH"))
2117              (filter-environment! cross?
2118               '("CROSS_C_INCLUDE_PATH" "CROSS_CPLUS_INCLUDE_PATH"
2119                 "CROSS_LIBRARY_PATH"))
2120              (filter-environment! (lambda (e) (not (cross? e)))
2121               '("C_INCLUDE_PATH" "CPLUS_INCLUDE_PATH"
2122                 "LIBRARY_PATH"))
2123              ;; Guix tries to be helpful and automatically adds
2124              ;; mini-os-git-checkout/include to the include path,
2125              ;; but actually we don't want it to be there (yet).
2126              (filter-environment! (lambda (e)
2127                                     (not
2128                                      (string-contains e
2129                                       "mini-os-git-checkout")))
2130               '("C_INCLUDE_PATH" "CPLUS_INCLUDE_PATH"
2131                 "LIBRARY_PATH"))
2132             (setenv "EFI_VENDOR" "guix")
2133              #t))
2134         (replace 'build
2135           (lambda* (#:key make-flags #:allow-other-keys)
2136             (apply invoke "make" "world" make-flags))))))
2137     (inputs
2138      `(("acpica" ,acpica) ; TODO: patch iasl invocation.
2139        ("bridge-utils" ,bridge-utils) ; TODO: patch invocations.
2140        ("glib" ,glib)
2141        ("iproute" ,iproute) ; TODO: patch invocations.
2142        ("libaio" ,libaio)
2143        ("libx11" ,libx11)
2144        ("libyajl" ,libyajl)
2145        ("ncurses" ,ncurses)
2146        ("openssl" ,openssl)
2147        ("ovmf" ,ovmf)
2148        ("pixman" ,pixman)
2149        ("qemu" ,qemu-minimal)
2150        ("seabios" ,seabios)
2151        ("util-linux" ,util-linux "lib") ; uuid
2152        ; TODO: ocaml-findlib, ocaml-nox.
2153        ("xz" ,xz) ; for liblzma
2154        ("zlib" ,zlib)))
2155     (native-inputs
2156      `(("dev86" ,dev86)
2157        ("bison" ,bison)
2158        ("cmake" ,cmake-minimal)
2159        ("figlet" ,figlet)
2160        ("flex" ,flex)
2161        ("gettext" ,gettext-minimal)
2162        ("libnl" ,libnl)
2163        ("mini-os"
2164        ,(origin
2165          (method git-fetch)
2166          (uri (git-reference
2167                (url "https://xenbits.xen.org/git-http/mini-os.git")
2168                ;; This corresponds to (string-append "xen-RELEASE-" version))
2169                ;; at time of packaging, but upstream has unfortunately modified
2170                ;; existing tags in the past.
2171                (commit "0b4b7897e08b967a09bed2028a79fabff82342dd")))
2172          (sha256
2173           (base32 "1i8pcl19n60i2m9vlg79q3nknpj209c9ic5x10wxaicx45kc107f"))
2174          (file-name "mini-os-git-checkout")))
2175        ("perl" ,perl)
2176        ; TODO: markdown
2177        ("pkg-config" ,pkg-config)
2178        ("python" ,python-2)
2179        ("wget" ,wget)
2180        ("cross-gcc" ,(cross-gcc "i686-linux-gnu"
2181                                 #:xbinutils (cross-binutils "i686-linux-gnu")
2182                                 #:libc (cross-libc "i686-linux-gnu")))
2183        ("cross-libc" ,(cross-libc "i686-linux-gnu")) ; header files
2184        ("cross-libc-static" ,(cross-libc "i686-linux-gnu") "static")))
2185     (home-page "https://xenproject.org/")
2186     (synopsis "Xen Virtual Machine Monitor")
2187     (description "This package provides the Xen Virtual Machine Monitor
2188 which is a hypervisor.")
2189     ;; TODO: Some files are licensed differently.  List those.
2190     (license license:gpl2)
2191     (supported-systems '("i686-linux" "x86_64-linux" "armhf-linux"))))
2192
2193 (define-public osinfo-db-tools
2194   (package
2195     (name "osinfo-db-tools")
2196     (version "1.9.0")
2197     (source (origin
2198               (method url-fetch)
2199               (uri (string-append "https://releases.pagure.org/libosinfo/osinfo-db-tools-"
2200                                   version ".tar.xz"))
2201
2202               (sha256
2203                (base32
2204                 "1h23a8nzdxjyvw44dwh903563n3b1z5skx8g0b1p1v5cif3iqpr5"))))
2205     (build-system meson-build-system)
2206     (inputs
2207      `(("libsoup" ,libsoup-minimal-2)
2208        ("libxml2" ,libxml2)
2209        ("libxslt" ,libxslt)
2210        ("json-glib" ,json-glib)
2211        ("libarchive" ,libarchive)))
2212     (native-inputs
2213      `(("perl" ,perl)
2214        ("gobject-introspection" ,gobject-introspection)
2215        ("gettext" ,gettext-minimal)
2216        ("pkg-config" ,pkg-config)
2217        ;; Tests
2218        ("python" ,python)
2219        ("pytest" ,python-pytest)
2220        ("requests" ,python-requests)))
2221     (home-page "https://gitlab.com/libosinfo/osinfo-db-tools")
2222     (synopsis "Tools for managing the osinfo database")
2223     (description "This package contains a set of tools to assist
2224 administrators and developers in managing the database.")
2225     (license license:lgpl2.0+)))
2226
2227 (define-public osinfo-db
2228   (package
2229     (name "osinfo-db")
2230     (version "20210903")
2231     (source (origin
2232               (method url-fetch)
2233               (uri (string-append "https://releases.pagure.org/libosinfo/osinfo-db-"
2234                                   version ".tar.xz"))
2235               (sha256
2236                (base32
2237                 "0d08ffvwdzwr16gv7pz2r7brds5gciirz8ixs97s5ly03grd7rrh"))))
2238     (build-system trivial-build-system)
2239     (arguments
2240      `(#:modules ((guix build utils))
2241        #:builder
2242        (begin
2243          (use-modules (guix build utils))
2244          (let* ((out (assoc-ref %outputs "out"))
2245                 (osinfo-dir (string-append out "/share/osinfo"))
2246                 (source (assoc-ref %build-inputs "source"))
2247                 (osinfo-db-import
2248                  (string-append (assoc-ref %build-inputs "osinfo-db-tools")
2249                                 "/bin/osinfo-db-import")))
2250            (mkdir-p osinfo-dir)
2251            (invoke osinfo-db-import "--dir" osinfo-dir source)))))
2252     (native-inputs
2253      `(("intltool" ,intltool)
2254        ("osinfo-db-tools" ,osinfo-db-tools)))
2255     (home-page "https://gitlab.com/libosinfo/osinfo-db")
2256     (synopsis "Database of information about operating systems")
2257     (description "Osinfo-db provides the database files for use with the
2258 libosinfo library.  It provides information about guest operating systems for
2259 use with virtualization provisioning tools")
2260     (license license:lgpl2.0+)))
2261
2262 (define-public python-transient
2263   (package
2264     (name "python-transient")
2265     (version "0.12")
2266     (source
2267      (origin
2268        (method url-fetch)
2269        (uri (pypi-uri "transient" version))
2270        (sha256
2271         (base32
2272          "148yiqrmcscsi6787y0f27i1y9cf0gcw3mqfv5frhpmsmv62mv5z"))))
2273     (build-system python-build-system)
2274     (arguments
2275      `(#:tests? #f ; Requires behave
2276        #:phases (modify-phases %standard-phases
2277                   (add-after 'unpack 'fix-dependencies
2278                     (lambda _
2279                       (substitute* "setup.py"
2280                         (("==")
2281                          ">="))
2282                       #t)))))
2283     (propagated-inputs
2284      `(("python-beautifultable" ,python-beautifultable)
2285        ("python-click" ,python-click)
2286        ("python-importlib-resources"
2287         ,python-importlib-resources)
2288        ("python-lark-parser" ,python-lark-parser)
2289        ("python-marshmallow" ,python-marshmallow)
2290        ("python-progressbar2" ,python-progressbar2)
2291        ("python-requests" ,python-requests)
2292        ("python-toml" ,python-toml)))
2293     (native-inputs
2294      `(("python-black" ,python-black)
2295        ("python-mypy" ,python-mypy)
2296        ("python-pyhamcrest" ,python-pyhamcrest)
2297        ("python-twine" ,python-twine)))
2298     (home-page
2299      "https://github.com/ALSchwalm/transient")
2300     (synopsis
2301      "QEMU Wrapper written in Python")
2302     (description
2303      "@code{transient} is a wrapper for QEMU allowing the creation of virtual
2304 machines with shared folder, ssh, and disk creation support.")
2305     (license license:expat)))