;;; guix-ui-package.el --- Interface for displaying packages -*- lexical-binding: t -*- ;; Copyright © 2014, 2015, 2016 Alex Kost ;; 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 this program. If not, see . ;;; Commentary: ;; This file provides an interface for displaying packages and outputs ;; in 'list' and 'info' buffers, and commands for working with them. ;;; Code:
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
;;; Copyright © 2017, 2020 Marius Bakke <marius@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 tests networking)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services networking)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages networking)
  #:use-module (gnu packages guile)
  #:use-module (gnu services shepherd)
  #:use-module (ice-9 match)
  #:export (%test-static-networking
            %test-static-networking-advanced
            %test-inetd
            %test-openvswitch
            %test-dhcpd
            %test-tor
            %test-iptables
            %test-ipfs))


;;;
;;; Static networking.
;;;

(define (run-static-networking-test vm)
  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build syscalls))
      #~(begin
          (use-modules (gnu build marionette)
                       (guix build syscalls)
                       (srfi srfi-64))

          (define marionette
            (make-marionette
             '(#$vm "-nic" "user,model=virtio-net-pci")))

          (test-runner-current (system-test-runner #$output))
          (test-begin "static-networking")

          (test-assert "service is up"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'networking))
             marionette))

          (test-assert "network interfaces"
            (marionette-eval
             '(begin
                (use-modules (guix build syscalls))
                (network-interface-names))
             marionette))

          (test-equal "address of eth0"
            "10.0.2.15"
            (marionette-eval
             '(let* ((sock (socket AF_INET SOCK_STREAM 0))
                     (addr (network-interface-address sock "eth0")))
                (close-port sock)
                (inet-ntop (sockaddr:fam addr) (sockaddr:addr addr)))
             marionette))

          (test-equal "netmask of eth0"
            "255.255.255.0"
            (marionette-eval
             '(let* ((sock (socket AF_INET SOCK_STREAM 0))
                     (mask (network-interface-netmask sock "eth0")))
                (close-port sock)
                (inet-ntop (sockaddr:fam mask) (sockaddr:addr mask)))
             marionette))

          (test-equal "eth0 is up"
            IFF_UP
            (marionette-eval
             '(let* ((sock  (socket AF_INET SOCK_STREAM 0))
                     (flags (network-interface-flags sock "eth0")))
                (logand flags IFF_UP))
             marionette))

          (test-end))))

  (gexp->derivation "static-networking" test))

(define %test-static-networking
  (system-test
   (name "static-networking")
   (description "Test the 'static-networking' service.")
   (value
    (let ((os (marionette-operating-system
               (simple-operating-system
                (service static-networking-service-type
                         (list %qemu-static-networking)))
               #:imported-modules '((gnu services herd)
                                    (guix combinators)))))
      (run-static-networking-test (virtual-machine os))))))

(define (run-static-networking-advanced-test vm)
  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build syscalls))
      #~(begin
          (use-modules (gnu build marionette)
                       (guix build syscalls)
                       (srfi srfi-64))

          (define marionette
            (make-marionette
             '(#$vm "-net" "nic,model=e1000,macaddr=98:11:22:33:44:55"
                    "-net" "nic,model=e1000,macaddr=98:11:22:33:44:56")))

          (test-runner-current (system-test-runner #$output))
          (test-begin "static-networking-advanced")

          (test-assert "service is up"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'networking))
             marionette))

          (test-assert "network interfaces"
            (marionette-eval
             '(begin
                (use-modules (guix build syscalls))
                (network-interface-names))
             marionette))

          (test-equal "bond0 bonding mode"
            "802.3ad 4"
            (marionette-eval
             '(begin
                (use-modules (ice-9 rdelim))
                (call-with-input-file "/sys/class/net/bond0/bonding/mode" read-line))
             marionette))

          (test-equal "bond0 bonding lacp_rate"
            "fast 1"
            (marionette-eval
             '(begin
                (use-modules (ice-9 rdelim))
                (call-with-input-file "/sys/class/net/bond0/bonding/lacp_rate" read-line))
             marionette))

          (test-equal "bond0 bonding miimon"
            "100"
            (marionette-eval
             '(begin
                (use-modules (ice-9 rdelim))
                (call-with-input-file "/sys/class/net/bond0/bonding/miimon" read-line))
             marionette))

          (test-equal "bond0 bonding slaves"
            "a b"
            (marionette-eval
             '(begin
                (use-modules (ice-9 rdelim))
                (call-with-input-file "/sys/class/net/bond0/bonding/slaves" read-line))
             marionette))

          ;; The hw mac address will come from the first slave bonded to the
          ;; channel.
          (test-equal "bond0 mac address"
            "98:11:22:33:44:55"
            (marionette-eval
             '(begin
                (use-modules (ice-9 rdelim))
                (call-with-input-file "/sys/class/net/bond0/address" read-line))
             marionette))

          (test-equal "bond0.1055 is up"
            IFF_UP
            (marionette-eval
             '(let* ((sock  (socket AF_INET SOCK_STREAM 0))
                     (flags (network-interface-flags sock "bond0.1055")))
                (logand flags IFF_UP))
             marionette))

          (test-equal "bond0.1055 address is correct"
            "192.168.1.4"
            (marionette-eval
             '(let* ((sock (socket AF_INET SOCK_STREAM 0))
                     (addr (network-interface-address sock "bond0.1055")))
                (close-port sock)
                (inet-ntop (sockaddr:fam addr) (sockaddr:addr addr)))
             marionette))

          (test-equal "bond0.1055 netmask is correct"
            "255.255.255.0"
            (marionette-eval
             '(let* ((sock (socket AF_INET SOCK_STREAM 0))
                     (mask (network-interface-netmask sock "bond0.1055")))
                (close-port sock)
                (inet-ntop (sockaddr:fam mask) (sockaddr:addr mask)))
             marionette))
          (test-end))))

  (gexp->derivation "static-networking-advanced" test))

(define %test-static-networking-advanced
  (system-test
   (name "static-networking-advanced")
   (description "Test the 'static-networking' service with advanced features like bonds, vlans etc...")
   (value
    (let ((os (marionette-operating-system
               (simple-operating-system
                (service static-networking-service-type
                         (list (static-networking
                                (links (list

                                        (network-link
                                         (mac-address "98:11:22:33:44:55")
                                         (arguments '((name . "a"))))

                                        (network-link
                                         (mac-address "98:11:22:33:44:56")
                                         (arguments '((name . "b"))))

                                        (network-link
                                         (name "bond0")
                                         (type 'bond)
                                         (arguments '((mode . "802.3ad")
                                                      (miimon . 100)
                                                      (lacp-active . "on")
                                                      (lacp-rate . "fast"))))

                                        (network-link
                                         (name "a")
                                         (arguments '((master . "bond0"))))

                                        (network-link
                                         (name "b")
                                         (arguments '((master . "bond0"))))

                                        (network-link
                                         (name "bond0.1055")
                                         (type 'vlan)
                                         (arguments '((id . 1055)
                                                      (link . "bond0"))))))

                                (addresses (list (network-address
                                                  (value "192.168.1.4/24")
                                                  (device "bond0.1055"))))))))
               #:imported-modules '((gnu services herd)
                                    (guix combinators)))))
      (run-static-networking-advanced-test (virtual-machine os))))))


;;;
;;; Inetd.
;;;

(define %inetd-os
  ;; Operating system with 2 inetd services.
  (simple-operating-system
   (service dhcp-client-service-type)
   (service inetd-service-type
            (inetd-configuration
             (entries (list
                       (inetd-entry
                        (name "echo")
                        (socket-type 'stream)
                        (protocol "tcp")
                        (wait? #f)
                        (user "root"))
                       (inetd-entry
                        (name "dict")
                        (socket-type 'stream)
                        (protocol "tcp")
                        (wait? #f)
                        (user "root")
                        (program (file-append bash
                                              "/bin/bash"))
                        (arguments
                         (list "bash" (plain-file "my-dict.sh" "\
while read line
do
    if [[ $line =~ ^DEFINE\\ (.*)$ ]]
    then
        case ${BASH_REMATCH[1]} in
            Guix)
                echo GNU Guix is a package management tool for the GNU system.
                ;;
            G-expression)
                echo Like an S-expression but with a G.
                ;;
            *)
                echo NO DEFINITION FOUND
                ;;
        esac
    else
        echo ERROR
    fi
done" ))))))))))

(define* (run-inetd-test)
  "Run tests in %INETD-OS, where the inetd service provides an echo service on
port 7, and a dict service on port 2628."
  (define os
    (marionette-operating-system %inetd-os))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((8007 . 7)
                         (8628 . 2628)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (ice-9 rdelim)
                       (srfi srfi-64)
                       (gnu build marionette))
          (define marionette
            (make-marionette (list #$vm)))

          (test-runner-current (system-test-runner #$output))
          (test-begin "inetd")

          ;; Make sure the PID file is created.
          (test-assert "PID file"
            (wait-for-file "/var/run/inetd.pid" marionette
                           #:timeout 30))

          ;; Test the echo service.
          (test-equal "echo response"
            "Hello, Guix!"
            (let ((echo (socket PF_INET SOCK_STREAM 0))
                  (addr (make-socket-address AF_INET INADDR_LOOPBACK 8007)))
              (connect echo addr)
              (display "Hello, Guix!\n" echo)
              (let ((response (read-line echo)))
                (close echo)
                response)))

          ;; Test the dict service
          (test-equal "dict response"
            "GNU Guix is a package management tool for the GNU system."
            (let ((dict (socket PF_INET SOCK_STREAM 0))
                  (addr (make-socket-address AF_INET INADDR_LOOPBACK 8628)))
              (connect dict addr)
              (display "DEFINE Guix\n" dict)
              (let ((response (read-line dict)))
                (close dict)
                response)))

          (test-end))))

  (gexp->derivation "inetd-test" test))

(define %test-inetd
  (system-test
   (name "inetd")
   (description "Connect to a host with an INETD server.")
   (value (run-inetd-test))))


;;;
;;; Open vSwitch
;;;

(define setup-openvswitch
  #~(let ((ovs-vsctl (lambda (str)
                       (zero? (apply system*
                                     #$(file-append openvswitch "/bin/ovs-vsctl")
                                     (string-tokenize str)))))
          (add-native-port (lambda (if)
                             (string-append "--may-exist add-port br0 " if
                                            " vlan_mode=native-untagged"
                                            " -- set Interface " if
                                            " type=internal"))))
      (and (ovs-vsctl "--may-exist add-br br0")
           ;; Connect eth0 as an "untagged" port (no VLANs).
           (ovs-vsctl "--may-exist add-port br0 eth0 vlan_mode=native-untagged")
           (ovs-vsctl (add-native-port "ovs0")))))

(define openvswitch-configuration-service
  (simple-service 'openvswitch-configuration shepherd-root-service-type
                  (list (shepherd-service
                         (provision '(openvswitch-configuration))
                         (requirement '(vswitchd))
                         (start #~(lambda ()
                                    #$setup-openvswitch))
                         (respawn? #f)))))

(define %openvswitch-os
  (operating-system
    (inherit (simple-operating-system
              (simple-service 'openswitch-networking
                              static-networking-service-type
                              (list (static-networking
                                     (addresses (list (network-address
                                                       (value "10.1.1.1/24")
                                                       (device "ovs0"))))
                                     (requirement '(openvswitch-configuration)))))
              (service openvswitch-service-type)
              openvswitch-configuration-service))
    ;; Ensure the interface name does not change depending on the driver.
    (kernel-arguments (cons "net.ifnames=0" %default-kernel-arguments))))

(define (run-openvswitch-test)
  (define os
    (marionette-operating-system %openvswitch-os
                                 #:imported-modules '((gnu services herd)
                                                      (guix build syscalls))))

  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build syscalls))
      #~(begin
          (use-modules (gnu build marionette)
                       (guix build syscalls)
                       (ice-9 popen)
                       (ice-9 rdelim)
                       (srfi srfi-64))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (test-runner-current (system-test-runner #$output))
          (test-begin "openvswitch")

          ;; Wait for our configuration to be active (it sets up br0).
          (test-assert "openvswitch-configuration is running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (wait-for-service 'openvswitch-configuration))
             marionette))

          ;; Make sure the bridge is created.
          (test-assert "br0 exists"
            (marionette-eval
             '(zero? (system* #$(file-append openvswitch "/bin/ovs-vsctl")
                              "br-exists" "br0"))
             marionette))

          ;; Make sure eth0 is connected to the bridge.
          (test-equal "eth0 is connected to br0"
            "br0"
            (marionette-eval
             '(begin
                (use-modules (ice-9 popen) (ice-9 rdelim))
                (let* ((port (open-pipe*
                              OPEN_READ
                              (string-append #$openvswitch "/bin/ovs-vsctl")
                              "port-to-br" "eth0"))
                       (output (read-line port)))
                  (close-pipe port)
                  output))
             marionette))

          ;; Make sure the virtual interface got a static IP.
          (test-assert "networking has started on ovs0"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd)
                             (srfi srfi-1))
                (live-service-running
                 (find (lambda (live)
                         (memq 'networking
                               (live-service-provision live)))
                       (current-services))))
             marionette))

          (test-equal "ovs0 is up"
            IFF_UP
            (marionette-eval
             '(begin
                (use-modules (guix build syscalls))

                (let* ((sock  (socket AF_INET SOCK_STREAM 0))
                       (flags (network-interface-flags sock "ovs0")))
                  (close-port sock)
                  (logand flags IFF_UP)))
             marionette))

          (test-end))))

  (gexp->derivation "openvswitch-test" test))

(define %test-openvswitch
  (system-test
   (name "openvswitch")
   (description "Test a running OpenvSwitch configuration.")
   (value (run-openvswitch-test))))


;;;
;;; DHCP Daemon
;;;

(define minimal-dhcpd-v4-config-file
  (plain-file "dhcpd.conf"
              "\
default-lease-time 600;
max-lease-time 7200;

subnet 192.168.1.0 netmask 255.255.255.0 {
 range 192.168.1.100 192.168.1.200;
 option routers 192.168.1.1;
 option domain-name-servers 192.168.1.2, 192.168.1.3;
 option domain-name \"dummy.domain.name.abc123xyz\";
}
"))

(define dhcpd-v4-configuration
  (dhcpd-configuration
   (config-file minimal-dhcpd-v4-config-file)
   (version "4")
   (interfaces '("ens3"))))

(define %dhcpd-os
  (simple-operating-system
   (service static-networking-service-type
            (list (static-networking
                   (addresses (list (network-address
                                     (value "192.168.1.4/24")
                                     (device "ens3"))))
                   (routes (list (network-route
                                  (destination "default")
                                  (gateway "192.168.1.1"))))
                   (name-servers '("192.168.1.2" "192.168.1.3")))))
   (service dhcpd-service-type dhcpd-v4-configuration)))

(define (run-dhcpd-test)
  (define os
    (marionette-operating-system %dhcpd-os
                                 #:imported-modules '((gnu services herd))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (test-runner-current (system-test-runner #$output))
          (test-begin "dhcpd")

          (test-assert "pid file exists"
            (wait-for-file
             '#$(dhcpd-configuration-pid-file dhcpd-v4-configuration)
             marionette))

          (test-assert "lease file exists"
            (wait-for-file
             '#$(dhcpd-configuration-lease-file dhcpd-v4-configuration)
             marionette
             #:read '(@ (ice-9 textual-ports) get-string-all)))

          (test-assert "run directory exists"
            (marionette-eval
             '(file-exists?
               #$(dhcpd-configuration-run-directory dhcpd-v4-configuration))
             marionette))

          (test-assert "dhcpd is alive"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (wait-for-service 'dhcpv4-daemon))
             marionette))

          (test-end))))

  (gexp->derivation "dhcpd-test" test))

(define %test-dhcpd
  (system-test
   (name "dhcpd")
   (description "Test a running DHCP daemon configuration.")
   (value (run-dhcpd-test))))


;;;
;;; Services related to Tor
;;;

(define %tor-os
  (simple-operating-system
   (service tor-service-type)))

(define %tor-os/unix-socks-socket
  (simple-operating-system
   (service tor-service-type
            (tor-configuration
             (socks-socket-type 'unix)))))

(define (run-tor-test)
  (define os
    (marionette-operating-system %tor-os
                                 #:imported-modules '((gnu services herd))
                                 #:requirements '(tor)))

  (define os/unix-socks-socket
    (marionette-operating-system %tor-os/unix-socks-socket
                                 #:imported-modules '((gnu services herd))
                                 #:requirements '(tor)))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (ice-9 popen)
                       (ice-9 rdelim)
                       (srfi srfi-64))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (define (tor-is-alive? marionette)
            (marionette-eval
             '(begin
                (use-modules (gnu services herd)
                             (srfi srfi-1))
                (live-service-running
                 (find (lambda (live)
                         (memq 'tor
                               (live-service-provision live)))
                       (current-services))))
             marionette))

          (test-runner-current (system-test-runner #$output))
          (test-begin "tor")

          ;; Test the usual Tor service.

          (test-assert "tor is alive"
            (tor-is-alive? marionette))

          (test-assert "tor is listening"
            (let ((default-port 9050))
              (wait-for-tcp-port default-port marionette)))

          ;; Don't run two VMs at once.
          (marionette-control "quit" marionette)

          ;; Test the Tor service using a SOCKS socket.

          (let* ((socket-directory "/tmp/more-sockets")
                 (_ (mkdir socket-directory))
                 (marionette/unix-socks-socket
                  (make-marionette
                   (list #$(virtual-machine os/unix-socks-socket))
                   ;; We can't use the same socket directory as the first
                   ;; marionette.
                   #:socket-directory socket-directory)))
            (test-assert "tor is alive, even when using a SOCKS socket"
              (tor-is-alive? marionette/unix-socks-socket))

            (test-assert "tor is listening, even when using a SOCKS socket"
              (wait-for-unix-socket "/var/run/tor/socks-sock"
                                    marionette/unix-socks-socket)))

          (test-end))))

  (gexp->derivation "tor-test" test))

(define %test-tor
  (system-test
   (name "tor")
   (description "Test a running Tor daemon configuration.")
   (value (run-tor-test))))

(define* (run-iptables-test)
  "Run tests of 'iptables-service-type'."
  (define iptables-rules
    "*filter
:INPUT ACCEPT
:FORWARD ACCEPT
:OUTPUT ACCEPT
-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp-port-unreachable
COMMIT
")

  (define ip6tables-rules
    "*filter
:INPUT ACCEPT
:FORWARD ACCEPT
:OUTPUT ACCEPT
-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp6-port-unreachable
COMMIT
")

  (define inetd-echo-port 7)

  (define os
    (marionette-operating-system
     (simple-operating-system
      (service dhcp-client-service-type)
      (service inetd-service-type
               (inetd-configuration
                (entries (list
                          (inetd-entry
                           (name "echo")
                           (socket-type 'stream)
                           (protocol "tcp")
                           (wait? #f)
                           (user "root"))))))
      (service iptables-service-type
               (iptables-configuration
                (ipv4-rules (plain-file "iptables.rules" iptables-rules))
                (ipv6-rules (plain-file "ip6tables.rules" ip6tables-rules)))))
     #:imported-modules '((gnu services herd))
     #:requirements '(inetd iptables)))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-64)
                       (gnu build marionette))
          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (define (dump-iptables iptables-save marionette)
            (marionette-eval
             `(begin
                (use-modules (ice-9 popen)
                             (ice-9 rdelim)
                             (ice-9 regex))
                (call-with-output-string
                  (lambda (out)
                    (call-with-port
                     (open-pipe* OPEN_READ ,iptables-save)
                     (lambda (in)
                       (let loop ((line (read-line in)))
                         ;; iptables-save does not output rules in the exact
                         ;; same format we loaded using iptables-restore. It
                         ;; adds comments, packet counters, etc. We remove
                         ;; these additions.
                         (unless (eof-object? line)
                           (cond
                            ;; Remove comments
                            ((string-match "^#" line) #t)
                            ;; Remove packet counters
                            ((string-match "^:([A-Z]*) ([A-Z]*) .*" line)
                             => (lambda (match-record)
                                  (format out ":~a ~a~%"
                                          (match:substring match-record 1)
                                          (match:substring match-record 2))))
                            ;; Pass other lines without modification
                            (else (display line out)
                                  (newline out)))
                           (loop (read-line in)))))))))
             marionette))

          (test-runner-current (system-test-runner #$output))
          (test-begin "iptables")

          (test-equal "iptables-save dumps the same rules that were loaded"
            (dump-iptables #$(file-append iptables "/sbin/iptables-save")
                           marionette)
            #$iptables-rules)

          (test-equal "ip6tables-save dumps the same rules that were loaded"
            (dump-iptables #$(file-append iptables "/sbin/ip6tables-save")
                           marionette)
            #$ip6tables-rules)

          (test-error "iptables firewall blocks access to inetd echo service"
                      'misc-error
                      (wait-for-tcp-port inetd-echo-port marionette #:timeout 5))

          ;; TODO: This test freezes up at the login prompt without any
          ;; relevant messages on the console. Perhaps it is waiting for some
          ;; timeout. Find and fix this issue.
          ;; (test-assert "inetd echo service is accessible after iptables firewall is stopped"
          ;;   (begin
          ;;     (marionette-eval
          ;;      '(begin
          ;;         (use-modules (gnu services herd))
          ;;         (stop-service 'iptables))
          ;;      marionette)
          ;;     (wait-for-tcp-port inetd-echo-port marionette #:timeout 5)))

          (test-end))))

  (gexp->derivation "iptables" test))

(define %test-iptables
  (system-test
   (name "iptables")
   (description "Test a running iptables daemon.")
   (value (run-iptables-test))))


;;;
;;; IPFS service
;;;

(define %ipfs-os
  (simple-operating-system
   (service ipfs-service-type)))

(define (run-ipfs-test)
  (define os
    (marionette-operating-system %ipfs-os
                                 #:imported-modules (source-module-closure
                                                     '((gnu services herd)
                                                       (guix ipfs)))
                                 #:extensions (list guile-json-4)
                                 #:requirements '(ipfs)))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (rnrs bytevectors)
                       (srfi srfi-64)
                       (ice-9 binary-ports))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (define (ipfs-is-alive?)
            (marionette-eval
             '(begin
                (use-modules (gnu services herd)
                             (srfi srfi-1))
                (live-service-running
                 (find (lambda (live)
                         (memq 'ipfs
                               (live-service-provision live)))
                       (current-services))))
             marionette))

          ;; The default API endpoint port 5001 is used,
          ;; so there is no need to parameterize %ipfs-base-url.
          (define (add-data data)
            (marionette-eval `(content-name (add-data ,data)) marionette))
          (define (read-contents object)
            (marionette-eval
             `(let* ((input (read-contents ,object))
                     (all-input (get-bytevector-all input)))
                (close-port input)
                all-input)
             marionette))

          (marionette-eval '(use-modules (guix ipfs)) marionette)
          (test-runner-current (system-test-runner #$output))
          (test-begin "ipfs")

          ;; Test the IPFS service.

          (test-assert "ipfs is alive" (ipfs-is-alive?))

          (test-assert "ipfs is listening on the gateway"
            (let ((default-port 8082))
              (wait-for-tcp-port default-port marionette)))

          (test-assert "ipfs is listening on the API endpoint"
            (let ((default-port 5001))
              (wait-for-tcp-port default-port marionette)))

          (define test-bv (string->utf8 "hello ipfs!"))
          (test-equal "can upload and download a file to/from ipfs"
            test-bv
            (read-contents (add-data test-bv)))

          (test-end))))
  (gexp->derivation "ipfs-test" test))

(define %test-ipfs
  (system-test
   (name "ipfs")
   (description "Test a running IPFS daemon configuration.")
   (value (run-ipfs-test))))
generated by cgit
)) (apply #'guix-hydra-latest-builds number args)) ;;; Output 'info' (guix-ui-info-define-interface output :buffer-name "*Guix Package Info*" :format '((name format (format guix-package-info-name)) (version format guix-output-info-insert-version) (output format guix-output-info-insert-output) (synopsis simple (indent guix-package-info-synopsis)) guix-package-info-insert-misc (source simple guix-package-info-insert-source) (path simple (indent guix-file)) (dependencies simple (indent guix-file)) (location simple guix-package-info-insert-location) (home-url format (format guix-url)) (license format (format guix-package-license)) (systems format guix-package-info-insert-systems) (inputs format (format guix-package-input)) (native-inputs format (format guix-package-native-input)) (propagated-inputs format (format guix-package-propagated-input)) (description simple (indent guix-package-info-description))) :titles guix-package-info-titles :required '(id package-id installed non-unique)) (defun guix-output-info-insert-version (version entry) "Insert output VERSION and obsolete text if needed at point." (guix-info-insert-value-format version 'guix-package-info-version) (and (guix-entry-value entry 'obsolete) (guix-package-info-insert-obsolete-text))) (defun guix-output-info-insert-output (output entry) "Insert OUTPUT and action buttons at point." (let* ((installed (guix-entry-value entry 'installed)) (obsolete (guix-entry-value entry 'obsolete)) (action-type (if installed 'delete 'install))) (guix-info-insert-value-format output (if installed 'guix-package-info-installed-outputs 'guix-package-info-uninstalled-outputs)) (guix-info-insert-indent) (guix-package-info-insert-action-button action-type entry output) (when obsolete (guix-info-insert-indent) (guix-package-info-insert-action-button 'upgrade entry output)))) ;;; Output 'list' (guix-ui-list-define-interface output :buffer-name "*Guix Package List*" :describe-function 'guix-output-list-describe :format '((name guix-package-list-get-name 20 t) (version nil 10 nil) (output nil 9 t) (installed nil 12 t) (synopsis guix-list-get-one-line 30 nil)) :required '(id package-id) :sort-key '(name) :marks '((install . ?I) (upgrade . ?U) (delete . ?D))) (let ((map guix-output-list-mode-map)) (define-key map (kbd "B") 'guix-package-list-latest-builds) (define-key map (kbd "e") 'guix-output-list-edit) (define-key map (kbd "x") 'guix-output-list-execute) (define-key map (kbd "i") 'guix-output-list-mark-install) (define-key map (kbd "d") 'guix-output-list-mark-delete) (define-key map (kbd "U") 'guix-output-list-mark-upgrade) (define-key map (kbd "^") 'guix-output-list-mark-upgrades)) (defun guix-output-list-mark-install () "Mark the current output for installation and move to the next line." (interactive) (guix-package-list-marking-check) (let* ((entry (guix-list-current-entry)) (installed (guix-entry-value entry 'installed))) (if installed (user-error "This output is already installed") (guix-list--mark 'install t)))) (defun guix-output-list-mark-delete () "Mark the current output for deletion and move to the next line." (interactive) (guix-package-list-marking-check) (let* ((entry (guix-list-current-entry)) (installed (guix-entry-value entry 'installed))) (if installed (guix-list--mark 'delete t) (user-error "This output is not installed")))) (defun guix-output-list-mark-upgrade () "Mark the current output for upgrading and move to the next line." (interactive) (guix-package-list-marking-check) (let* ((entry (guix-list-current-entry)) (installed (guix-entry-value entry 'installed))) (or installed (user-error "This output is not installed")) (when (or (guix-entry-value entry 'obsolete) (y-or-n-p "This output is not obsolete. Try to upgrade it anyway? ")) (guix-list--mark 'upgrade t)))) (defun guix-output-list-mark-upgrades () "Mark all obsolete package outputs for upgrading." (interactive) (guix-package-mark-upgrades (lambda (_) (guix-list--mark 'upgrade)))) (defun guix-output-list-execute () "Perform actions on the marked outputs." (interactive) (guix-package-execute-actions #'guix-output-list-make-action)) (defun guix-output-list-make-action (action-type) "Return action specification for the outputs marked with ACTION-TYPE. Return nil, if there are no outputs marked with ACTION-TYPE. The specification is suitable for `guix-process-output-actions'." (let ((ids (guix-list-get-marked-id-list action-type))) (and ids (cons action-type (mapcar #'guix-package-id-and-output-by-output-id ids))))) (defun guix-output-list-describe (ids) "Describe outputs with IDS (list of output identifiers). See `guix-package-info-type'." (if (eq guix-package-info-type 'output) (guix-buffer-get-display-entries 'info 'output (cl-list* (guix-ui-current-profile) 'id ids) 'add) (let ((pids (mapcar (lambda (oid) (car (guix-package-id-and-output-by-output-id oid))) ids))) (guix-buffer-get-display-entries 'info 'package (cl-list* (guix-ui-current-profile) 'id (cl-remove-duplicates pids)) 'add)))) (defun guix-output-list-edit (&optional directory) "Go to the location of the current package. See `guix-find-location' for the meaning of DIRECTORY." (interactive (list (guix-read-directory))) (guix-edit (guix-entry-value (guix-list-current-entry) 'package-id) directory)) ;;; Interactive commands (defvar guix-package-search-params '(name synopsis description) "Default list of package parameters for searching by regexp.") (defvar guix-package-search-history nil "A history of minibuffer prompts.") ;;;###autoload (defun guix-packages-by-name (name &optional profile) "Display Guix packages with NAME. NAME is a string with name specification. It may optionally contain a version number. Examples: \"guile\", \"guile@2.0.11\". If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (guix-read-package-name) (guix-ui-read-profile))) (guix-package-get-display profile 'name name)) ;;;###autoload (defun guix-packages-by-license (license &optional profile) "Display Guix packages with LICENSE. LICENSE is a license name string. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (guix-read-license-name) (guix-ui-read-profile))) (guix-package-get-display profile 'license license)) ;;;###autoload (defun guix-packages-by-location (location &optional profile) "Display Guix packages placed in LOCATION file. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (guix-read-package-location) (guix-ui-read-profile))) (guix-package-get-display profile 'location location)) ;;;###autoload (defun guix-package-from-file (file &optional profile) "Display Guix package that the code from FILE evaluates to. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (read-file-name "File with package: ") (guix-ui-read-profile))) (guix-buffer-get-display-entries 'info 'package (list (or profile guix-current-profile) 'from-file file) 'add)) ;;;###autoload (defun guix-search-by-regexp (regexp &optional params profile) "Search for Guix packages by REGEXP. PARAMS are package parameters that should be searched. If PARAMS are not specified, use `guix-package-search-params'. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (read-regexp "Regexp: " nil 'guix-package-search-history) nil (guix-ui-read-profile))) (guix-package-get-display profile 'regexp regexp (or params guix-package-search-params))) ;;;###autoload (defun guix-search-by-name (regexp &optional profile) "Search for Guix packages matching REGEXP in a package name. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (read-string "Package name by regexp: " nil 'guix-package-search-history) (guix-ui-read-profile))) (guix-search-by-regexp regexp '(name) profile)) ;;;###autoload (defun guix-installed-packages (&optional profile) "Display information about installed Guix packages. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (guix-ui-read-profile))) (guix-package-get-display profile 'installed)) ;;;###autoload (defun guix-installed-user-packages () "Display information about Guix packages installed in a user profile." (interactive) (guix-installed-packages guix-user-profile)) ;;;###autoload (defun guix-installed-system-packages () "Display information about Guix packages installed in a system profile." (interactive) (guix-installed-packages (guix-packages-profile guix-system-profile nil t))) ;;;###autoload (defun guix-obsolete-packages (&optional profile) "Display information about obsolete Guix packages. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (guix-ui-read-profile))) (guix-package-get-display profile 'obsolete)) ;;;###autoload (defun guix-all-available-packages (&optional profile) "Display information about all available Guix packages. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (guix-ui-read-profile))) (guix-package-get-display profile 'all-available)) ;;;###autoload (defun guix-newest-available-packages (&optional profile) "Display information about the newest available Guix packages. If PROFILE is nil, use `guix-current-profile'. Interactively with prefix, prompt for PROFILE." (interactive (list (guix-ui-read-profile))) (guix-package-get-display profile 'newest-available)) (provide 'guix-ui-package) ;;; guix-ui-package.el ends here