code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 "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)

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")))

;; Avoid collisions with other tests.
(%http-server-port 10200)

(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 © 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 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@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-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 "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)))
      (let*-values (((compressed pids1)
                     (compressed-port method (open-bytevector-input-port data)))
                    ((decompressed pids2)
                     (decompressed-port method compressed)))
        (and (every (compose zero? cdr waitpid)
                    (pk 'pids method (append pids1 pids2)))
             (let ((result (get-bytevector-all decompressed)))
               (pk 'len method
                   (if (bytevector? result)
                       (bytevector-length result)
                       result)
                   (bytevector-length data))
               (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)
          (list (const #t) (const #t) (const #t)))

;; 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-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:
/build/
/install/
/release/
/sources/
/libreboot.conf
.version
.revision
.tarfiles
.epoch
push
*.vim
/TODO/
/docs/version
/bucts/
/coreboot/
/crossgcc/
/flashrom/
/grub/
/memtest86plus/
/seabios/
/bin/
/resources/utilities/ich9deblob/*.rom
/resources/utilities/ich9deblob/*.bin
/resources/utilities/ich9deblob/ich9deblob
/resources/utilities/ich9deblob/ich9gen
/resources/utilities/ich9deblob/demefactory
/resources/utilities/ich9deblob/obj/*.o
/resources/utilities/ich9deblob/obj/*/*.o
/resources/utilities/ich9deblob/mkdescriptor*.[ch]
/resources/utilities/ich9deblob/mkgbe*.[ch]
/resources/utilities/grub-assemble/grub_*.elf
/mkgbe.[ch]
/*.bin
/resources/utilities/i945-pwm/i945-pwm
/push
/ChangeLog
/NEWS
/version
/versiondate
/gm45macaddress
tocheck*
*.html
!www/template.html
/www/temp.md
/www/news/index.md

repo_name: consts/libreboot

path: .gitignore


code:
Paper Build System
==================

Entry Point
-----------

The entry point for using the paper build system is the main script in the root
directory, named after the build system (paper, libreboot, etc).
Running the main script with no argument will show its general usage.

Configuration
-------------

The paper build system can be configured with a script named after the build
system (paper, libreboot, etc) with a ".conf" suffix. It is automatically loaded
by the build system when running the main script.

It contains environment variables assigned to the desired values. The list of
environment variables is shown in the main script's general usage.

Project and Tool Targets
------------------------

The build system works around the concepts of projects and tools, that define
specific components that can be used to produce either:
* sources
* systems
* images
* tools

Various actions are available for each project and tool targets, many of which
are shown in the main script's general usage. Each project and tool may provide
a usage action that allows to see the specific usage for it. Actions are
executed recursively when no targets are specified.

Each project and tool target has its own directory (either in projects or tools)
that contain a script named after the target and possible a helper script, named
after the script with a "-helper" suffix. The helper script is automatically
included by the build system. Functions in helper scripts are usually prefixed
with the name of the target, where "-" symbols are replaced with "_" symbols.

Each project and tool target's actions are functions defined in the target's
specific script, with names matching the target's actions.

Meta-Targets
------------

Meta targets are project and tool targets that apply the requested action to
individual targets, allowing to execute an action to many targets at once.
For instance, a meta-target named after the build system with a "-all" suffix
would call other meta-targets, prefixed with "-images", "-tools", etc that would
then perform the requested action to all underlying targets.

Projects Actions
----------------

Various generic actions allow preparing projects through a series of steps:
* downloading, extracting or updating the project's sources
* building the project to a build directory
* installing the project to an install directory
* releasing the project to a release directory
* cleaning the build, install and release directories

Actions can be checked by a matching project-specific function, named after the
function to check with a "_check" suffix, to determine whether it is necessary
to run them again to follow the steps. An environment variable can force actions
to be executed, by specifying a space-separated list of projects:
PROJECTS_FORCE.

Projects Configuration and Patches
----------------------------------

Configuration for each project is stored in each project's own directory.
Targets for each project are defined with a "targets" file in each directory
of the "configs" directory. Targets are read recursively, following
sub-directory names for project targets.

Each project's configuration directory can be used to hold target-specific
information and configuration.

An "install" file in each sub-directory indicated which files to grab from the
build files and where to install them in the install directory.

Projects Sources
----------------

Each project can either download specific sources or use another project's
sources, possibly providing its own revision and patches.

Sources are downloaded with the "download" action or can be extracted from
released sources (after placing the sources in the sources directory) with the
"extract" action.

Projects may also keep their sources in a "sources" directory in their
project-specific directory.

Projects Build
--------------

Each project is built to a build directory, named after the project, with the
list of targets separated by a "-" symbol.

An environment variable allows controlling the number of tasks to run at the
same time: TASKS.

Projects Install
----------------

Projects are installed from "install" files in the project directory, that
copies the selected built files to the install directory, named after the
project, with the list of targets separated by a "-" symbol. These install files
are read recursively, following sub-directory names for project targets.

Additional files to install can be specified in the "install" directory and
described in an "install" file. These install files are read recursively,
following sub-directory names for project targets.

Projects Release
----------------

Projects are released to a release directory, named after the project, with the
list of targets separated by a "-" symbol. Each project's install files are
packed into a tarball to the corresponding release directory. A checksum and a
GPG detached signature (if the RELEASE_KEY environment variable is set) are also
generated.

Tarballs are generated reproducibly, from a list of files stored in the
".tarfiles" file. They may also contain the ".epoch", git ".revision" and
".version" files.

Tools Actions
-------------

Tools are used for maintaining the build system, for performing routine tasks
that can be automated. They may have specific actions and not implement any of
the generic actions.

Actions can be checked by a matching tool-specific function, named after the
function to check with a "_check" suffix, to determine whether it is necessary
to run them again to follow the steps. An environment variable can force actions
to be executed, by specifying a space-separated list of tasks: TASKS_FORCE.

Tools Sources
-------------

Tools may keep their sources in a "sources" directory in their tool-specific
directory. These sources may be updated with the "update" action.


code:
Libreboot project

Libreboot documentation is under docs/
The website is https://libreboot.org/
License can be found in COPYING and through parts of the source tree.

Libreboot is a free BIOS or UEFI replacement (free as in freedom); libre boot
firmware that initializes the hardware and starts a bootloader for your
operating system. It's also an open source BIOS, but open source fails to
promote freedom; please call libreboot free software.

Why use libreboot?

Many people use non-free boot firmware, even if they use GNU+Linux. Non-free
BIOS/UEFI firmware often contains backdoors, can be slow and have severe bugs,
where you are left helpless at the mercy of the developers; you have no freedom
over your computing. By contrast, libreboot is building a world where
everyone can use, study, adapt and share software, with true control and
ownership over their technology. In other words, you should use Libreboot for
your freedom's sake!

Libreboot is faster, more secure and more reliable than most non-free firmware,
and can provide many advanced features (such as encrypted /boot/, GPG signature
checking before booting your kernel, ability to load an OS from the flash chip,
and more).

Libreboot's main upstream providers are coreboot (which we deblob, for hardware
initialization), depthcharge (bootloader, and default libreboot payload on ARM),
and GRUB (bootloader, and default libreboot payload on x86). We also
integrate flashrom (for installing libreboot), and several of our own utilities,
scripts and configuration files. All of this is integrated into a single,
coherent package that is easy to use. We add our own patches to the various
upstreams used, and where feasible try to merge upstream as much as possible.

Libreboot provides a fully automated build system and installation process, with
documentation written for non-technical users, in an attempt to make the
software as easy to use as possible. ROM images are provided, along with
utilities, all built from the publicly distributed source code.

This README is licensed under Creative Commons Zero 1.0:
https://creativecommons.org/publicdomain/zero/1.0/

path: README


code:
Libreboot 20160907

For existing boards, there are no new board specific changes.

This release adds one new mainboard to libreboot:
* Intel D945GCLF desktop motherboard (thanks to Arthur Heymans)

Other bugfixes:
* Various improvements to the documentation
* re-added "unset superusers" to the grub.cfg, which was needed for some users
  depending on the distros that they used

Libreboot 20160902

This is a bugfix release, based on 20160818. It contains no new board changes.
The previous 20160818 release had build errors in the _src archive, and the
_util archive was only source code.

Changes compared to 20160818:
* Fixed bug where ./build module coreboot always returned non-zero status
* Fixed missing symlink of crossgcc when building from _src (thanks Arthur
Heymans)
* Fixed building with the depthcharge payload (ASUS C201)
* Proper ChangeLog now, instead of pasted git log
* Util archive is now binaries again (source code is in the _src archive)
* Documentation is now in HTML format

Libreboot 20160818

NEW BOARDS ADDED:
* ASUS Chromebook C201 (ARM laptop) (thanks to Paul Kocialkowski)
* Gigabyte GA-G41M-ES2L motherboard (desktop) (thanks to Damien Zammit)
* Intel D510MO motherboard (desktop) (thanks to Damien Zammit)
* ASUS KCMA-D8 motherboard (desktop) (thanks to Timothy Pearson)
* ASUS KFSN4-DRE motherboard (server) (thanks to Timothy Pearson)
* ASUS KGPE-D16 motherboard (server) (thanks to Timothy Pearson)

For boards previously supported, many fixes from upstream have been merged.

Other changes (compared to libreboot 20150518):
(this is a summary. For more detailed change list, refer to the git log)

256MiB VRAM allocated on GM45 (X200, T400, T500, R400) instead of 32MiB.
This is an improvement over both Lenovo BIOS and Libreboot 20150518, allowing
video decoding at 1080p to be smoother. (thanks Arthur Heymans)
To clarify, GM45 video performance in libreboot 20160818 is better than on
the original BIOS and the previous libreboot release.

64MiB VRAM on i945 (X60, T60, MacBook2,1) now supported in coreboot-libre, and
used by default (in the previous release, it was 8MiB allocated). Thanks to
Arthur Heymans.

Higher battery life on GM45 (X200, T400, T500, R400) due to higher cstates now
being supported (thanks Arthur Heymans). C4 power states also supported.

Text mode on GM45 (X200, T400, T500, R400) now works, making it possible to
use MemTest86+ comfortably. (thanks to Nick High from coreboot)

Dual channel LVDS displays on GM45 (T400, T500) are now automatically
detected in coreboot-libre. (thanks Vladimir Serbinenko from coreboot)

Partial fix in coreboot-libre for GRUB display on GM45, for dual channel
LVDS higher resolution LCD panels (T400, T500). (thanks Arthur Heymans)

Massively improved GRUB configuration, making it easier to boot more
encrypted systems automatically, and generally a more useful menu for booting
the system (thanks go to Klemens Nanni of the autoboot project).
Libreboot now uses the grub.cfg provided by the installed GNU+Linux distribution
automatically, if present, switching to that configuration. This is done across
many partitions, where libreboot actively searches for a configuration file
(also on LVM volumes and encrypted volumes). This should make libreboot more
easy to use for non-technical users, without having to modify the GRUB
configuration used in libreboot.

Utilities archives is now source only. You will need to compile the packages
in there (build scripts included, and a script for installing build
dependencies. (binary utility archives are planned again in the next
release, when the new build system is merged)

SeaGRUB is now the default payload on all x86 boards. (SeaBIOS configured to
load a compressed GRUB payload from CBFS immediately, without providing an
interface in SeaBIOS. This way, GRUB is still used but now BIOS services are
available, so you get the best of both worlds). Thanks go to Timothy Pearson
of coreboot for this idea.

crossgcc is now downloaded and built as a separate module to coreboot-libre,
with a universal revision used to build all boards.

Individual boards now have their own coreboot revision and patches, independently
of each other board. This makes maintenance easier.

Updated all utilities, and modules (coreboot, GRUB, etc) to newer versions,
with various bugfixes and improvements upstream.

RTC century byte issue now fixed on GM45 in coreboot-libre, so the date
should now be correctly displayed when running the latest linux kernel, instead
of seeing 1970-01-01 when you boot (thanks to Alexander Couzens from coreboot)

Build system now uses multiple CPU cores when building, speeding up building
for some people. Manually specifying how many cores are needed is also possible,
for those using the build system in a chroot environment. (thanks go to
Timothy Pearson from coreboot)

In the build system (git repository), https:// is now used when cloning coreboot.
http:// is used as a fallback for GRUB, if git:// fails.

New payload, the depthcharge bootloader (free bootloader maintained by Google)
for use on the ASUS Chromebook C201. (thanks go to Paul Kocialkowski)

Various fixes to the ich9gen utility (e.g. flash component density is now
set correctly in the descriptor, gbe-less descriptors now supported)

path: RELEASE


code:
---
title: How to install FreeBSD on a libreboot system
...

This section relates to preparing, booting and installing FreeBSD on
your libreboot system, using nothing more than a USB flash drive (and
*dd*). They've only been tested on a Lenovo ThinkPad x200.

It is expected that you use text mode in libreboot (txtmode images), for
the early boot process in FreeBSD. **Booting the installer results in a
red flickering text display, and doesn't boot.**

Thanks go to ioxcide in [this Reddit
post](https://www.reddit.com/r/BSD/comments/53jt70/libreboot_and_bsds/)
for the initial instructions.

TODO: test FreeBSD more extensively, and make sure it works (and fix it
if it does not). Instructions are provided here, to boot and install
FreeBSD but we're not sure whether it is currently fully compatible
with libreboot.

-   [Prepare the USB drive (in FreeBSD)](#prepare)
-   [Installing FreeBSD without full disk encryption](#noencryption)
-   [Installing FreeBSD with full disk encryption](#encryption)
-   [Booting](#booting)
-   [Configuring Grub](#configuring_grub)
-   [Troubleshooting](#troubleshooting)

**This section is only for the GRUB payload. For depthcharge (used on
CrOS devices in libreboot), instructions have yet to be written in the
libreboot documentation.**

freebsd.img is the installation image for FreeBSD. Adapt the filename
accordingly, for whatever FreeBSD version you use.

Prepare the USB drive (in FreeBSD)
----------------------------------

[This page](https://www.freebsd.org/doc/handbook/bsdinstall-pre.html) on
the FreeBSD website shows how to create a bootable USB drive for
installing FreeBSD. Use the *dd* on that page.

Prepare the USB drive (in NetBSD)
---------------------------------

[This
page](https://wiki.netbsd.org/tutorials/how_to_install_netbsd_from_an_usb_memory_stick/)
on the NetBSD website shows how to create a NetBSD bootable USB drive
from within NetBSD itself. You should use the *dd* method documented
there; you can use this with any ISO, including FreeBSD.

Prepare the USB drive (in LibertyBSD or OpenBSD)
------------------------------------------------

If you downloaded your ISO on a LibertyBSD or OpenBSD system, here is
how to create the bootable FreeBSD USB drive:

Connect the USB drive. Check dmesg:

    $ dmesg | tail

Check to confirm which drive it is, for example, if you think its sd3:

    $ disklabel sd3

Check that it wasn't automatically mounted. If it was, unmount it. For
example:

    $ doas umount /dev/sd3i

dmesg told you what device it is. Overwrite the drive, writing the
FreeBSD installer to it with dd. For example:

    $ doas dd if=freebsd.img of=/dev/rsdXc bs=1M; sync

You should now be able to boot the installer from your USB drive.
Continue reading, for information about how to do that.

Prepare the USB drive (in GNU+Linux)
------------------------------------

If you downloaded your ISO on a GNU+Linux system, here is how to create
the bootable FreeBSD USB drive:

Connect the USB drive. Check dmesg:

    $ dmesg
Check lsblk to confirm which drive it is:

    $ lsblk

Check that it wasn't automatically mounted. If it was, unmount it. For
example:

    $ sudo umount /dev/sdX\*
    # umount /dev/sdX\*

dmesg told you what device it is. Overwrite the drive, writing your
distro ISO to it with dd. For example:

    $ sudo dd if=freebsd.img of=/dev/sdX bs=8M; sync
    # dd if=freebsd.img of=/dev/sdX bs=8M; sync

You should now be able to boot the installer from your USB drive.
Continue reading, for information about how to do that.

Installing FreeBSD without full disk encryption
-----------------------------------------------

Press C in GRUB to access the command line:

    grub> kfreebsd (usb0,gpt3)/boot/kernel/kernel
    grub> set FreeBSD.vfs.mountfrom=ufs:/dev/da1p3\
    grub> boot

It will start booting into the FreeBSD installer. Follow the normal
process for installing FreeBSD.

Installing FreeBSD with full disk encryption
--------------------------------------------

TODO

Booting
-------

TODO

Configuring Grub
----------------

TODO

Troubleshooting
===============

Most of these issues occur when using libreboot with coreboot's 'text
mode' instead of the coreboot framebuffer. This mode is useful for
booting payloads like memtest86+ which expect text-mode, but for FreeBSD
it can be problematic when they are trying to switch to a framebuffer
because it doesn't exist.

In most cases, you should use the vesafb ROM images. Example filename:
libreboot\_ukdvorak\_vesafb.rom.

won't boot\...something about file not found
---------------------------------------------

Your device names (i.e. usb0, usb1, sd0, sd1, wd0, ahci0, hd0, etc) and
numbers may differ. Use TAB completion.

Copyright © 2016 Leah Rowe <info@minifree.org>\
Copyright © 2016 Scott Bonds <scott@ggr.com>\
This page is available under the [CC BY SA 4.0](../cc-by-sa-4.0.txt)


code:
---
title: BSD projects
...

This section relates to dealing with BSD projects: preparing bootable
USB drives, changing the default GRUB menu and so on.

**This section is only for the \*GRUB\* payload. For depthcharge,
instructions have yet to be written.**

-   [How to install NetBSD on a libreboot system](netbsd.md)
-   [How to install LibertyBSD or OpenBSD on a libreboot
    system](openbsd.md)

-   [How to install FreeBSD on a libreboot system](freebsd.md)

Copyright © 2016 Scott Bonds <scott@ggr.com>\
This page is available under the [CC BY SA 4.0](../cc-by-sa-4.0.txt)


code:
---
title: How to install NetBSD on a libreboot system
...

This section relates to preparing, booting and installing NetBSD on your
libreboot system, using nothing more than a USB flash drive (and *dd*).
They've only been tested on a librebooted ThinkPad X60.

It is expected that you use text mode in libreboot (txtmode images), for
the early boot process in NetBSD. **Suspend/hibernate is broken,
according to at least 1 user.**

Thanks go to ioxcide in [this Reddit
post](https://www.reddit.com/r/BSD/comments/53jt70/libreboot_and_bsds/)
for the initial instructions.

-   [Prepare the USB drive (in NetBSD)](#prepare)
-   [Installing NetBSD without full disk encryption](#noencryption)
-   [Installing NetBSD with full disk encryption](#encryption)
-   [Booting](#booting)
-   [Configuring Grub](#configuring_grub)
-   [Troubleshooting](#troubleshooting)

**This section is only for the GRUB payload. For depthcharge (used on
CrOS devices in libreboot), instructions have yet to be written in the
libreboot documentation.**

netbsd.iso is the installation image for NetBSD. Adapt the filename
accordingly, for your version of NetBSD.

Prepare the USB drive (in NetBSD)
---------------------------------

[This
page](https://wiki.netbsd.org/tutorials/how_to_install_netbsd_from_an_usb_memory_stick/)
on the NetBSD website shows how to create a NetBSD bootable USB drive
from within NetBSD itself. You should use the *dd* method documented
there.

Prepare the USB drive (in FreeBSD)
----------------------------------

[This page](https://www.freebsd.org/doc/handbook/bsdinstall-pre.html) on
the FreeBSD website shows how to create a bootable USB drive for
installing FreeBSD. Use the *dd* on that page. You can also use the same
instructions with a NetBSD ISO image.

Prepare the USB drive (in LibertyBSD or NetBSD)
-----------------------------------------------

If you downloaded your ISO on a LibertyBSD or NetBSD system, here is how
to create the bootable NetBSD USB drive:

Connect the USB drive. Check dmesg:

    $ dmesg | tail

Check to confirm which drive it is, for example, if you think its sd3:

    $ disklabel sd3

Check that it wasn't automatically mounted. If it was, unmount it. For
example:

    $ doas umount /dev/sd3i

dmesg told you what device it is. Overwrite the drive, writing the
NetBSD installer to it with dd. For example:

    $ doas netbsd.iso of=/dev/rsdXc bs=1M; sync

You should now be able to boot the installer from your USB drive.
Continue reading, for information about how to do that.

Prepare the USB drive (in GNU+Linux)
------------------------------------

If you downloaded your ISO on a GNU+Linux system, here is how to create
the bootable NetBSD USB drive:

Connect the USB drive. Check dmesg:

    $ dmesg
Check lsblk to confirm which drive it is:

    $ lsblk

Check that it wasn't automatically mounted. If it was, unmount it. For
example:

    $ sudo umount /dev/sdX\*
    # umount /dev/sdX\*

dmesg told you what device it is. Overwrite the drive, writing your
distro ISO to it with dd. For example:

    $ sudo dd if=install60.fs of=/dev/sdX bs=8M; sync
    # dd if=netbsd.iso of=/dev/sdX bs=8M; sync

You should now be able to boot the installer from your USB drive.
Continue reading, for information about how to do that.

Installing NetBSD without full disk encryption
----------------------------------------------

You might have to use an external USB keyboard during the installation.
Press C to access the GRUB terminal.

    grub> knetbsd -r sd0a (usb0,netbsd1)/netbsd
    grub> boot

It will start booting into the NetBSD installer. Follow the normal
process for installing NetBSD.

Installing NetBSD with full disk encryption
-------------------------------------------

TODO

Booting
-------

Press C in GRUB to access the command line:

    grub> knetbsd -r wd0a (ahci0,netbsd1)/netbsd
    grub> boot

NetBSD will start booting. Yay!

Configuring Grub
----------------

If you don't want to drop to the GRUB command line and type in a
command to boot NetBSD every time, you can create a GRUB configuration
that's aware of your NetBSD installation and that will automatically be
used by libreboot.

On your NetBSD root partition, create the **/grub** directory and add
the file **libreboot\_grub.cfg** to it. Inside the
**libreboot\_grub.cfg** add these lines:

**default=0 timeout=3 menuentry "NetBSD" {\
    knetbsd -r wd0a (ahci0,netbsd1)/netbsd\
}\
**

The next time you boot, you'll see the old Grub menu for a few seconds,
then you'll see the a new menu with only NetBSD on the list. After 3
seconds NetBSD will boot, or you can hit enter to boot.

Troubleshooting
===============

Most of these issues occur when using libreboot with coreboot's 'text
mode' instead of the coreboot framebuffer. This mode is useful for
booting payloads like memtest86+ which expect text-mode, but for NetBSD
it can be problematic when they are trying to switch to a framebuffer
because it doesn't exist.

In most cases, you should use the vesafb ROM images. Example filename:
libreboot\_ukdvorak\_vesafb.rom.

won't boot\...something about file not found
---------------------------------------------

Your device names (i.e. usb0, usb1, sd0, sd1, wd0, ahci0, hd0, etc) and
numbers may differ. Use TAB completion.

Copyright © 2016 Leah Rowe <info@minifree.org>\
Copyright © 2016 Scott Bonds <scott@ggr.com>\
This page is available under the [CC BY SA 4.0](../cc-by-sa-4.0.txt)


code:
---
title: How to install LibertyBSD or OpenBSD on a libreboot system
...

NOTE: This guide was written for OpenBSD by the person who contributed
it, but the libreboot project recommends LibertyBSD. LibertyBSD is a
version of OpenBSD without proprietary software in the repositories
(OpenBSD distributes firmware blobs for devices inside its kernel). Go
to the [LibertyBSD website](http://libertybsd.net/) -- TODO: test on
LibertyBSD and prioritise that in this guide.

This section relates to preparing, booting and installing OpenBSD on
your libreboot system, using nothing more than a USB flash drive (and
*dd*). They've only been tested on a Lenovo ThinkPad x200.

-   [Prepare the USB drive (in OpenBSD)](#prepare)
-   [Installing OpenBSD without full disk encryption](#noencryption)
-   [Installing OpenBSD with full disk encryption](#encryption)
-   [Booting](#booting)
-   [Configuring Grub](#configuring_grub)
-   [Troubleshooting](#troubleshooting)

**This section is only for the GRUB payload. For depthcharge (used on
CrOS devices in libreboot), instructions have yet to be written in the
libreboot documentation.**

install60.fs is the installation image for OpenBSD 6.0. Adapt the
filename accordingly, for a different OpenBSD version or LibertyBSD.

Prepare the USB drive (in LibertyBSD or OpenBSD)
------------------------------------------------

If you downloaded your ISO on a LibertyBSD or OpenBSD system, here is
how to create the bootable LibertyBSD/OpenBSD USB drive:

Connect the USB drive. Check dmesg:

    $ dmesg | tail

Check to confirm which drive it is, for example, if you think its sd3:

    $ disklabel sd3

Check that it wasn't automatically mounted. If it was, unmount it. For
example:

    $ doas umount /dev/sd3i

dmesg told you what device it is. Overwrite the drive, writing the
OpenBSD installer to it with dd. For example:

    $ doas dd if=install60.fs of=/dev/rsdXc bs=1M; sync

You should now be able to boot the installer from your USB drive.
Continue reading, for information about how to do that.

Prepare the USB drive (in NetBSD)
---------------------------------

[This
page](https://wiki.netbsd.org/tutorials/how_to_install_netbsd_from_an_usb_memory_stick/)
on the NetBSD website shows how to create a NetBSD bootable USB drive
from within NetBSD itself. You should use the *dd* method documented
there. This will also work with the OpenBSD image.

Prepare the USB drive (in FreeBSD)
----------------------------------

[This page](https://www.freebsd.org/doc/handbook/bsdinstall-pre.md) on
the FreeBSD website shows how to create a bootable USB drive for
installing FreeBSD. Use the *dd* on that page. You can also use the same
instructions with a OpenBSD ISO image.

Prepare the USB drive (in GNU+Linux)
------------------------------------

If you downloaded your ISO on a GNU+Linux system, here is how to create
the bootable OpenBSD USB drive:

Connect the USB drive. Check dmesg:

    $ dmesg
Check lsblk to confirm which drive it is:

    $ lsblk

Check that it wasn't automatically mounted. If it was, unmount it. For
example:

    $ sudo umount /dev/sdX\*
    # umount /dev/sdX\*

dmesg told you what device it is. Overwrite the drive, writing your
distro ISO to it with dd. For example:

    $ sudo dd if=install60.fs of=/dev/sdX bs=8M; sync
    # dd if=install60.fs of=/dev/sdX bs=8M; sync

You should now be able to boot the installer from your USB drive.
Continue reading, for information about how to do that.

Installing OpenBSD without full disk encryption
-----------------------------------------------

Press C in GRUB to access the command line:

    grub> kopenbsd (usb0,openbsd1)/6.0/amd64/bsd.rd
    grub> boot

It will start booting into the OpenBSD installer. Follow the normal
process for installing OpenBSD.

Installing OpenBSD with full disk encryption
--------------------------------------------

Not working. You can modify the above procedure (installation w/o
encryption) to install OpenBSD using full disk encryption, and it
appears to work, except that its not yet clear how to actually *boot* an
OpenBSD+FDE installation using libreboot+Grub2. If you get it working,
please let us know.

If booting in text mode (framebuffer mode might also work), it might be
possible to chainload the OpenBSD or LibertyBSD bootloader from the MBR
section on the internal storage device. This way, it would be possible
to boot with an encrypted OpenBSD or LibertyBSD installation. Please let
us know (contact details are on the libreboot homepage) if you get it
working this way.

Alternatively, it would be good to port OpenBSD either natively as a
coreboot payload, or port it to libpayload (payload library in coreboot;
it has a basic C library and a few functions for certain operations e.g.
text/bitmap). **This would be ideal, because then it would be possible
to boot a truly fully encrypted OpenBSD or LibertyBSD installation, by
putting everything in the flash chip.**

Alternatively, modifying GRUB to support booting fully encrypted OpenBSD
installations would be possible, but probably not feasible; it's an
alien codebase to the OpenBSD project, not tightly integrated and the
OpenBSD bootloader already works.

Booting
-------

Press C in GRUB to access the command line:

    grub> kopenbsd -r sd0a (ahci0,openbsd1)/bsd
    grub> boot

OpenBSD will start booting. Yay!

Configuring Grub
----------------

If you don't want to drop to the GRUB command line and type in a
command to boot OpenBSD every time, you can create a GRUB configuration
that's aware of your OpenBSD installation and that will automatically
be used by libreboot.

On your OpenBSD root partition, create the **/grub** directory and add
the file **libreboot\_grub.cfg** to it. Inside the
**libreboot\_grub.cfg** add these lines:

**default=0 timeout=3 menuentry "OpenBSD" {\
    kopenbsd -r sd0a (ahci0,openbsd1)/bsd\
}\
**

The next time you boot, you'll see the old Grub menu for a few seconds,
then you'll see the a new menu with only OpenBSD on the list. After 3
seconds OpenBSD will boot, or you can hit enter to boot.

Troubleshooting
===============

Most of these issues occur when using libreboot with coreboot's 'text
mode' instead of the coreboot framebuffer. This mode is useful for
booting payloads like memtest86+ which expect text-mode, but for OpenBSD
it can be problematic when they are trying to switch to a framebuffer
because it doesn't exist.

In most cases, you should use the vesafb ROM images. Example filename:
libreboot\_ukdvorak\_vesafb.rom.

won't boot\...something about file not found
---------------------------------------------

Your device names (i.e. usb0, usb1, sd0, sd1, wd0, ahci0, hd0, etc) and
numbers may differ. Use TAB completion.

Copyright © 2016 Scott Bonds <scott@ggr.com>\
Copyright © 2016 Leah Rowe <info@minifree.org>\
This page is available under the [CC BY SA 4.0](../cc-by-sa-4.0.txt)