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