code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2020 Simon South <simon@simonsouth.net>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 (test-syscalls)
  #:use-module (guix utils)
  #:use-module (guix build syscalls)
  #:use-module (gnu build linux-container)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (system foreign)
  #:use-module ((ice-9 ftw) #:select (scandir))
  #:use-module (ice-9 match))

;; Test the (guix build syscalls) module, although there's not much that can
;; actually be tested without being root.

(define temp-file
  (string-append "t-utils-" (number->string (getpid))))

(test-begin "syscalls")

(test-equal "mount, ENOENT"
  ENOENT
  (catch 'system-error
    (lambda ()
      (mount "/dev/null" "/does-not-exist" "ext2")
      #f)
    (compose system-error-errno list)))

(test-assert "umount, ENOENT/EPERM"
  (catch 'system-error
    (lambda ()
      (umount "/does-not-exist")
      #f)
    (lambda args
      ;; Both return values have been encountered in the wild.
      (memv (system-error-errno args) (list EPERM ENOENT)))))

(test-assert "mounts"
  ;; Check for one of the common mount points.
  (let ((mounts (mounts)))
    (any (match-lambda
           ((point . type)
            (let ((mount (find (lambda (mount)
                                 (string=? (mount-point mount) point))
                               mounts)))
              (and mount
                   (string=? (mount-type mount) type)))))
         '(("/proc"    . "proc")
           ("/sys"     . "sysfs")
           ("/dev/shm" . "tmpfs")))))

(test-assert "mount-points"
  ;; Reportedly "/" is not always listed as a mount point, so check a few
  ;; others (see <http://bugs.gnu.org/20261>.)
  (any (cute member <> (mount-points))
       '("/" "/proc" "/sys" "/dev")))

(false-if-exception (delete-file temp-file))
(test-equal "utime with AT_SYMLINK_NOFOLLOW"
  '(0 0)
  (begin
    ;; Test libguile's utime with AT_SYMLINK_NOFOLLOW, which libguile does not
    ;; define as of Guile 2.2.4.
    (symlink "/nowhere" temp-file)
    (utime temp-file 0 0 0 0 AT_SYMLINK_NOFOLLOW)
    (let ((st (lstat temp-file)))
      (delete-file temp-file)
      ;; Note: 'utimensat' does not change 'ctime'.
      (list (stat:mtime st) (stat:atime st)))))

(test-assert "swapon, ENOSYS/ENOENT/EPERM"
  (catch 'system-error
    (lambda ()
      (swapon "/does-not-exist")
      #f)
    (lambda args
      (memv (system-error-errno args) (list EPERM ENOENT ENOSYS)))))

(test-assert "swapoff, ENOSYS/ENOENT/EINVAL/EPERM"
  (catch 'system-error
    (lambda ()
      (swapoff "/does-not-exist")
      #f)
    (lambda args
      (memv (system-error-errno args) (list EPERM EINVAL ENOENT ENOSYS)))))

(test-assert "mkdtemp!"
  (let* ((tmp (or (getenv "TMPDIR") "/tmp"))
         (dir (mkdtemp! (string-append tmp "/guix-test-XXXXXX"))))
    (and (file-exists? dir)
         (begin
           (rmdir dir)
           #t))))

(test-equal "statfs, ENOENT"
  ENOENT
  (catch 'system-error
    (lambda ()
      (statfs "/does-not-exist"))
    (compose system-error-errno list)))

(test-assert "statfs"
  (let ((fs (statfs "/")))
    (and (file-system? fs)
         (> (file-system-block-size fs) 0)
         (>= (file-system-blocks-available fs) 0)
         (>= (file-system-blocks-free fs)
             (file-system-blocks-available fs)))))

(define (user-namespace pid)
  (string-append "/proc/" (number->string pid) "/ns/user"))

(define perform-container-tests?
  (and (user-namespace-supported?)
       (unprivileged-user-namespace-supported?)))

(unless perform-container-tests?
  (test-skip 1))
(test-assert "clone"
  (match (clone (logior CLONE_NEWUSER SIGCHLD))
    (0 (primitive-exit 42))
    (pid
     ;; Check if user namespaces are different.
     (and (not (equal? (readlink (user-namespace pid))
                       (readlink (user-namespace (getpid)))))
          (match (waitpid pid)
            ((_ . status)
             (= 42 (status:exit-val status))))))))

(unless perform-container-tests?
  (test-skip 1))
(test-assert "setns"
  (match (clone (logior CLONE_NEWUSER SIGCHLD))
    (0 (primitive-exit 0))
    (clone-pid
     (match (pipe)
       ((in . out)
        (match (primitive-fork)
          (0
           (close in)
           ;; Join the user namespace.
           (call-with-input-file (user-namespace clone-pid)
             (lambda (port)
               (setns (port->fdes port) 0)))
           (write 'done out)
           (close out)
           (primitive-exit 0))
          (fork-pid
           (close out)
           ;; Wait for the child process to join the namespace.
           (read in)
           (let ((result (and (equal? (readlink (user-namespace clone-pid))
                                      (readlink (user-namespace fork-pid))))))
             ;; Clean up.
             (waitpid clone-pid)
             (waitpid fork-pid)
             result))))))))

(when (not perform-container-tests?)
  (test-skip 1))
(test-equal "pivot-root"
  'success!
  (match (socketpair AF_UNIX SOCK_STREAM 0)
    ((parent . child)
     (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD))
       (0
        (dynamic-wind
          (const #t)
          (lambda ()
            (close parent)
            (call-with-temporary-directory
             (lambda (root)
               (display "ready\n" child)
               (read child)                       ;wait for "go!"
               (let ((put-old (string-append root "/real-root")))
                 (mount "none" root "tmpfs")
                 (mkdir put-old)
                 (call-with-output-file (string-append root "/test")
                   (lambda (port)
                     (display "testing\n" port)))
                 (pivot-root root put-old)
                 ;; The test file should now be located inside the root directory.
                 (write (and (file-exists? "/test") 'success!) child)
                 (close child)))))
          (lambda ()
            (primitive-exit 0))))
       (pid
        (close child)
        (match (read parent)
          ('ready
           ;; Set up the UID/GID mapping so that we can mkdir on the tmpfs:
           ;; <https://bugzilla.kernel.org/show_bug.cgi?id=183461>.
           (call-with-output-file (format #f "/proc/~d/setgroups" pid)
             (lambda (port)
               (display "deny" port)))
           (call-with-output-file (format #f "/proc/~d/uid_map" pid)
             (lambda (port)
               (format port "0 ~d 1" (getuid))))
           (call-with-output-file (format #f "/proc/~d/gid_map" pid)
             (lambda (port)
               (format port "0 ~d 1" (getgid))))
           (display "go!\n" parent)
           (let ((result (read parent)))
             (close parent)
             (and (zero? (match (waitpid pid)
                           ((_ . status)
                            (status:exit-val status))))
                  result)))))))))

(test-equal "scandir*, ENOENT"
  ENOENT
  (catch 'system-error
    (lambda ()
      (scandir* "/does/not/exist"))
    (lambda args
      (system-error-errno args))))

(test-equal "scandir*, ASCII file names"
  (scandir (dirname (search-path %load-path "guix/base32.scm"))
           (const #t) string<?)
  (match (scandir* (dirname (search-path %load-path "guix/base32.scm")))
    (((names . properties) ...)
     names)))

(test-equal "scandir*, UTF-8 file names"
  '("." ".." "α" "λ")
  (call-with-temporary-directory
   (lambda (directory)
     ;; Wrap 'creat' to make sure that we really pass a UTF-8-encoded file
     ;; name to the system call.
     (let ((creat (pointer->procedure int
                                      (dynamic-func "creat" (dynamic-link))
                                      (list '* int))))
       (creat (string->pointer (string-append directory "/α")
                               "UTF-8")
              #o644)
       (creat (string->pointer (string-append directory "/λ")
                               "UTF-8")
              #o644)
       (let ((locale (setlocale LC_ALL)))
         (dynamic-wind
           (lambda ()
             ;; Make sure that even in a C locale we get the right result.
             (setlocale LC_ALL "C"))
           (lambda ()
             (match (scandir* directory)
               (((names . properties) ...)
                names)))
           (lambda ()
             (setlocale LC_ALL locale))))))))

(test-assert "scandir*, properties"
  (let ((directory (dirname (search-path %load-path "guix/base32.scm"))))
    (every (lambda (entry name)
             (match entry
               ((name2 . properties)
                (and (string=? name2 name)
                     (let* ((full  (string-append directory "/" name))
                            (stat  (lstat full))
                            (inode (assoc-ref properties 'inode))
                            (type  (assoc-ref properties 'type)))
                       (and (= inode (stat:ino stat))
                            (or (eq? type 'unknown)
                                (eq? type (stat:type stat)))))))))
           (scandir* directory)
           (scandir directory (const #t) string<?))))

(false-if-exception (delete-file temp-file))
(test-assert "getxattr, setxattr"
  (let ((key "user.translator")
        (value "/hurd/pfinet\0")
        (file (open-file temp-file "w0")))
    (catch 'system-error
      (lambda ()
        (setxattr temp-file key value)
        (string=? (getxattr temp-file key) value))
      (lambda args
        ;; Accept ENOTSUP, if the file-system does not support extended user
        ;; attributes.
        (memv (system-error-errno args) (list ENOTSUP))))))

(false-if-exception (delete-file temp-file))
(test-equal "fcntl-flock wait"
  42                                              ; the child's exit status
  (let ((file (open-file temp-file "w0b")))
    ;; Acquire an exclusive lock.
    (fcntl-flock file 'write-lock)
    (match (primitive-fork)
      (0
       (dynamic-wind
         (const #t)
         (lambda ()
           ;; Reopen FILE read-only so we can have a read lock.
           (let ((file (open-file temp-file "r0b")))
             ;; Wait until we can acquire the lock.
             (fcntl-flock file 'read-lock)
             (primitive-exit (read file)))
           (primitive-exit 1))
         (lambda ()
           (primitive-exit 2))))
      (pid
       ;; Write garbage and wait.
       (display "hello, world!"  file)
       (force-output file)
       (sleep 1)

       ;; Write the real answer.
       (seek file 0 SEEK_SET)
       (truncate-file file 0)
       (write 42 file)
       (force-output file)

       ;; Unlock, which should let the child continue.
       (fcntl-flock file 'unlock)

       (match (waitpid pid)
         ((_  . status)
          (let ((result (status:exit-val status)))
            (close-port file)
            result)))))))

(test-equal "fcntl-flock non-blocking"
  EAGAIN                                          ; the child's exit status
  (match (pipe)
    ((input . output)
     (match (primitive-fork)
       (0
        (dynamic-wind
          (const #t)
          (lambda ()
            (close-port output)

            ;; Wait for the green light.
            (read-char input)

            ;; Open FILE read-only so we can have a read lock.
            (let ((file (open-file temp-file "w0")))
              (catch 'flock-error
                (lambda ()
                  ;; This attempt should throw EAGAIN.
                  (fcntl-flock file 'write-lock #:wait? #f))
                (lambda (key errno)
                  (primitive-exit (pk 'errno errno)))))
            (primitive-exit -1))
          (lambda ()
            (primitive-exit -2))))
       (pid
        (close-port input)
        (let ((file (open-file temp-file "w0")))
          ;; Acquire an exclusive lock.
          (fcntl-flock file 'write-lock)

          ;; Tell the child to continue.
          (write 'green-light output)
          (force-output output)

          (match (waitpid pid)
            ((_  . status)
             (let ((result (status:exit-val status)))
               (fcntl-flock file 'unlock)
               (close-port file)
               result)))))))))

(test-equal "set-thread-name"
  "Syscall Test"
  (let ((name (thread-name)))
    (set-thread-name "Syscall Test")
    (let ((new-name (thread-name)))
      (set-thread-name name)
      new-name)))

(test-assert "all-network-interface-names"
  (match (all-network-interface-names)
    (((? string? names) ..1)
     (member "lo" names))))

(test-assert "network-interface-names"
  (match (remove (lambda (interface)
                   ;; Ignore interface aliases since they don't show up in
                   ;; (all-network-interface-names).
                   (string-contains interface ":"))
                 (network-interface-names))
    (((? string? names) ..1)
     (lset<= string=? names (all-network-interface-names)))))

(test-assert "network-interface-flags"
  (let* ((sock  (socket AF_INET SOCK_STREAM 0))
         (flags (network-interface-flags sock "lo")))
    (close-port sock)
    (and (not (zero? (logand flags IFF_LOOPBACK)))
         (not (zero? (logand flags IFF_UP))))))

(test-equal "loopback-network-interface?"
  ENODEV
  (and (loopback-network-interface? "lo")
       (catch 'system-error
         (lambda ()
           (loopback-network-interface? "nonexistent")
           #f)
         (lambda args
           (system-error-errno args)))))

(test-equal "loopback-network-interface-running?"
  ENODEV
  (and (network-interface-running? "lo")
       (catch 'system-error
         (lambda ()
           (network-interface-running? "nonexistent")
           #f)
         (lambda args
           (system-error-errno args)))))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "set-network-interface-flags"
  (let ((sock (socket AF_INET SOCK_STREAM 0)))
    (catch 'system-error
      (lambda ()
        (set-network-interface-flags sock "lo" IFF_UP))
      (lambda args
        (close-port sock)
        ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "network-interface-address lo"
  (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0)
  (let* ((sock (socket AF_INET SOCK_STREAM 0))
         (addr (network-interface-address sock "lo")))
    (close-port sock)
    addr))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "set-network-interface-address"
  (let ((sock (socket AF_INET SOCK_STREAM 0)))
    (catch 'system-error
      (lambda ()
        (set-network-interface-address sock "nonexistent"
                                       (make-socket-address
                                        AF_INET
                                        (inet-pton AF_INET "127.12.14.15")
                                        0)))
      (lambda args
        (close-port sock)
        ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "network-interface-netmask lo"
  (make-socket-address AF_INET (inet-pton AF_INET "255.0.0.0") 0)
  (let* ((sock (socket AF_INET SOCK_STREAM 0))
         (addr (network-interface-netmask sock "lo")))
    (close-port sock)
    addr))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "set-network-interface-netmask"
  (let ((sock (socket AF_INET SOCK_STREAM 0)))
    (catch 'system-error
      (lambda ()
        (set-network-interface-netmask sock "nonexistent"
                                       (make-socket-address
                                        AF_INET
                                        (inet-pton AF_INET "255.0.0.0")
                                        0)))
      (lambda args
        (close-port sock)
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "network-interfaces returns one or more interfaces"
  '(#t #t #t)
  (match (network-interfaces)
    ((interfaces ..1)
     (list (every interface? interfaces)
           (every string? (map interface-name interfaces))
           (every (lambda (sockaddr)
                    ;; Sometimes interfaces have no associated address.
                    (or (vector? sockaddr)
                        (not sockaddr)))
                  (map interface-address interfaces))))))

(test-equal "network-interfaces returns \"lo\""
  (list #t (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0))
  (match (filter (lambda (interface)
                   (string=? "lo" (interface-name interface)))
                 (network-interfaces))
    ((loopbacks ..1)
     (list (every (lambda (lo)
                    (not (zero? (logand IFF_LOOPBACK (interface-flags lo)))))
                  loopbacks)
           (match (find (lambda (lo)
                          (= AF_INET (sockaddr:fam (interface-address lo))))
                        loopbacks)
             (#f #f)
             (lo (interface-address lo)))))))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "add-network-route/gateway"
  (let ((sock    (socket AF_INET SOCK_STREAM 0))
        (gateway (make-socket-address AF_INET
                                      (inet-pton AF_INET "192.168.0.1")
                                      0)))
    (catch 'system-error
      (lambda ()
        (add-network-route/gateway sock gateway))
      (lambda args
        (close-port sock)
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "delete-network-route"
  (let ((sock        (socket AF_INET SOCK_STREAM 0))
        (destination (make-socket-address AF_INET INADDR_ANY 0)))
    (catch 'system-error
      (lambda ()
        (delete-network-route sock destination))
      (lambda args
        (close-port sock)
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "tcgetattr ENOTTY"
  ENOTTY
  (catch 'system-error
    (lambda ()
      (call-with-input-file "/dev/null"
        (lambda (port)
          (tcgetattr (fileno port)))))
    (compose system-error-errno list)))

(test-skip (if (and (file-exists? "/proc/self/fd/0")
                    (string-prefix? "/dev/pts/" (readlink "/proc/self/fd/0")))
               0
               2))

(test-assert "tcgetattr"
  (let ((termios (tcgetattr 0)))
    (and (termios? termios)
         (> (termios-input-speed termios) 0)
         (> (termios-output-speed termios) 0))))

(test-assert "tcsetattr"
  (let ((first (tcgetattr 0)))
    (tcsetattr 0 (tcsetattr-action TCSANOW) first)
    (equal? first (tcgetattr 0))))

(test-assert "terminal-window-size ENOTTY"
  (call-with-input-file "/dev/null"
    (lambda (port)
      (catch 'system-error
        (lambda ()
          (terminal-window-size port))
        (lambda args
          ;; Accept EINVAL, which some old Linux versions might return.
          (memv (system-error-errno args)
                (list ENOTTY EINVAL)))))))

(test-assert "terminal-columns"
  (> (terminal-columns) 0))

(test-assert "terminal-columns non-file port"
  (> (terminal-columns (open-input-string "Join us now, share the software!"))
     0))

(test-assert "terminal-rows"
  (> (terminal-rows) 0))

(test-assert "utmpx-entries"
  (match (utmpx-entries)
    (((? utmpx? entries) ...)
     (every (lambda (entry)
              (match (utmpx-user entry)
                ((? string?)
                 ;; Ensure we have a valid PID for those entries where it
                 ;; makes sense.
                 (or (not (memv (utmpx-login-type entry)
                                (list (login-type INIT_PROCESS)
                                      (login-type LOGIN_PROCESS)
                                      (login-type USER_PROCESS))))
                     (> (utmpx-pid entry) 0)))
                (#f                               ;might be DEAD_PROCESS
                 #t)))
            entries))))

(test-assert "read-utmpx, EOF"
  (eof-object? (read-utmpx (%make-void-port "r"))))

(unless (access? "/var/run/utmpx" O_RDONLY)
  (test-skip 1))
(test-assert "read-utmpx"
  (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx)))
    (or (utmpx? result) (eof-object? result))))

(when (zero? (getuid))
  (test-skip 1))
(test-equal "add-to-entropy-count"
  EPERM
  (call-with-output-file "/dev/urandom"
    (lambda (port)
      (catch 'system-error
        (lambda ()
          (add-to-entropy-count port 77)
          #f)
        (lambda args
          (system-error-errno args))))))

(test-end)

(false-if-exception (delete-file temp-file))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 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 (test-system)
  #:use-module (gnu)
  #:use-module ((gnu services) #:select (service-value))
  #:use-module (guix store)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64))

;; Test the (gnu system) module.

(define %root-fs
  (file-system
    (device (file-system-label "my-root"))
    (mount-point "/")
    (type "ext4")))

(define %os
  (operating-system
    (host-name "komputilo")
    (timezone "Europe/Berlin")
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/sdX")))
    (file-systems (cons %root-fs %base-file-systems))

    (users %base-user-accounts)))

(define %luks-device
  (mapped-device
   (source "/dev/foo") (target "my-luks-device")
   (type luks-device-mapping)))

(define %os-with-mapped-device
  (operating-system
    (host-name "komputilo")
    (timezone "Europe/Berlin")
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/sdX")))
    (mapped-devices (list %luks-device))
    (file-systems (cons (file-system
                          (inherit %root-fs)
                          (dependencies (list %luks-device)))
                        %base-file-systems))
    (users %base-user-accounts)))

(test-begin "system")

(test-assert "operating-system-store-file-system"
  ;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this
  ;; shouldn't be a problem.
  (eq? %root-fs
       (operating-system-store-file-system %os)))

(test-assert "operating-system-store-file-system, prefix"
  (let* ((gnu (file-system
                (device "foobar")
                (mount-point (dirname (%store-prefix)))
                (type "ext5")))
         (os  (operating-system
                (inherit %os)
                (file-systems (cons* gnu %root-fs
                                     %base-file-systems)))))
    (eq? gnu (operating-system-store-file-system os))))

(test-assert "operating-system-store-file-system, store"
  (let* ((gnu (file-system
                (device "foobar")
                (mount-point (%store-prefix))
                (type "ext5")))
         (os  (operating-system
                (inherit %os)
                (file-systems (cons* gnu %root-fs
                                     %base-file-systems)))))
    (eq? gnu (operating-system-store-file-system os))))

(test-equal "operating-system-user-mapped-devices"
  '()
  (operating-system-user-mapped-devices %os-with-mapped-device))

(test-equal "operating-system-boot-mapped-devices"
  (list %luks-device)
  (operating-system-boot-mapped-devices %os-with-mapped-device))

(test-equal "operating-system-boot-mapped-devices, implicit dependency"
  (list %luks-device)

  ;; Here we expect the implicit dependency between "/" and
  ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
  ;; 'dependencies' field in the root file system.
  (operating-system-boot-mapped-devices
   (operating-system
     (inherit %os-with-mapped-device)
     (file-systems (cons (file-system
                           (device "/dev/mapper/my-luks-device")
                           (mount-point "/")
                           (type "ext4"))
                         %base-file-systems)))))

(test-equal "non-boot-file-system-service"
  '()

  ;; Make sure that mapped devices with at least one needed-for-boot user are
  ;; handled exclusively from the initrd.  See <https://bugs.gnu.org/31889>.
  (append-map file-system-dependencies
              (service-value
               ((@@ (gnu system) non-boot-file-system-service)
                (operating-system
                  (inherit %os-with-mapped-device)
                  (file-systems
                   (list (file-system
                           (mount-point "/foo/bar")
                           (device "qux:baz")
                           (type "none")
                           (dependencies (list %luks-device)))
                         (file-system
                           (device (file-system-label "my-root"))
                           (mount-point "/")
                           (type "ext4")
                           (dependencies (list %luks-device))))))))))

(test-end)

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 (test-texlive)
  #:use-module (gnu packages tex)
  #:use-module (guix import texlive)
  #:use-module (guix tests)
  #:use-module (guix tests http)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (srfi srfi-26)
  #:use-module (web client)
  #:use-module (ice-9 match))

(test-begin "texlive")

(define xml
  "\
<entry id=\"foo\">
   <name>foo</name>

Foomatic frobnication in LuaLaTeX

   <authorref id=\"rekado\"/>
   <license type=\"lppl1.3\"/>
   <version number=\"2.6a\"/>
   <description>

          Foo is a package for LuaLaTeX. It provides an interface to frobnicate gimbals
          in a foomatic way with the LuaTeX engine.

          The package requires the bar and golly
          bundles for extremely special specialties.

   </description>
   <ctan path=\"/macros/latex/contrib/foo\" file=\"true\"/>
   <texlive location=\"foo\"/>
   <keyval key=\"topic\" value=\"tests\"/>
  null
</entry>")

(define sxml
  '(*TOP* (entry (@ (id "foo"))
                 (name "foo")
                 (caption "Foomatic frobnication in LuaLaTeX")
                 (authorref (@ (id "rekado")))
                 (license (@ (type "lppl1.3")))
                 (version (@ (number "2.6a")))
                 (description
                  (p "\n          Foo is a package for LuaLaTeX. It provides an interface to frobnicate gimbals\n          in a foomatic way with the LuaTeX engine.\n     ")
                  (p "\n          The package requires the bar and golly\n          bundles for extremely special specialties.\n     "))
                 (ctan (@ (path "/macros/latex/contrib/foo") (file "true")))
                 (texlive (@ (location "foo")))
                 (keyval (@ (value "tests") (key "topic")))
                 "\n  null\n")))

(test-equal "fetch-sxml: returns SXML for valid XML"
  sxml
  (with-http-server `((200 ,xml))
    (parameterize ((current-http-proxy (%local-url)))
      (fetch-sxml "foo"))))

;; TODO:
(test-assert "sxml->package"
  ;; Replace network resources with sample data.
  (mock ((guix build svn) svn-fetch
         (lambda* (url revision directory
                       #:key (svn-command "svn")
                       (user-name #f)
                       (password #f))
           (mkdir-p directory)
           (with-output-to-file (string-append directory "/foo")
             (lambda ()
               (display "source")))))
        (let ((result (sxml->package sxml)))
          (match result
            (('package
               ('name "texlive-latex-foo")
               ('version "2.6a")
               ('source ('origin
                          ('method 'svn-fetch)
                          ('uri ('texlive-ref "latex" "foo"))
                          ('sha256
                           ('base32
                            (? string? hash)))))
               ('build-system 'texlive-build-system)
               ('arguments ('quote (#:tex-directory "latex/foo")))
               ('home-page "http://www.ctan.org/pkg/foo")
               ('synopsis "Foomatic frobnication in LuaLaTeX")
               ('description
                "Foo is a package for LuaLaTeX.  It provides an interface to \
frobnicate gimbals in a foomatic way with the LuaTeX engine.  The package \
requires the bar and golly bundles for extremely special specialties.")
               ('license 'lppl1.3+))
             #t)
            (_
             (begin
               (format #t "~s\n" result)
               (pk 'fail result #f)))))))

(test-end "texlive")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2019, 2020, 2021 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 (test-transformations)
  #:use-module (guix tests)
  #:use-module (guix store)
  #:use-module ((guix gexp) #:select (lower-object))
  #:use-module ((guix profiles)
                #:select (package->manifest-entry
                          manifest-entry-properties))
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix git-download)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix transformations)
  #:use-module ((guix gexp) #:select (local-file? local-file-file))
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix git)
  #:use-module (guix upstream)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages busybox)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

(test-begin "transformations")

(test-assert "options->transformation, no transformations"
  (let ((p (dummy-package "foo"))
        (t (options->transformation '())))
    (eq? (t p) p)))

(test-assert "options->transformation, with-source"
  ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
  ;; be applicable.
  (let* ((p (dummy-package "guix.scm"))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (with-store store
      (let* ((new (t p))
             (source (run-with-store store
                       (lower-object (package-source new)))))
        (and (not (eq? new p))
             (string=? source
                       (add-to-store store "guix.scm" #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-source, replacement"
  ;; Same, but this time the original package has a 'replacement' field.  We
  ;; expect that replacement to be set to #f in the new package.
  (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (not (package-replacement new))))))

(test-assert "options->transformation, with-source, with version"
  ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
  ;; should be applicable, and its version should be extracted.
  (let ((p (dummy-package "foo"))
        (s (search-path %load-path "guix.scm")))
    (call-with-temporary-directory
     (lambda (directory)
       (let* ((f (string-append directory "/foo-42.0.tar.gz"))
              (t (options->transformation `((with-source . ,f)))))
         (copy-file s f)
         (with-store store
           (let* ((new (t p))
                  (source (run-with-store store
                            (lower-object (package-source new)))))
             (and (not (eq? new p))
                  (string=? (package-name new) (package-name p))
                  (string=? (package-version new) "42.0")
                  (string=? source
                            (add-to-store store (basename f) #t
                                          "sha256" f))))))))))

(test-assert "options->transformation, with-source, no matches"
  ;; When a transformation in not applicable, a warning must be raised.
  (let* ((p (dummy-package "foobar"))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (let* ((port (open-output-string))
           (new  (parameterize ((guix-warning-port port))
                   (t p))))
      (and (eq? new p)
           (string-contains (get-output-string port)
                            "had no effect")))))

(test-assert "options->transformation, with-source, PKG=URI"
  (let* ((p (dummy-package "foo"))
         (s (search-path %load-path "guix.scm"))
         (f (string-append "foo=" s))
         (t (options->transformation `((with-source . ,f)))))
    (with-store store
      (let* ((new (t p))
             (source (run-with-store store
                       (lower-object (package-source new)))))
        (and (not (eq? new p))
             (string=? (package-name new) (package-name p))
             (string=? (package-version new)
                       (package-version p))
             (string=? source
                       (add-to-store store (basename s) #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-source, PKG@VER=URI"
  (let* ((p (dummy-package "foo"))
         (s (search-path %load-path "guix.scm"))
         (f (string-append "foo@42.0=" s))
         (t (options->transformation `((with-source . ,f)))))
    (with-store store
      (let* ((new (t p))
             (source (run-with-store store
                       (lower-object (package-source new)))))
        (and (not (eq? new p))
             (string=? (package-name new) (package-name p))
             (string=? (package-version new) "42.0")
             (string=? source
                       (add-to-store store (basename s) #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-input"
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,(specification->package "coreutils"))
                        ("bar" ,(specification->package "grep"))
                        ("baz" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation '((with-input . "coreutils=busybox")
                                       (with-input . "grep=findutils")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2) ("baz" dep3))
              (and (string=? (package-full-name dep1)
                             (package-full-name busybox))
                   (string=? (package-full-name dep2)
                             (package-full-name findutils))
                   (string=? (package-name dep3) "chbouib")
                   (match (package-native-inputs dep3)
                     ((("x" dep))
                      (string=? (package-full-name dep)
                                (package-full-name findutils)))))))))))

(test-assert "options->transformation, with-graft"
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation '((with-graft . "grep=findutils")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-full-name dep1)
                             (package-full-name grep))
                   (string=? (package-full-name (package-replacement dep1))
                             (package-full-name findutils))
                   (string=? (package-name dep2) "chbouib")
                   (match (package-native-inputs dep2)
                     ((("x" dep))
                      (with-store store
                        (string=? (derivation-file-name
                                   (package-derivation store findutils))
                                  (derivation-file-name
                                   (package-derivation store dep)))))))))))))

(test-equal "options->transformation, with-branch"
  (git-checkout (url "https://example.org")
                (branch "devel")
                (recursive? #t))
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (source (origin
                                            (method git-fetch)
                                            (uri (git-reference
                                                  (url "https://example.org")
                                                  (commit "cabba9e")))
                                            (sha256 #f)))))))))
         (t (options->transformation '((with-branch . "chbouib=devel")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-full-name dep1)
                             (package-full-name grep))
                   (string=? (package-name dep2) "chbouib")
                   (package-source dep2))))))))

(test-equal "options->transformation, with-commit"
  (git-checkout (url "https://example.org")
                (commit "abcdef")
                (recursive? #t))
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (source (origin
                                            (method git-fetch)
                                            (uri (git-reference
                                                  (url "https://example.org")
                                                  (commit "cabba9e")))
                                            (sha256 #f)))))))))
         (t (options->transformation '((with-commit . "chbouib=abcdef")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-full-name dep1)
                             (package-full-name grep))
                   (string=? (package-name dep2) "chbouib")
                   (package-source dep2))))))))

(test-equal "options->transformation, with-git-url"
  (let ((source (git-checkout (url "https://example.org")
                              (recursive? #t))))
    (list source source))
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation '((with-git-url . "grep=https://example.org")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-full-name dep1)
                             (package-full-name grep))
                   (string=? (package-name dep2) "chbouib")
                   (match (package-native-inputs dep2)
                     ((("x" dep3))
                      (map package-source (list dep1 dep3)))))))))))

(test-equal "options->transformation, with-git-url + with-branch"
  ;; Combine the two options and make sure the 'with-branch' transformation
  ;; comes after the 'with-git-url' transformation.
  (let ((source (git-checkout (url "https://example.org")
                              (branch "BRANCH")
                              (recursive? #t))))
    (list source source))
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation
             (reverse '((with-git-url
                         . "grep=https://example.org")
                        (with-branch . "grep=BRANCH"))))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-name dep1) "grep")
                   (string=? (package-name dep2) "chbouib")
                   (match (package-native-inputs dep2)
                     ((("x" dep3))
                      (map package-source (list dep1 dep3)))))))))))

(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
  "Return true if P depends on TOOLCHAIN instead of the default tool chain."
  (define toolchain-packages
    '("gcc" "binutils" "glibc" "ld-wrapper"))

  (define (package-name* obj)
    (and (package? obj) (package-name obj)))

  (match (bag-build-inputs (package->bag p))
    (((_ (= package-name* packages) . _) ...)
     (and (not (any (cut member <> packages) toolchain-packages))
          (member toolchain packages)))))

(test-assert "options->transformation, with-c-toolchain"
  (let* ((dep0 (dummy-package "chbouib"
                 (build-system gnu-build-system)
                 (native-inputs `(("y" ,grep)))))
         (dep1 (dummy-package "stuff"
                 (native-inputs `(("x" ,dep0)))))
         (p    (dummy-package "thingie"
                 (build-system gnu-build-system)
                 (inputs `(("foo" ,grep)
                           ("bar" ,dep1)))))
         (t    (options->transformation
                '((with-c-toolchain . "chbouib=gcc-toolchain")))))
    ;; Here we check that the transformation applies to DEP0 and all its
    ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
    ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
    (let ((new (t p)))
      (and (depends-on-toolchain? new "gcc-toolchain")
           (match (bag-build-inputs (package->bag new))
             ((("foo" dep0) ("bar" dep1) _ ...)
              (and (depends-on-toolchain? dep1 "gcc-toolchain")
                   (not (depends-on-toolchain? dep0 "gcc-toolchain"))
                   (string=? (package-full-name dep0)
                             (package-full-name grep))
                   (match (bag-build-inputs (package->bag dep1))
                     ((("x" dep) _ ...)
                      (and (depends-on-toolchain? dep "gcc-toolchain")
                           (match (bag-build-inputs (package->bag dep))
                             ((("y" dep) _ ...)   ;this one is unchanged
                              (eq? dep grep)))))))))))))

(test-equal "options->transformation, with-c-toolchain twice"
  (package-full-name grep)
  (let* ((dep0 (dummy-package "chbouib"))
         (dep1 (dummy-package "stuff"))
         (p    (dummy-package "thingie"
                 (build-system gnu-build-system)
                 (inputs `(("foo" ,dep0)
                           ("bar" ,dep1)
                           ("baz" ,grep)))))
         (t    (options->transformation
                '((with-c-toolchain . "chbouib=clang-toolchain")
                  (with-c-toolchain . "stuff=clang-toolchain")))))
    (let ((new (t p)))
      (and (depends-on-toolchain? new "clang-toolchain")
           (match (bag-build-inputs (package->bag new))
             ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
              (and (depends-on-toolchain? dep0 "clang-toolchain")
                   (depends-on-toolchain? dep1 "clang-toolchain")
                   (not (depends-on-toolchain? dep2 "clang-toolchain"))
                   (package-full-name dep2))))))))

(test-assert "options->transformation, with-c-toolchain, no effect"
  (let ((p (dummy-package "thingie"))
        (t (options->transformation
            '((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
    ;; When it has no effect, '--with-c-toolchain' returns P.
    (eq? (t p) p)))

(test-equal "options->transformation, with-debug-info"
  '(#:strip-binaries? #f)
  (let* ((dep  (dummy-package "chbouib"))
         (p    (dummy-package "thingie"
                 (build-system gnu-build-system)
                 (inputs `(("foo" ,dep)
                           ("bar" ,grep)))))
         (t    (options->transformation
                '((with-debug-info . "chbouib")))))
    (let ((new (t p)))
      (match (package-inputs new)
        ((("foo" dep0) ("bar" dep1))
         (and (string=? (package-full-name dep1)
                        (package-full-name grep))
              (package-arguments (package-replacement dep0))))))))

(test-assert "options->transformation, without-tests"
  (let* ((dep (dummy-package "dep"))
         (p   (dummy-package "foo"
                (inputs `(("dep" ,dep)))))
         (t   (options->transformation '((without-tests . "dep")
                                         (without-tests . "tar")))))
    (let ((new (t p)))
      (match (bag-direct-inputs (package->bag new))
        ((("dep" dep) ("tar" tar) _ ...)
         (and (equal? (package-arguments dep) '(#:tests? #f))
              (match (memq #:tests? (package-arguments tar))
                ((#:tests? #f _ ...) #t))))))))

(test-equal "options->transformation, with-patch"
  (search-patches "glibc-locales.patch" "guile-relocatable.patch")
  (let* ((dep    (dummy-package "dep"
                   (source (dummy-origin))))
         (p      (dummy-package "foo"
                   (inputs `(("dep" ,dep)))))
         (patch1 (search-patch "glibc-locales.patch"))
         (patch2 (search-patch "guile-relocatable.patch"))
         (t      (options->transformation
                  `((with-patch . ,(string-append "dep=" patch1))
                    (with-patch . ,(string-append "dep=" patch2))
                    (with-patch . ,(string-append "tar=" patch1))))))
    (let ((new (t p)))
      (match (bag-direct-inputs (package->bag new))
        ((("dep" dep) ("tar" tar) _ ...)
         (and (member patch1
                      (filter-map (lambda (patch)
                                    (and (local-file? patch)
                                         (local-file-file patch)))
                                  (origin-patches (package-source tar))))
              (map local-file-file
                   (origin-patches (package-source dep)))))))))

(test-equal "options->transformation, with-latest"
  "42.0"
  (mock ((guix upstream) %updaters
         (delay (list (upstream-updater
                       (name 'dummy)
                       (pred (const #t))
                       (description "")
                       (latest (const (upstream-source
                                       (package "foo")
                                       (version "42.0")
                                       (urls '("http://example.org")))))))))
        (let* ((p (dummy-package "foo" (version "1.0")))
               (t (options->transformation
                   `((with-latest . "foo")))))
          (package-version (t p)))))

(test-equal "options->transformation + package->manifest-entry"
  '((transformations . ((without-tests . "foo"))))
  (let* ((p (dummy-package "foo"))
         (t (options->transformation '((without-tests . "foo"))))
         (e (package->manifest-entry (t p))))
    (manifest-entry-properties e)))

(test-end)

;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 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 (test-ui)
  #:use-module (guix ui)
  #:use-module (guix profiles)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module ((gnu packages) #:select (specification->package))
  #:use-module (guix tests)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 regex))

;; Test the (guix ui) module.

(define %paragraph
  "GNU Guile is an implementation of the Scheme programming language, with
support for many SRFIs, packaged for use in a wide variety of environments.
In addition to implementing the R5RS Scheme standard and a large subset of
R6RS, Guile includes a module system, full access to POSIX system calls,
networking support, multiple threads, dynamic linking, a foreign function call
interface, and powerful string processing.")

(define guile-1.8.8
  (manifest-entry
    (name "guile")
    (version "1.8.8")
    (item "/gnu/store/...")
    (output "out")))

(define guile-2.0.9
  (manifest-entry
    (name "guile")
    (version "2.0.9")
    (item "/gnu/store/...")
    (output "out")))

(test-begin "ui")

(test-assert "fill-paragraph"
  (every (lambda (column)
           (every (lambda (width)
                    (every (lambda (line)
                             (<= (string-length line) width))
                           (string-split (fill-paragraph %paragraph
                                                         width column)
                                         #\newline)))
                  '(15 30 35 40 45 50 60 70 80 90 100)))
   '(0 5)))

(test-assert "fill-paragraph, consecutive newlines"
  (every (lambda (width)
           (any (lambda (line)
                  (string-prefix? "When STR" line))
                (string-split
                 (fill-paragraph (procedure-documentation fill-paragraph)
                                 width)
                 #\newline)))
         '(15 20 25 30 40 50 60)))

(test-equal "fill-paragraph, large unbreakable word"
  '("Here is a" "very-very-long-word"
    "and that's" "it.")
  (string-split
   (fill-paragraph "Here is a very-very-long-word and that's it."
                   10)
   #\newline))

(test-equal "fill-paragraph, two spaces after period"
  "First line.  Second line"
  (fill-paragraph "First line.
Second line" 24))

(test-equal "package-description-string vs. Unicode"
  "b•ll•t\n\n"                                ;see <http://bugs.gnu.org/21536>
  (with-fluids ((%default-port-encoding "ISO-8859-1"))
    (package-description-string
     (dummy-package "foo" (description "b•ll•t")))))

(test-equal "package-specification->name+version+output"
  '(("guile" #f "out")
    ("guile" "2.0.9" "out")
    ("guile" #f "debug")
    ("guile" "2.0.9" "debug")
    ("guile-cairo" "1.4.1" "out"))
  (map (lambda (spec)
         (call-with-values
             (lambda ()
               (package-specification->name+version+output spec))
           list))
       '("guile"
         "guile@2.0.9"
         "guile:debug"
         "guile@2.0.9:debug"
         "guile-cairo@1.4.1")))

(test-equal "integer"
  '(1)
  (string->generations "1"))

(test-equal "comma-separated integers"
  '(3 7 1 4 6)
  (string->generations "3,7,1,4,6"))

(test-equal "closed range"
  '(4 5 6 7 8 9 10 11 12)
  (string->generations "4..12"))

(test-equal "closed range, equal endpoints"
  '(3)
  (string->generations "3..3"))

(test-equal "indefinite end range"
  '(>= 7)
  (string->generations "7.."))

(test-equal "indefinite start range"
  '(<= 42)
  (string->generations "..42"))

(test-equal "integer, char"
  #f
  (string->generations "a"))

(test-equal "comma-separated integers, consecutive comma"
  #f
  (string->generations "1,,2"))

(test-equal "comma-separated integers, trailing comma"
  #f
  (string->generations "1,2,"))

(test-equal "comma-separated integers, chars"
  #f
  (string->generations "a,b"))

(test-equal "closed range, start > end"
  #f
  (string->generations "9..2"))

(test-equal "closed range, chars"
  #f
  (string->generations "a..b"))

(test-equal "indefinite end range, char"
  #f
  (string->generations "a.."))

(test-equal "indefinite start range, char"
  #f
  (string->generations "..a"))

(test-equal "duration, 1 day"
  (make-time time-duration 0 (* 3600 24))
  (string->duration "1d"))

(test-equal "duration, 1 week"
  (make-time time-duration 0 (* 3600 24 7))
  (string->duration "1w"))

(test-equal "duration, 1 month"
  (make-time time-duration 0 (* 3600 24 30))
  (string->duration "1m"))

(test-equal "duration, 1 week == 7 days"
  (string->duration "1w")
  (string->duration "7d"))

(test-equal "duration, 1 month == 30 days"
  (string->duration "1m")
  (string->duration "30d"))

(test-equal "duration, 2 hours"
  7200
  (time-second (string->duration "2h")))

(test-equal "duration, 1 second"
  (make-time time-duration 0 1)
  (string->duration "1s"))

(test-equal "duration, integer"
  #f
  (string->duration "1"))

(test-equal "duration, char"
  #f
  (string->duration "d"))

(test-equal "size->number, bytes"
  42
  (size->number "42"))

(test-equal "size->number, MiB"
  (* 42 (expt 2 20))
  (size->number "42MiB"))

(test-equal "size->number, GiB"
  (* 3 (expt 2 30))
  (size->number "3GiB"))

(test-equal "size->number, 1.2GiB"
  (inexact->exact (round (* 1.2 (expt 2 30))))
  (size->number "1.2GiB"))

(test-equal "size->number, 1T"
  (expt 2 40)
  (size->number "1T"))

(test-equal "size->number, 1.M"
  (expt 2 20)
  (size->number "1.M"))

(test-assert "size->number, invalid unit"
  (catch 'quit
    (lambda ()
      (size->number "9X"))
    (lambda args
      #t)))

(test-equal "show-what-to-build, zero outputs"
  ""
  (with-store store
    (let ((drv (derivation store "zero" "/bin/sh" '()
                           #:outputs '())))
      (with-error-to-string
       (lambda ()
         ;; This should print nothing.
         (show-what-to-build store (list drv)))))))

(test-assert "show-manifest-transaction"
  (let* ((m (manifest (list guile-1.8.8)))
         (t (manifest-transaction (install (list guile-2.0.9)))))
    (with-store store
      (and (string-match "guile +1.8.8 → 2.0.9"
                         (with-fluids ((%default-port-encoding "UTF-8"))
                           (with-error-to-string
                            (lambda ()
                              (show-manifest-transaction store m t)))))
           (string-match "guile +1.8.8 -> 2.0.9"
                         (with-error-to-string
                           (lambda ()
                             ;; In Guile 2.2, %DEFAULT-PORT-ENCODING doesn't
                             ;; influence the encoding of string ports.
                             (set-port-encoding! (current-error-port)
                                                 "ISO-8859-1")
                             (show-manifest-transaction store m t))))))))

(test-assert "package-relevance"
  (let ((guile  (specification->package "guile"))
        (gcrypt (specification->package "guile-gcrypt"))
        (go     (specification->package "go"))
        (gnugo  (specification->package "gnugo"))
        (libb2  (specification->package "libb2"))
        (rx     (cut make-regexp <> regexp/icase))
        (>0     (cut > <> 0))
        (=0     zero?))
    (and (>0 (package-relevance guile
                                (map rx '("scheme"))))
         (>0 (package-relevance guile
                                (map rx '("scheme" "implementation"))))
         (>0 (package-relevance gcrypt
                                (map rx '("guile" "crypto"))))
         (=0 (package-relevance guile
                                (map rx '("guile" "crypto"))))
         (>0 (package-relevance go
                                (map rx '("go"))))
         (=0 (package-relevance go
                                (map rx '("go" "game"))))
         (>0 (package-relevance gnugo
                                (map rx '("go" "game"))))
         (>0 (package-relevance libb2
                                (map rx '("crypto" "library")))))))

(test-end "ui")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@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 (test-union)
  #:use-module (guix tests)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix build union)
  #:use-module ((guix build utils)
                #:select (with-directory-excursion directory-exists?))
  #:use-module (gnu packages bootstrap)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match))

;; Exercise the (guix build union) module.

(define %store
  (open-connection-for-tests))

(test-begin "union")

(test-assert "union-build with symlink to directory"
  ;; http://bugs.gnu.org/17083
  ;; Here both ONE and TWO provide an element called 'foo', but in ONE it's a
  ;; directory whereas in TWO it's a symlink to a directory.
  (let* ((one     (build-expression->derivation
                   %store "one"
                   '(begin
                      (use-modules (guix build utils) (srfi srfi-26))
                      (let ((foo (string-append %output "/foo")))
                        (mkdir-p foo)
                        (call-with-output-file (string-append foo "/one")
                          (cut display "one" <>))))
                   #:modules '((guix build utils))))
         (two     (build-expression->derivation
                   %store "two"
                   '(begin
                      (use-modules (guix build utils) (srfi srfi-26))
                      (let ((foo (string-append %output "/foo"))
                            (bar (string-append %output "/bar")))
                        (mkdir-p bar)
                        (call-with-output-file (string-append bar "/two")
                          (cut display "two" <>))
                        (symlink "bar" foo)))
                   #:modules '((guix build utils))))
         (builder '(begin
                     (use-modules (guix build union))

                     (union-build (assoc-ref %outputs "out")
                                  (list (assoc-ref %build-inputs "one")
                                        (assoc-ref %build-inputs "two")))))
         (drv
          (build-expression->derivation %store "union-collision-symlink"
                                        builder
                                        #:inputs `(("one" ,one) ("two" ,two))
                                        #:modules '((guix build union)))))
    (and (build-derivations %store (list drv))
         (with-directory-excursion (pk (derivation->output-path drv))
           (and (string=? "one"
                          (call-with-input-file "foo/one" get-string-all))
                (string=? "two"
                          (call-with-input-file "foo/two" get-string-all))
                (string=? "two"
                          (call-with-input-file "bar/two" get-string-all))
                (not (file-exists? "bar/one")))))))

(test-skip (if (and %store (network-reachable?))
               0
               1))

(test-assert "union-build"
  (let* ((inputs  (map (match-lambda
                        ((name package)
                         `(,name ,(package-derivation %store package))))

                       ;; Purposefully leave duplicate entries.
                       (filter (compose package? cadr)
                               (append %bootstrap-inputs-for-tests
                                       (take %bootstrap-inputs-for-tests 3)))))
         (builder `(begin
                     (use-modules (guix build union))
                     (union-build (assoc-ref %outputs "out")
                                  (map cdr %build-inputs))))
         (drv
          (build-expression->derivation %store "union-test"
                                        builder
                                        #:inputs inputs
                                        #:modules '((guix build union)))))
    (and (build-derivations %store (list (pk 'drv drv)))
         (with-directory-excursion (derivation->output-path drv)
           (and (file-exists? "bin/touch")
                (file-exists? "bin/gcc")
                (file-exists? "bin/ld")
                (file-exists? "lib/libc.so")
                (directory-exists? "lib/gcc")
                (file-exists? "include/unistd.h")

                ;; The 'include/c++' sub-directory is only found in
                ;; gcc-bootstrap, so it should be unified in a
                ;; straightforward way, without traversing it.
                (eq? 'symlink (stat:type (lstat "include/c++")))

                ;; Conversely, several inputs have a 'bin' sub-directory, so
                ;; unifying it requires traversing them all, and creating a
                ;; new 'bin' sub-directory in the profile.
                (eq? 'directory (stat:type (lstat "bin"))))))))

(test-assert "union-build collision first & last"
  (let* ((guile   (package-derivation %store %bootstrap-guile))
         (fake    (build-expression->derivation
                   %store "fake-guile"
                   '(begin
                      (use-modules (guix build utils))
                      (let ((out (assoc-ref %outputs "out")))
                        (mkdir-p (string-append out "/bin"))
                        (call-with-output-file (string-append out "/bin/guile")
                          (const #t))))
                   #:modules '((guix build utils))))
         (builder (lambda (policy)
                    `(begin
                       (use-modules (guix build union)
                                    (srfi srfi-1))
                       (union-build (assoc-ref %outputs "out")
                                    (map cdr %build-inputs)
                                    #:resolve-collision ,policy))))
         (drv1
          (build-expression->derivation %store "union-first"
                                        (builder 'first)
                                        #:inputs `(("guile" ,guile)
                                                   ("fake" ,fake))
                                        #:modules '((guix build union))))
         (drv2
          (build-expression->derivation %store "union-last"
                                        (builder 'last)
                                        #:inputs `(("guile" ,guile)
                                                   ("fake" ,fake))
                                        #:modules '((guix build union)))))
    (and (build-derivations %store (list drv1 drv2))
         (with-directory-excursion (derivation->output-path drv1)
           (string=? (readlink "bin/guile")
                     (string-append (derivation->output-path guile)
                                    "/bin/guile")))
         (with-directory-excursion (derivation->output-path drv2)
           (string=? (readlink "bin/guile")
                     (string-append (derivation->output-path fake)
                                    "/bin/guile"))))))

(test-assert "union-build #:create-all-directories? #t"
  (let* ((build  `(begin
                    (use-modules (guix build union))
                    (union-build (assoc-ref %outputs "out")
                                 (map cdr %build-inputs)
                                 #:create-all-directories? #t)))
         (input  (package-derivation %store %bootstrap-guile))
         (drv    (build-expression->derivation %store "union-test-all-dirs"
                                               build
                                               #:modules '((guix build union))
                                               #:inputs `(("g" ,input)))))
    (and (build-derivations %store (list drv))
         (with-directory-excursion (derivation->output-path drv)
           ;; Even though there's only one input to the union,
           ;; #:create-all-directories? #t must have created bin/ rather than
           ;; making it a symlink to Guile's bin/.
           (and (file-exists? "bin/guile")
                (file-is-directory? "bin")
                (eq? 'symlink (stat:type (lstat "bin/guile"))))))))

(letrec-syntax ((test-relative-file-name
                 (syntax-rules (=>)
                   ((_ (reference file => expected) rest ...)
                    (begin
                      (test-equal (string-append "relative-file-name "
                                                 reference " " file)
                        expected
                        (relative-file-name reference file))
                      (test-relative-file-name rest ...)))
                   ((_)
                    #t))))
  (test-relative-file-name
   ("/a/b" "/a/c/d"     => "../c/d")
   ("/a/b" "/a/b"       => "")
   ("/a/b" "/a"         => "..")
   ("/a/b" "/a/b/c/d"   => "c/d")
   ("/a/b/c" "/a/d/e/f" => "../../d/e/f")))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 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 (test-upstream)
  #:use-module (guix upstream)
  #:use-module (guix tests)
  #:use-module (srfi srfi-64))

(test-begin "upstream")

;; FIXME: Temporarily skipping this test; see <https://bugs.gnu.org/34229>.
(test-skip 1)

(test-equal "coalesce-sources same version"
  (list (upstream-source
         (package "foo") (version "1")
         (urls '("ftp://example.org/foo-1.tar.xz"
                 "ftp://example.org/foo-1.tar.gz"))
         (signature-urls '("ftp://example.org/foo-1.tar.xz.sig"
                           "ftp://example.org/foo-1.tar.gz.sig"))))

  (coalesce-sources (list (upstream-source
                           (package "foo") (version "1")
                           (urls '("ftp://example.org/foo-1.tar.gz"))
                           (signature-urls
                            '("ftp://example.org/foo-1.tar.gz.sig")))
                          (upstream-source
                           (package "foo") (version "1")
                           (urls '("ftp://example.org/foo-1.tar.xz"))
                           (signature-urls
                            '("ftp://example.org/foo-1.tar.xz.sig"))))))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; 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 (test-utils)
  #:use-module ((guix config) #:select (%gzip))
  #:use-module (guix utils)
  #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
  #:use-module ((guix search-paths) #:select (string-tokenize*))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist))

(define temp-file
  (string-append "t-utils-" (number->string (getpid))))

(test-begin "utils")

(test-assert "gnu-triplet->nix-system"
  (let ((samples '(("i586-gnu0.3" "i686-gnu")
                   ("x86_64-unknown-linux-gnu" "x86_64-linux")
                   ("i386-pc-linux-gnu" "i686-linux")
                   ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
                   ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
                   ("i686-pc-cygwin" "i686-cygwin"))))
    (let-values (((gnu nix) (unzip2 samples)))
      (every (lambda (gnu nix)
               (equal? nix (gnu-triplet->nix-system gnu)))
             gnu nix))))

(test-assert "package-name->name+version"
  (every (match-lambda
          ((name version)
           (let*-values (((full-name)
                          (if version
                              (string-append name "@" version)
                              name))
                         ((name* version*)
                          (package-name->name+version full-name)))
             (and (equal? name* name)
                  (equal? version* version)))))
         '(("foo" "0.9.1b")
           ("foo-14-bar" "320")
           ("foo-bar2" #f)
           ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
           ("nixpkgs" "1.0pre22125_a28fe19")
           ("gtk2" "2.38.0"))))

(test-assert "guile-version>? 1.8"
  (guile-version>? "1.8"))

(test-assert "guile-version>? 10.5"
  (not (guile-version>? "10.5")))

(test-assert "version-prefix?"
  (and (version-prefix? "4.1" "4.1.2")
       (version-prefix? "4.1" "4.1")
       (not (version-prefix? "4.1" "4.16.2"))
       (not (version-prefix? "4.1" "4"))))

(test-equal "version-unique-prefix"
  '("2" "2.2" "")
  (list (version-unique-prefix "2.0" '("3.0" "2.0"))
        (version-unique-prefix "2.2" '("3.0.5" "2.0.9" "2.2.7"))
        (version-unique-prefix "27.1" '("27.1"))))

(test-equal "string-tokenize*"
  '(("foo")
    ("foo" "bar" "baz")
    ("foo" "bar" "")
    ("foo" "bar" "baz"))
  (list (string-tokenize* "foo" ":")
        (string-tokenize* "foo;bar;baz" ";")
        (string-tokenize* "foo!bar!" "!")
        (string-tokenize* "foo+-+bar+-+baz" "+-+")))

(test-equal "string-replace-substring"
  '("foo BAR! baz"
    "/gnu/store/chbouib"
    "")
  (list (string-replace-substring "foo bar baz" "bar" "BAR!")
        (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
        (string-replace-substring "" "foo" "bar")))

(test-equal "strip-keyword-arguments"
  '(a #:b b #:c c)
  (strip-keyword-arguments '(#:foo #:bar #:baz)
                           '(a #:foo 42 #:b b #:baz 3
                               #:c c #:bar 4)))

(test-equal "ensure-keyword-arguments"
  '((#:foo 2)
    (#:foo 2 #:bar 3)
    (#:foo 42 #:bar 3))
  (list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
        (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
        (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))

(test-equal "default-keyword-arguments"
  '((#:foo 2)
    (#:foo 2)
    (#:foo 2 #:bar 3)
    (#:foo 2 #:bar 3)
    (#:foo 2 #:bar 3))
  (list (default-keyword-arguments '() '(#:foo 2))
        (default-keyword-arguments '(#:foo 2) '(#:foo 4))
        (default-keyword-arguments '() '(#:bar 3 #:foo 2))
        (default-keyword-arguments '(#:bar 3) '(#:foo 2))
        (default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))

(test-equal "substitute-keyword-arguments"
  '((#:foo 3)
    (#:foo 3)
    (#:foo 3 #:bar (1 2))
    (#:bar (1 2) #:foo 3)
    (#:foo 3))
  (list (substitute-keyword-arguments '(#:foo 2)
          ((#:foo f) (1+ f)))
        (substitute-keyword-arguments '()
          ((#:foo f 2) (1+ f)))
        (substitute-keyword-arguments '(#:foo 2 #:bar (2))
          ((#:foo f) (1+ f))
          ((#:bar b) (cons 1 b)))
        (substitute-keyword-arguments '(#:foo 2)
          ((#:foo _) 3)
          ((#:bar b '(2)) (cons 1 b)))
        (substitute-keyword-arguments '(#:foo 2)
          ((#:foo f 1) (1+ f))
          ((#:bar b) (cons 42 b)))))

(test-assert "filtered-port, file"
  (let* ((file  (search-path %load-path "guix.scm"))
         (input (open-file file "r0b")))
    (let*-values (((compressed pids1)
                   (filtered-port `(,%gzip "-c" "--fast") input))
                  ((decompressed pids2)
                   (filtered-port `(,%gzip "-d") compressed)))
      (and (every (compose zero? cdr waitpid)
                  (append pids1 pids2))
           (equal? (get-bytevector-all decompressed)
                   (call-with-input-file file get-bytevector-all))))))

(test-assert "filtered-port, non-file"
  (let ((data (call-with-input-file (search-path %load-path "guix.scm")
                get-bytevector-all)))
    (let*-values (((compressed pids1)
                   (filtered-port `(,%gzip "-c" "--fast")
                                  (open-bytevector-input-port data)))
                  ((decompressed pids2)
                   (filtered-port `(,%gzip "-d") compressed)))
      (and (pk (every (compose zero? cdr waitpid)
                   (append pids1 pids2)))
           (equal? (get-bytevector-all decompressed) data)))))

(test-assert "filtered-port, does not exist"
  (let* ((file  (search-path %load-path "guix.scm"))
         (input (open-file file "r0b")))
    (let-values (((port pids)
                  (filtered-port '("/does/not/exist") input)))
      (any (compose (negate zero?) cdr waitpid)
           pids))))

(define (test-compression/decompression method run?)
  "Test METHOD, a symbol such as 'gzip.  Call RUN? to determine whether to
skip these tests."
  (unless (run?) (test-skip 1))
  (test-assert (format #f "compressed-port, decompressed-port, non-file [~a]"
                       method)
    (let ((data (call-with-input-file (search-path %load-path "guix.scm")
                  get-bytevector-all)))
      (call-with-temporary-output-file
       (lambda (output port)
         (close-port port)
         (let*-values (((compressed pids)
                        ;; Note: 'compressed-output-port' only supports file
                        ;; ports.
                        (compressed-output-port method
                                                (open-file output "w0"))))
           (put-bytevector compressed data)
           (close-port compressed)
           (and (every (compose zero? cdr waitpid)
                       (pk 'pids method pids))
                (let*-values (((decompressed pids)
                               (decompressed-port method
                                                  (open-bytevector-input-port
                                                   (call-with-input-file output
                                                     get-bytevector-all))))
                              ((result)
                               (get-bytevector-all decompressed)))
                  (close-port decompressed)
                  (pk 'len method
                      (if (bytevector? result)
                          (bytevector-length result)
                          result)
                      (bytevector-length data))
                  (and (every (compose zero? cdr waitpid)
                              (pk 'pids method pids))
                       (equal? result data)))))))))

  (false-if-exception (delete-file temp-file))
  (unless (run?) (test-skip 1))
  (test-assert (format #f "compressed-output-port + decompressed-port [~a]"
                       method)
    (let* ((file (search-path %load-path "guix/derivations.scm"))
           (data (call-with-input-file file get-bytevector-all))
           (port (open-file temp-file "w0b")))
      (call-with-compressed-output-port method port
        (lambda (compressed)
          (put-bytevector compressed data)))
      (close-port port)

      (bytevector=? data
                    (call-with-decompressed-port method (open-file temp-file "r0b")
                      get-bytevector-all)))))

(for-each test-compression/decompression
          `(gzip xz lzip zstd)
          (list (const #t) (const #t) (const #t)
                (lambda ()
                  (resolve-module '(zstd) #t #f #:ensure #f))))

;; This is actually in (guix store).
(test-equal "store-path-package-name"
  "bash-4.2-p24"
  (store-path-package-name
   (string-append (%store-prefix)
                  "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))

(test-equal "canonical-newline-port"
  "This is a journey\nInto the sound\nA journey ...\n"
  (let ((port (open-string-input-port
               "This is a journey\r\nInto the sound\r\nA journey ...\n")))
    (get-string-all (canonical-newline-port port))))

(test-equal "canonical-newline-port-1024"
  (string-concatenate (make-list 100 "0123456789abcde\n"))
  (let ((port (open-string-input-port
               (string-concatenate
                (make-list 100 "0123456789abcde\r\n")))))
    (get-string-all (canonical-newline-port port))))

(test-equal "edit-expression"
  "(display \"GNU Guix\")\n(newline)\n"
  (begin
    (call-with-output-file temp-file
      (lambda (port)
        (display "(display \"xiuG UNG\")\n(newline)\n" port)))
    (edit-expression `((filename . ,temp-file)
                       (line     . 0)
                       (column   . 9))
                     string-reverse)
    (call-with-input-file temp-file get-string-all)))

(test-equal "string-distance"
  '(0 1 1 5 5)
  (list
   (string-distance "hello" "hello")
   (string-distance "hello" "helo")
   (string-distance "helo" "hello")
   (string-distance "" "hello")
   (string-distance "hello" "")))

(test-equal "string-closest"
  '("hello" "hello" "helo" #f)
  (list
   (string-closest "hello" '("hello"))
   (string-closest "hello" '("helo" "hello" "halo"))
   (string-closest "hello" '("kikoo" "helo" "hihihi" "halo"))
   (string-closest "hello" '("aaaaa" "12345" "hellohello" "h"))))

(test-end)

(false-if-exception (delete-file temp-file))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017, 2018, 2019 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 (test-uuid)
  #:use-module (gnu system uuid)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors))

(test-begin "uuid")

(test-equal "uuid->string"
  "c5307e6b-d1ba-499d-89c5-cb0b143577c4"
  (uuid->string
   #vu8(197 48 126 107 209 186 73 157 137 197 203 11 20 53 119 196)))

(test-equal "string->uuid"
  '(16 "4dab5feb-d176-45de-b287-9b0a6e4c01cb")
  (let ((uuid (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")))
    (list (bytevector-length uuid) (uuid->string uuid))))

(test-assert "uuid"
  (let ((str "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))
    (bytevector=? (uuid-bytevector
                   (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))
                  (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))))

(test-assert "uuid, syntax error"
  (catch 'syntax-error
    (lambda ()
      (eval '(uuid "foobar") (current-module))
      #f)
    (lambda (key proc message location form . args)
      (and (eq? proc 'uuid)
           (string-contains message "invalid UUID")
           (equal? form '(uuid "foobar" 'dce))))))

(test-equal "uuid, ISO-9660, format preserved"
  "1970-01-01-17-14-42-99"
  (uuid->string (uuid "1970-01-01-17-14-42-99" 'iso9660)))

(test-equal "uuid, FAT32, format preserved"
  "1234-ABCD"
  (uuid->string (uuid "1234-abcd" 'fat32)))

(test-equal "uuid, FAT32, leading zeros preserved"
  "00CA-050E"                                    ;<https://bugs.gnu.org/35582>
  (uuid->string (uuid "00CA-050E" 'fat32)))

(test-assert "uuid, dynamic value"
  (let* ((good "4dab5feb-d176-45de-b287-9b0a6e4c01cb")
         (bad  (string-drop good 3)))
    (and (uuid? (uuid good))
         (string=? good (uuid->string (uuid good)))
         (not (uuid bad)))))

(test-assert "uuid=?"
  (and (uuid=? (uuid-bytevector (uuid "1234-abcd" 'fat32))
               (uuid "1234-abcd" 'fat32))
       (uuid=? (uuid "1234-abcd" 'fat32)
               (uuid "1234-abcd" 'fat))))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 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 (test-workers)
  #:use-module (guix workers)
  #:use-module (ice-9 threads)
  #:use-module (srfi srfi-64))

(test-begin "workers")

(test-equal "enqueue"
  4242
  (let* ((pool   (make-pool))
         (result 0)
         (1+!    (let ((lock (make-mutex)))
                   (lambda ()
                     (with-mutex lock
                       (set! result (+ result 1)))))))
    (let loop ((i 4242))
      (unless (zero? i)
        (pool-enqueue! pool 1+!)
        (loop (- i 1))))
    (let poll ()
      (unless (pool-idle? pool)
        (pk 'busy result)
        (sleep 1)
        (poll)))
    result))

;; Same as above, but throw exceptions within the workers and make sure they
;; remain alive.
(test-equal "exceptions"
  4242
  (let* ((pool   (make-pool 10))
         (result 0)
         (1+!    (let ((lock (make-mutex)))
                   (lambda ()
                     (with-mutex lock
                       (set! result (+ result 1)))))))
    (let loop ((i 10))
      (unless (zero? i)
        (pool-enqueue! pool (lambda ()
                              (throw 'whatever)))
        (loop (- i 1))))
    (let loop ((i 4242))
      (unless (zero? i)
        (pool-enqueue! pool 1+!)
        (loop (- i 1))))
    (let poll ()
      (unless (pool-idle? pool)
        (pk 'busy result)
        (sleep 1)
        (poll)))
    result))

(test-end)


code:
[dependencies]

[package]
authors = ["Peter Lane <peterlane@gmx.com>"]
categories = ["science"]
description = "Confusion matrix implementation for storing results from a classification experiment and providing statistical information."
repository = "https://notabug.org/peterlane/confusion-matrix-rust"
edition = "2021"
exclude = ["examples/*.rs"]
keywords = ["analysis", "data-science", "machine-learning"]
license = "MIT"
name = "confusion_matrix"
readme = "README.md"
version = "1.1.0"

repo_name: peterlane/confusion

license: unknown


code:
# Confusion Matrix

For storing results from a classification experiment and providing statistical
information.

A confusion matrix is used in data-mining as a summary of the performance of a
classification algorithm. Each row represents the _actual_ class of an
instance, and each column represents the _predicted_ class of that instance,
i.e. the class that they were classified as.  Numbers at each (row, column)
reflect the total number of instances of actual class "row" which were
predicted to fall in class "column".

A two-class example is:

```
    Predicted       Predicted     |
    Positive        Negative      | Actual
    ------------------------------+------------
        a               b         | Positive
        c               d         | Negative
```

Here, the value:

* a is the number of true positives (those labelled positive and classified positive)
* b is the number of false negatives (those labelled positive but classified negative)
* c is the number of false positives (those labelled negative but classified positive)
* d is the number of true negatives (those labelled negative and classified negative)

From this table we can calculate statistics like:

* true positive rate = a/(a+b)
* positive recall = a/(a+c)

Features:

* incrementally add results to build up a confusion matrix
* calculate any of a range of statistics from the matrix at any time
* output the matrix to text as a simple table

## Example

The following example shows how to create a confusion matrix, add some
results, and then print some statistics and the table itself.

```rust
use confusion_matrix;

fn main() {
    let mut cm = confusion_matrix::new();

    cm[("pos", "pos")] = 10;
    cm[("pos", "neg")] = 5;
    cm[("neg", "neg")] = 20;
    cm[("neg", "pos")] = 3;

    println!("Precision: {}", cm.precision("pos"));
    println!("Recall: {}", cm.recall("pos"));
    println!("MCC: {}", cm.matthews_correlation("pos"));
    println!("");
    println!("{}", cm);
}
```

Output:

```text
Precision: 0.7692307692307693
Recall: 0.6666666666666666
MCC: 0.5524850114241865

Predicted |
neg pos   | Actual
----------+-------
 20   3   | neg
  5  10   | pos
```

## MIT Licence

Copyright (c) 2021-23, Peter Lane <peterlane@gmx.com>

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.


code:
use confusion_matrix;

fn main() {
    let mut cm = confusion_matrix::new();

    cm[("pos", "pos")] = 10;
    cm[("pos", "neg")] = 5;
    cm[("neg", "neg")] = 20;
    cm[("neg", "pos")] = 3;

    println!("Precision: {}", cm.precision("pos"));
    println!("Recall: {}", cm.recall("pos"));
    println!("MCC: {}", cm.matthews_correlation("pos"));
    println!("");
    println!("{}", cm);
}