aboutsummaryrefslogtreecommitdiff
path: root/gnu/packages/pv.scm
blob: 97b3dcdadce9b705f5bccbcd42938afb7433ee23 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Claes Wallin <claes.wallin@greatsinodevelopment.com>
;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu packages pv)
  #:use-module (guix licenses)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix build-system gnu))

(define-public pv
  (package
    (name "pv")
    (version "1.6.20")
    (source
     (origin
       (method url-fetch)
       (uri (string-append "https://www.ivarch.com/programs/sources/pv-"
                           version ".tar.bz2"))
       (sha256
        (base32 "00y6zla8h653sn4axgqz7rr0x79vfwl62a7gn6lzn607zwg9acg8"))))
    (build-system gnu-build-system)
    (home-page "https://www.ivarch.com/programs/pv.shtml")
    (synopsis "Pipeline progress indicator")
    (description
     "@acronym{pv, Pipe Viewer} is a terminal tool for monitoring the progress
of data through a pipeline.  It can be inserted into any normal pipeline
between two processes.  It gives a visual indication of how quickly data is
passing through, how much has been transferred and how near to completion it is
(with a progress bar), how long it has taken, and an estimate of the remaining
time before completion.")
    (license artistic2.0)))
(marionette-eval '(begin (chdir "/tmp") (system* #$(file-append libvirt "/bin/virsh") "-c" "qemu:///system" "net-start" "default")) marionette)) (test-end)))) (gexp->derivation "libvirt-test" test)) (define %test-libvirt (system-test (name "libvirt") (description "Connect to the running LIBVIRT service.") (value (run-libvirt-test)))) ;;; ;;; QEMU Guest Agent service. ;;; (define %qemu-guest-agent-os (simple-operating-system (service qemu-guest-agent-service-type))) (define (run-qemu-guest-agent-test) "Run tests in %QEMU-GUEST-AGENT-OS." (define os (marionette-operating-system %qemu-guest-agent-os #:imported-modules '((gnu services herd)))) (define vm (virtual-machine (operating-system os) (port-forwardings '()))) (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (gnu build marionette) (ice-9 rdelim) (srfi srfi-64)) (define marionette ;; Ensure we look for the socket in the correct place below. (make-marionette (list #$vm) #:socket-directory "/tmp")) (define* (try-read port #:optional (attempts 10)) ;; Try reading from a port several times before giving up. (cond ((char-ready? port) (let ((response (read-line port))) (close-port port) response)) ((> attempts 1) (sleep 1) (try-read port (- attempts 1))) (else ""))) (define (run command) ;; Run a QEMU guest agent command and return the response. (let ((s (socket PF_UNIX SOCK_STREAM 0))) (connect s AF_UNIX "/tmp/qemu-ga") (display command s) (try-read s))) (test-runner-current (system-test-runner #$output)) (test-begin "qemu-guest-agent") (test-assert "service running" (marionette-eval '(begin (use-modules (gnu services herd)) (match (start-service 'qemu-guest-agent) (#f #f) (('service response-parts ...) (match (assq-ref response-parts 'running) ((pid) (number? pid)))))) marionette)) (test-equal "ping guest" "{\"return\": {}}" (run "{\"execute\": \"guest-ping\"}")) (test-assert "get network interfaces" (string-contains (run "{\"execute\": \"guest-network-get-interfaces\"}") "127.0.0.1")) (test-end)))) (gexp->derivation "qemu-guest-agent-test" test)) (define %test-qemu-guest-agent (system-test (name "qemu-guest-agent") (description "Run commands in a virtual machine using QEMU guest agent.") (value (run-qemu-guest-agent-test)))) ;;; ;;; GNU/Hurd virtual machines, aka. childhurds. ;;; (define %childhurd-os (simple-operating-system (service dhcp-client-service-type) (service hurd-vm-service-type (hurd-vm-configuration (os (operating-system (inherit %hurd-vm-operating-system) (users (cons (user-account (name "test") (group "users") (password "")) ;empty password %base-user-accounts)))))))) (define* (run-command-over-ssh command #:key (port 10022) (user "test")) "Return a program that runs COMMAND over SSH and prints the result on standard output." (define run (with-extensions (list guile-ssh) #~(begin (use-modules (ssh session) (ssh auth) (ssh popen) (ice-9 match) (ice-9 textual-ports)) (let ((session (make-session #:user #$user #:port #$port #:host "localhost" #:timeout 120 #:log-verbosity 'rare))) (match (connect! session) ('ok (userauth-password! session "") (display (get-string-all (open-remote-input-pipe* session #$@command)))) (status (error "could not connect to guest over SSH" session status))))))) (program-file "run-command-over-ssh" run)) (define (run-childhurd-test) (define (import-module? module) ;; This module is optional and depends on Guile-Gcrypt, do skip it. (and (guix-module-name? module) (not (equal? module '(guix store deduplication))))) (define os (marionette-operating-system %childhurd-os #:imported-modules (source-module-closure '((gnu services herd) (guix combinators) (gnu build install)) #:select? import-module?))) (define vm (virtual-machine (operating-system os) (memory-size (* 1024 3)))) (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (gnu build marionette) (srfi srfi-64) (ice-9 match)) (define marionette ;; Emulate as much as the host CPU supports so that, possibly, KVM ;; is available inside as well ("nested KVM"), provided ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it. (make-marionette (list #$vm "-cpu" "max"))) (test-runner-current (system-test-runner #$output)) (test-begin "childhurd") (test-assert "service running" (marionette-eval '(begin (use-modules (gnu services herd) (ice-9 match)) (match (start-service 'childhurd) (#f #f) (('service response-parts ...) (match (assq-ref response-parts 'running) ((pid) (number? pid)))))) marionette)) (test-equal "childhurd SSH server replies" "SSH" ;; Check from within the guest whether its childhurd's SSH ;; server is reachable. Do that from the guest: port forwarding ;; to the host won't work because QEMU listens on 127.0.0.1. (marionette-eval '(begin (use-modules (ice-9 match) (ice-9 textual-ports)) (let loop ((n 60)) (if (zero? n) 'all-attempts-failed (let ((s (socket PF_INET SOCK_STREAM 0)) (a (make-socket-address AF_INET INADDR_LOOPBACK 10022))) (format #t "connecting to childhurd SSH server...~%") (connect s a) (match (get-string-n s 3) ((? eof-object?) (close-port s) (sleep 1) (loop (- n 1))) (str (close-port s) str)))))) marionette)) (test-equal "SSH up and running" "childhurd GNU\n" ;; Connect from the guest to the chidhurd over SSH and run the ;; 'uname' command. (marionette-eval '(begin (use-modules (ice-9 popen) (ice-9 textual-ports)) (get-string-all (open-input-pipe #$(run-command-over-ssh '("uname" "-on"))))) marionette)) (test-assert "guix-daemon up and running" (let ((drv (marionette-eval '(begin (use-modules (ice-9 popen) (ice-9 textual-ports)) (get-string-all (open-input-pipe #$(run-command-over-ssh '("guix" "build" "coreutils" "--no-grafts" "-d"))))) marionette))) ;; We cannot compare the .drv with (raw-derivation-file ;; coreutils) on the host: they may differ due to fixed-output ;; derivations and changes introduced compared to the 'guix' ;; package snapshot. (and (string-suffix? ".drv" (pk 'drv (string-trim-right drv))) drv))) (test-assert "copy-on-write store" ;; Set up a writable store. The root partition is already an ;; overlayfs, which is not suitable as the bottom part of this ;; additional overlayfs; thus, create a tmpfs for the backing ;; store. ;; TODO: Remove this when <virtual-machine> creates a writable ;; store. (marionette-eval '(begin (use-modules (gnu build install) (guix build syscalls)) (mkdir "/run/writable-store") (mount "none" "/run/writable-store" "tmpfs") (mount-cow-store "/run/writable-store" "/backing-store") (system* "df" "-hT")) marionette)) (test-equal "offloading" 0 (marionette-eval '(and (file-exists? "/etc/guix/machines.scm") (system* "guix" "offload" "test")) marionette)) (test-end)))) (gexp->derivation "childhurd-test" test)) (define %test-childhurd (system-test (name "childhurd") (description "Connect to the GNU/Hurd virtual machine service, aka. a childhurd, making sure that the childhurd boots and runs its SSH server.") (value (run-childhurd-test)))) ;;; ;;; Virtual build machine. ;;; (define %build-vm-os (simple-operating-system (service virtual-build-machine-service-type (virtual-build-machine (cpu-count 1) (memory-size (* 1 1024)))))) (define (run-build-vm-test) (define (import-module? module) ;; This module is optional and depends on Guile-Gcrypt, do skip it. (and (guix-module-name? module) (not (equal? module '(guix store deduplication))))) (define os (marionette-operating-system %build-vm-os #:imported-modules (source-module-closure '((gnu services herd) (gnu build install)) #:select? import-module?))) (define vm (virtual-machine (operating-system os) (memory-size (* 1024 3)))) (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (gnu build marionette) (srfi srfi-64) (ice-9 match)) (define marionette ;; Emulate as much as the host CPU supports so that, possibly, KVM ;; is available inside as well ("nested KVM"), provided ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it. (make-marionette (list #$vm "-cpu" "max"))) (test-runner-current (system-test-runner #$output)) (test-begin "build-vm") (test-assert "service running" (marionette-eval '(begin (use-modules (gnu services herd) (ice-9 match)) (start-service 'build-vm)) marionette)) (test-assert "guest SSH up and running" ;; Note: Pass #:peek? #t because due to the way QEMU port ;; forwarding works, connecting to 11022 always works even if the ;; 'sshd' service hasn't been started yet in the guest. (wait-for-tcp-port 11022 marionette #:peek? #t)) (test-assert "copy-on-write store" ;; Set up a writable store. The root partition is already an ;; overlayfs, which is not suitable as the bottom part of this ;; additional overlayfs; thus, create a tmpfs for the backing ;; store. ;; TODO: Remove this when <virtual-machine> creates a writable ;; store. (marionette-eval '(begin (use-modules (gnu build install) (guix build syscalls)) (mkdir "/run/writable-store") (mount "none" "/run/writable-store" "tmpfs") (mount-cow-store "/run/writable-store" "/backing-store") (system* "df" "-hT")) marionette)) (test-equal "offloading" 0 (marionette-eval '(and (file-exists? "/etc/guix/machines.scm") (system* "guix" "offload" "test")) marionette)) (test-end)))) (gexp->derivation "build-vm-test" test)) (define %test-build-vm (system-test (name "build-vm") (description "Offload to a virtual build machine over SSH.") (value (run-build-vm-test))))