gnu/packages/virtualization.scm

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