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