code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-gnu-maintenance)
  #:use-module (guix gnu-maintenance)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(test-begin "gnu-maintenance")

(test-assert "release-file?"
  (and (every (lambda (project+file)
                (apply release-file? project+file))
              '(("gcc" "gcc-5.3.0.tar.bz2")
                ("texmacs" "TeXmacs-1.0.7.9-src.tar.gz")
                ("icecat" "icecat-38.4.0-gnu1.tar.bz2")
                ("mit-scheme" "mit-scheme-9.2.tar.gz")
                ("mediainfo" "mediainfo_20.09.tar.xz")
                ("exiv2" "exiv2-0.27.3-Source.tar.gz")
                ("mpg321" "mpg321_0.3.2.orig.tar.gz")
                ("bvi" "bvi-1.4.1.src.tar.gz")
                ("hostscope" "hostscope-V2.1.tgz")))
       (every (lambda (project+file)
                (not (apply release-file? project+file)))
              '(("guile" "guile-www-1.1.1.tar.gz")
                ("guile" "guile-2.0.11.tar.gz.sig")
                ("mit-scheme" "mit-scheme-9.2-i386.tar.gz")
                ("mit-scheme" "mit-scheme-9.2-doc-pdf.tar.gz")
                ("gnutls" "gnutls-3.2.18-w32.zip")))))

(test-assert "tarball->version"
  (let ((tarball->version (@@ (guix gnu-maintenance) tarball->version)))
    (every (match-lambda
             ((file version)
              (equal? (tarball->version file) version)))
           '(("coreutils-8.32.tar.gz" "8.32")
             ("mediainfo_20.09.tar.xz" "20.09")
             ("exiv2-0.27.3-Source.tar.gz" "0.27.3")
             ("mpg321_0.3.2.orig.tar.gz" "0.3.2")
             ("bvi-1.4.1.src.tar.gz" "1.4.1")))))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Mark H Weaver <mhw@netris.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-grafts)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix derivations)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix grafts)
  #:use-module (guix tests)
  #:use-module (gnu packages bootstrap)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 vlist))

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

(define (bootstrap-binary name)
  (let ((bin (search-bootstrap-binary name (%current-system))))
    (and %store
         (add-to-store %store name #t "sha256" bin))))

(define %bash
  (bootstrap-binary "bash"))
(define %mkdir
  (bootstrap-binary "mkdir"))

(test-begin "grafts")

(test-equal "graft-derivation, grafted item is a direct dependency"
  '((type . graft) (graft (count . 2)))
  (let* ((build `(begin
                   (mkdir %output)
                   (chdir %output)
                   (symlink %output "self")
                   (call-with-output-file "text"
                     (lambda (output)
                       (format output "foo/~a/bar" ,%mkdir)))
                   (symlink ,%bash "sh")))
         (orig  (build-expression->derivation %store "grafted" build
                                              #:inputs `(("a" ,%bash)
                                                         ("b" ,%mkdir))))
         (one   (add-text-to-store %store "bash" "fake bash"))
         (two   (build-expression->derivation %store "mkdir"
                                              '(call-with-output-file %output
                                                 (lambda (port)
                                                   (display "fake mkdir" port)))))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement one))
                                          (graft
                                            (origin %mkdir)
                                            (replacement two))))))
    (and (build-derivations %store (list grafted))
         (let ((properties (derivation-properties grafted))
               (two        (derivation->output-path two))
               (grafted    (derivation->output-path grafted)))
           (and (string=? (format #f "foo/~a/bar" two)
                          (call-with-input-file (string-append grafted "/text")
                            get-string-all))
                (string=? (readlink (string-append grafted "/sh")) one)
                (string=? (readlink (string-append grafted "/self"))
                          grafted)
                properties)))))

(test-assert "graft-derivation, grafted item uses a different name"
  (let* ((build   `(begin
                     (mkdir %output)
                     (chdir %output)
                     (symlink %output "self")
                     (symlink ,%bash "sh")))
         (orig    (build-expression->derivation %store "grafted" build
                                                #:inputs `(("a" ,%bash))))
         (repl    (add-text-to-store %store "BaSH" "fake bash"))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement repl))))))
    (and (build-derivations %store (list grafted))
         (let ((grafted (derivation->output-path grafted)))
           (and (string=? (readlink (string-append grafted "/sh")) repl)
                (string=? (readlink (string-append grafted "/self"))
                          grafted))))))

;; Make sure 'derivation-file-name' always gets to see an absolute file name.
(fluid-set! %file-port-name-canonicalization 'absolute)

(test-assert "graft-derivation, grafted item is an indirect dependency"
  (let* ((build `(begin
                   (mkdir %output)
                   (chdir %output)
                   (symlink %output "self")
                   (call-with-output-file "text"
                     (lambda (output)
                       (format output "foo/~a/bar" ,%mkdir)))
                   (symlink ,%bash "sh")))
         (dep   (build-expression->derivation %store "dep" build
                                              #:inputs `(("a" ,%bash)
                                                         ("b" ,%mkdir))))
         (orig  (build-expression->derivation %store "thing"
                                              '(symlink
                                                (assoc-ref %build-inputs
                                                           "dep")
                                                %output)
                                              #:inputs `(("dep" ,dep))))
         (one   (add-text-to-store %store "bash" "fake bash"))
         (two   (build-expression->derivation %store "mkdir"
                                              '(call-with-output-file %output
                                                 (lambda (port)
                                                   (display "fake mkdir" port)))))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement one))
                                          (graft
                                            (origin %mkdir)
                                            (replacement two))))))
    (and (build-derivations %store (list grafted))
         (let* ((two     (derivation->output-path two))
                (grafted (derivation->output-path grafted))
                (dep     (readlink grafted)))
           (and (string=? (format #f "foo/~a/bar" two)
                          (call-with-input-file (string-append dep "/text")
                            get-string-all))
                (string=? (readlink (string-append dep "/sh")) one)
                (string=? (readlink (string-append dep "/self")) dep)
                (equal? (references %store grafted) (list dep))
                (lset= string=?
                       (list one two dep)
                       (references %store dep)))))))

(test-assert "graft-derivation, preserve empty directories"
  (run-with-store %store
    (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
                         (graft -> (graft
                                     (origin %bash)
                                     (replacement fake)))
                         (drv     (gexp->derivation
                                   "to-graft"
                                   (with-imported-modules '((guix build utils))
                                     #~(begin
                                         (use-modules (guix build utils))
                                         (mkdir-p (string-append #$output
                                                                 "/a/b/c/d"))
                                         (symlink #$%bash
                                                  (string-append #$output
                                                                 "/bash"))))))
                         (grafted ((store-lift graft-derivation) drv
                                   (list graft)))
                         (_       (built-derivations (list grafted)))
                         (out ->  (derivation->output-path grafted)))
      (return (and (string=? (readlink (string-append out "/bash"))
                             fake)
                   (file-is-directory? (string-append out "/a/b/c/d")))))))

(test-assert "graft-derivation, no dependencies on grafted output"
  (run-with-store %store
    (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
                         (graft -> (graft
                                     (origin %bash)
                                     (replacement fake)))
                         (drv     (gexp->derivation "foo" #~(mkdir #$output)))
                         (grafted ((store-lift graft-derivation) drv
                                   (list graft))))
      (return (eq? grafted drv)))))

(test-assert "graft-derivation, multiple outputs"
  (let* ((build `(begin
                   (symlink (assoc-ref %build-inputs "a")
                            (assoc-ref %outputs "one"))
                   (symlink (assoc-ref %outputs "one")
                            (assoc-ref %outputs "two"))))
         (orig  (build-expression->derivation %store "grafted" build
                                              #:inputs `(("a" ,%bash))
                                              #:outputs '("one" "two")))
         (repl  (add-text-to-store %store "bash" "fake bash"))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement repl))))))
    (and (build-derivations %store (list grafted))
         (let ((one (derivation->output-path grafted "one"))
               (two (derivation->output-path grafted "two")))
           (and (string=? (readlink one) repl)
                (string=? (readlink two) one))))))

(test-assert "graft-derivation, replaced derivation has multiple outputs"
  ;; Here we have a replacement just for output "one" of P1 and not for the
  ;; other output.  Make sure the graft for P1:one correctly applies to the
  ;; dependents of P1.  See <http://bugs.gnu.org/24712>.
  (let* ((p1  (build-expression->derivation
               %store "p1"
               `(let ((one (assoc-ref %outputs "one"))
                      (two (assoc-ref %outputs "two")))
                  (mkdir one)
                  (mkdir two))
               #:outputs '("one" "two")))
         (p1r (build-expression->derivation
               %store "P1"
               `(let ((other (assoc-ref %outputs "ONE")))
                  (mkdir other)
                  (call-with-output-file (string-append other "/replacement")
                    (const #t)))
               #:outputs '("ONE")))
         (p2  (build-expression->derivation
               %store "p2"
               `(let ((out (assoc-ref %outputs "aaa")))
                  (mkdir (assoc-ref %outputs "zzz"))
                  (mkdir out) (chdir out)
                  (symlink (assoc-ref %build-inputs "p1:one") "one")
                  (symlink (assoc-ref %build-inputs "p1:two") "two"))
               #:outputs '("aaa" "zzz")
               #:inputs `(("p1:one" ,p1 "one")
                          ("p1:two" ,p1 "two"))))
         (p3  (build-expression->derivation
               %store "p3"
               `(symlink (assoc-ref %build-inputs "p2:aaa")
                         (assoc-ref %outputs "out"))
               #:inputs `(("p2:aaa" ,p2 "aaa")
                          ("p2:zzz" ,p2 "zzz"))))
         (p1g (graft
                (origin p1)
                (origin-output "one")
                (replacement p1r)
                (replacement-output "ONE")))
         (p3d (graft-derivation %store p3 (list p1g))))

    (and (not (find (lambda (input)
                      ;; INPUT should not be P2:zzz since the result of P3
                      ;; does not depend on it.  See
                      ;; <http://bugs.gnu.org/24886>.
                      (and (string=? (derivation-input-path input)
                                     (derivation-file-name p2))
                           (member "zzz"
                                   (derivation-input-sub-derivations input))))
                    (derivation-inputs p3d)))

         (build-derivations %store (list p3d))
         (let ((out (derivation->output-path (pk 'p2d p3d))))
           (and (not (string=? (readlink out)
                               (derivation->output-path p2 "aaa")))
                (string=? (derivation->output-path p1 "two")
                          (readlink (string-append out "/two")))
                (file-exists? (string-append out "/one/replacement")))))))

(test-assert "graft-derivation with #:outputs"
  ;; Call 'graft-derivation' with a narrowed set of outputs passed as
  ;; #:outputs.
  (let* ((p1  (build-expression->derivation
               %store "p1"
               `(let ((one (assoc-ref %outputs "one"))
                      (two (assoc-ref %outputs "two")))
                  (mkdir one)
                  (mkdir two))
               #:outputs '("one" "two")))
         (p1r (build-expression->derivation
               %store "P1"
               `(let ((other (assoc-ref %outputs "ONE")))
                  (mkdir other)
                  (call-with-output-file (string-append other "/replacement")
                    (const #t)))
               #:outputs '("ONE")))
         (p2  (build-expression->derivation
               %store "p2"
               `(let ((aaa (assoc-ref %outputs "aaa"))
                      (zzz (assoc-ref %outputs "zzz")))
                  (mkdir zzz) (chdir zzz)
                  (mkdir aaa) (chdir aaa)
                  (symlink (assoc-ref %build-inputs "p1:two") "two"))
               #:outputs '("aaa" "zzz")
               #:inputs `(("p1:one" ,p1 "one")
                          ("p1:two" ,p1 "two"))))
         (p1g (graft
                (origin p1)
                (origin-output "one")
                (replacement p1r)
                (replacement-output "ONE")))
         (p2g (graft-derivation %store p2 (list p1g)
                                #:outputs '("aaa"))))
    ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft.
    (eq? p2g p2)))

(test-equal "graft-derivation, unused outputs not depended on"
  '("aaa")

  ;; Make sure that the result of 'graft-derivation' does not pull outputs
  ;; that are irrelevant to the grafting process.  See
  ;; <http://bugs.gnu.org/24886>.
  (let* ((p1  (build-expression->derivation
               %store "p1"
               `(let ((one (assoc-ref %outputs "one"))
                      (two (assoc-ref %outputs "two")))
                  (mkdir one)
                  (mkdir two))
               #:outputs '("one" "two")))
         (p1r (build-expression->derivation
               %store "P1"
               `(let ((other (assoc-ref %outputs "ONE")))
                  (mkdir other)
                  (call-with-output-file (string-append other "/replacement")
                    (const #t)))
               #:outputs '("ONE")))
         (p2  (build-expression->derivation
               %store "p2"
               `(let ((aaa (assoc-ref %outputs "aaa"))
                      (zzz (assoc-ref %outputs "zzz")))
                  (mkdir zzz) (chdir zzz)
                  (symlink (assoc-ref %build-inputs "p1:two") "two")
                  (mkdir aaa) (chdir aaa)
                  (symlink (assoc-ref %build-inputs "p1:one") "one"))
               #:outputs '("aaa" "zzz")
               #:inputs `(("p1:one" ,p1 "one")
                          ("p1:two" ,p1 "two"))))
         (p1g (graft
                (origin p1)
                (origin-output "one")
                (replacement p1r)
                (replacement-output "ONE")))
         (p2g (graft-derivation %store p2 (list p1g)
                                #:outputs '("aaa"))))

    ;; Here P2G should only depend on P1:one and P1R:one; it must not depend
    ;; on P1:two or P1R:two since these are unused in the grafting process.
    (and (not (eq? p2g p2))
         (let* ((inputs      (derivation-inputs p2g))
                (match-input (lambda (drv)
                               (lambda (input)
                                 (string=? (derivation-input-path input)
                                           (derivation-file-name drv)))))
                (p1-inputs   (filter (match-input p1) inputs))
                (p1r-inputs  (filter (match-input p1r) inputs))
                (p2-inputs   (filter (match-input p2) inputs)))
           (and (equal? p1-inputs
                        (list (derivation-input p1 '("one"))))
                (equal? p1r-inputs
                        (list (derivation-input p1r '("ONE"))))
                (equal? p2-inputs
                        (list (derivation-input p2 '("aaa"))))
                (derivation-output-names p2g))))))

(test-assert "graft-derivation, renaming"         ;<http://bugs.gnu.org/23132>
  (let* ((build `(begin
                   (use-modules (guix build utils))
                   (mkdir-p (string-append (assoc-ref %outputs "out") "/"
                                           (assoc-ref %build-inputs "in")))))
         (orig  (build-expression->derivation %store "thing-to-graft" build
                                              #:modules '((guix build utils))
                                              #:inputs `(("in" ,%bash))))
         (repl  (add-text-to-store %store "bash" "fake bash"))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement repl))))))
    (and (build-derivations %store (list grafted))
         (let ((out (derivation->output-path grafted)))
           (file-is-directory? (string-append out "/" repl))))))

(test-assert "graft-derivation, grafts are not shadowed"
  ;; We build a DAG as below, where dotted arrows represent replacements and
  ;; solid arrows represent dependencies:
  ;;
  ;;  P1  ·············>  P1R
  ;;  |\__________________.
  ;;  v                   v
  ;;  P2  ·············>  P2R
  ;;  |
  ;;  v
  ;;  P3
  ;;
  ;; We want to make sure that the two grafts we want to apply to P3 are
  ;; honored and not shadowed by other computed grafts.
  (let* ((p1     (build-expression->derivation
                  %store "p1"
                  '(mkdir (assoc-ref %outputs "out"))))
         (p1r    (build-expression->derivation
                  %store "P1"
                  '(let ((out (assoc-ref %outputs "out")))
                     (mkdir out)
                     (call-with-output-file (string-append out "/replacement")
                       (const #t)))))
         (p2     (build-expression->derivation
                  %store "p2"
                  `(let ((out (assoc-ref %outputs "out")))
                     (mkdir out)
                     (chdir out)
                     (symlink (assoc-ref %build-inputs "p1") "p1"))
                  #:inputs `(("p1" ,p1))))
         (p2r    (build-expression->derivation
                  %store "P2"
                  `(let ((out (assoc-ref %outputs "out")))
                     (mkdir out)
                     (chdir out)
                     (symlink (assoc-ref %build-inputs "p1") "p1")
                     (call-with-output-file (string-append out "/replacement")
                       (const #t)))
                  #:inputs `(("p1" ,p1))))
         (p3     (build-expression->derivation
                  %store "p3"
                  `(let ((out (assoc-ref %outputs "out")))
                     (mkdir out)
                     (chdir out)
                     (symlink (assoc-ref %build-inputs "p2") "p2"))
                  #:inputs `(("p2" ,p2))))
         (p1g    (graft
                   (origin p1)
                   (replacement p1r)))
         (p2g    (graft
                   (origin p2)
                   (replacement (graft-derivation %store p2r (list p1g)))))
         (p3d    (graft-derivation %store p3 (list p1g p2g))))
    (and (build-derivations %store (list p3d))
         (let ((out (derivation->output-path (pk p3d))))
           ;; Make sure OUT refers to the replacement of P2, which in turn
           ;; refers to the replacement of P1, as specified by P1G and P2G.
           ;; It used to be the case that P2G would be shadowed by a simple
           ;; P2->P2R graft, which is not what we want.
           (and (file-exists? (string-append out "/p2/replacement"))
                (file-exists? (string-append out "/p2/p1/replacement")))))))

(define buffer-size
  ;; Must be equal to REQUEST-SIZE in 'replace-store-references'.
  (expt 2 20))

(test-equal "replace-store-references, <http://bugs.gnu.org/28212>"
  (string-append (make-string (- buffer-size 47) #\a)
                 "/gnu/store/" (make-string 32 #\8)
                 "-SoMeTHiNG"
                 (list->string (map integer->char (iota 77 33))))

  ;; Create input data where the right-hand-size of the dash ("-something"
  ;; here) goes beyond the end of the internal buffer of
  ;; 'replace-store-references'.
  (let* ((content     (string-append (make-string (- buffer-size 47) #\a)
                                     "/gnu/store/" (make-string 32 #\7)
                                     "-something"
                                     (list->string
                                      (map integer->char (iota 77 33)))))
         (replacement (alist->vhash
                       `((,(make-string 32 #\7)
                          . ,(string->utf8 (string-append
                                            (make-string 32 #\8)
                                            "-SoMeTHiNG")))))))
    (call-with-output-string
      (lambda (output)
        ((@@ (guix build graft) replace-store-references)
         (open-input-string content) output
         replacement
         "/gnu/store")))))

(define (insert-nuls char-size str)
  (string-join (map string (string->list str))
               (make-string (- char-size 1) #\nul)))

(define (nuls-to-underscores s)
  (string-replace-substring s "\0" "_"))

(define (annotate-buffer-boundary s)
  (string-append (string-take s buffer-size)
                 "|"
                 (string-drop s buffer-size)))

(define (abbreviate-leading-fill s)
  (let ((s* (string-trim s #\=)))
    (format #f "[~a =s]~a"
            (- (string-length s)
               (string-length s*))
            s*)))

(define (prettify-for-display s)
  (abbreviate-leading-fill
   (annotate-buffer-boundary
    (nuls-to-underscores s))))

(define (two-sample-refs-with-gap char-size1 char-size2 gap offset
                                  char1 name1 char2 name2)
  (string-append
   (make-string (- buffer-size offset) #\=)
   (insert-nuls char-size1
                (string-append "/gnu/store/" (make-string 32 char1) name1))
   gap
   (insert-nuls char-size2
                (string-append "/gnu/store/" (make-string 32 char2) name2))
   (list->string (map integer->char (iota 77 33)))))

(define (sample-map-entry old-char new-char new-name)
  (cons (make-string 32 old-char)
        (string->utf8 (string-append (make-string 32 new-char)
                                     new-name))))

(define (test-two-refs-with-gap char-size1 char-size2 gap offset)
  (test-equal
      (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a"
              char-size1 char-size2 gap offset)
    (prettify-for-display
     (two-sample-refs-with-gap char-size1 char-size2 gap offset
                               #\6 "-BlahBlaH"
                               #\8"-SoMeTHiNG"))
    (prettify-for-display
     (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset
                                               #\5 "-blahblah"
                                               #\7 "-something"))
            (replacement (alist->vhash
                          (list (sample-map-entry #\5 #\6 "-BlahBlaH")
                                (sample-map-entry #\7 #\8 "-SoMeTHiNG")))))
       (call-with-output-string
         (lambda (output)
           ((@@ (guix build graft) replace-store-references)
            (open-input-string content) output
            replacement
            "/gnu/store")))))))

(for-each (lambda (char-size1)
            (for-each (lambda (char-size2)
                        (for-each (lambda (gap)
                                    (for-each (lambda (offset)
                                                (test-two-refs-with-gap char-size1
                                                                        char-size2
                                                                        gap
                                                                        offset))
                                              ;; offsets to test
                                              (map (lambda (i)
                                                     (+ i (* 40 char-size1)))
                                                   (iota 30))))
                                  ;; gaps
                                  '("" "-" " " "a")))
                      ;; char-size2 values to test
                      '(1 2)))
          ;; char-size1 values to test
          '(1 2 4))

(test-end)

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 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-graph)
  #:use-module (guix tests)
  #:use-module (guix graph)
  #:use-module (guix scripts graph)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix grafts)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system trivial)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bootstrap)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages libunistring)
  #:use-module (gnu packages bootstrap)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

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

;; Globally disable grafts because they can trigger early builds.
(%graft? #f)

(define (make-recording-backend)
  "Return a <graph-backend> and a thunk that returns the recorded nodes and
edges."
  (let ((nodes '())
        (edges '()))
    (define (record-node id label port)
      (set! nodes (cons (list id label) nodes)))
    (define (record-edge source target port)
      (set! edges (cons (list source target) edges)))
    (define (return)
      (values (reverse nodes) (reverse edges)))

    (values (graph-backend "test" "This is the test backend."
                           (const #t) (const #t)
                           record-node record-edge)
            return)))

(define (package->tuple package)
  "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
  (list (object-address package)
        (package-full-name package)))

(define (edge->tuple source target)
  "Likewise for an edge from SOURCE to TARGET."
  (list (object-address source)
        (object-address target)))

(test-begin "graph")

(test-assert "package DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((p1 (dummy-package "p1"))
           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
           (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
      (run-with-store %store
        (export-graph (list p3) 'port
                      #:node-type %package-node-type
                      #:backend backend))
      ;; We should see nothing more than these 3 packages.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? nodes (map package->tuple (list p3 p2 p1)))
             (equal? edges
                     (map edge->tuple
                          (list p3 p3 p2)
                          (list p2 p1 p1))))))))

(test-assert "reverse package DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (export-graph (list libunistring) 'port
                    #:node-type %reverse-package-node-type
                    #:backend backend))
    ;; We should see nothing more than these 3 packages.
    (let-values (((nodes edges) (nodes+edges)))
      (and (member (package->tuple guile-2.0) nodes)
           (->bool (member (edge->tuple libunistring guile-2.0) edges))))))

(test-assert "bag-emerged DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((o        (dummy-origin (method (lambda _
                                             (text-file "foo" "bar")))))
           (p        (dummy-package "p" (source o)))
           (implicit (map (match-lambda
                            ((label package) package)
                            ((label package output) package))
                          (standard-packages))))
      (run-with-store %store
        (export-graph (list p) 'port
                      #:node-type %bag-emerged-node-type
                      #:backend backend))
      ;; We should see exactly P and IMPLICIT, with one edge from P to each
      ;; element of IMPLICIT.  O must not appear among NODES.  Note: IMPLICIT
      ;; contains "glibc" twice, once for "out" and a second time for
      ;; "static", hence the 'delete-duplicates' call below.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? (match nodes
                       (((labels names) ...)
                        names))
                     (map package-full-name
                          (cons p (delete-duplicates implicit))))
             (equal? (match edges
                       (((sources destinations) ...)
                        (zip (map store-path-package-name sources)
                             (map store-path-package-name destinations))))
                     (map (lambda (destination)
                            (list "p-0.drv"
                                  (string-append
                                   (package-full-name destination "-")
                                   ".drv")))
                          implicit)))))))

(test-assert "bag DAG"                            ;a big town in Iraq
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let ((p (dummy-package "p")))
      (run-with-store %store
        (export-graph (list p) 'port
                      #:node-type %bag-node-type
                      #:backend backend))
      ;; We should see P, its implicit inputs as well as the whole DAG, which
      ;; should include bootstrap binaries.
      (let-values (((nodes edges) (nodes+edges)))
        (every (lambda (name)
                 (find (cut string=? name <>)
                       (match nodes
                         (((labels names) ...)
                          names))))
               (match (%bootstrap-inputs)
                 (((labels packages) ...)
                  (map package-full-name (filter package? packages)))))))))

(test-assert "bag DAG, including origins"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((m (lambda* (uri hash-type hash name #:key system)
                (text-file "foo-1.2.3.tar.gz" "This is a fake!")))
           (o (origin
                (method m) (uri "the-uri")
                (sha256
                 (base32
                  "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))))
           (p (dummy-package "p" (source o))))
      (run-with-store %store
        (export-graph (list p) 'port
                      #:node-type %bag-with-origins-node-type
                      #:backend backend))
      ;; We should see O among the nodes, with an edge coming from P.
      (let-values (((nodes edges) (nodes+edges)))
        (run-with-store %store
          (mlet %store-monad ((o* (lower-object o))
                              (p* (lower-object p))
                              (g  (lower-object (default-guile))))
            (return
             (and (find (match-lambda
                          ((file "the-uri") #t)
                          (_                #f))
                        nodes)
                  (find (match-lambda
                          ((source target)
                           (and (string=? source (derivation-file-name p*))
                                (string=? target o*))))
                        edges)

                  ;; There must also be an edge from O to G.
                  (find (match-lambda
                          ((source target)
                           (and (string=? source o*)
                                (string=? target (derivation-file-name g)))))
                        edges)))))))))

(test-assert "reverse bag DAG"
  (let-values (((dune bap ocaml-base)
                (values (specification->package "ocaml4.07-dune")
                        (specification->package "bap")
                        (specification->package "ocaml4.07-base")))
               ((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (export-graph (list dune) 'port
                    #:node-type %reverse-bag-node-type
                    #:backend backend))

    (run-with-store %store
      (mlet %store-monad ((dune-drv       (package->derivation dune))
                          (bap-drv        (package->derivation bap))
                          (ocaml-base-drv (package->derivation ocaml-base)))
        ;; OCAML-BASE uses 'dune-build-system' so DUNE is a direct dependency.
        ;; BAP is much higher in the stack but it should be there.
        (let-values (((nodes edges) (nodes+edges)))
          (return
           (and (member `(,(derivation-file-name bap-drv)
                          ,(package-full-name bap))
                        nodes)
                (->bool (member (map derivation-file-name
                                     (list dune-drv ocaml-base-drv))
                                edges)))))))))

(test-assert "derivation DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
                           (guile (package->derivation %bootstrap-guile))
                           (drv   (gexp->derivation "output"
                                                    #~(symlink #$txt #$output)
                                                    #:guile-for-build
                                                    guile)))
        ;; We should get at least these 3 nodes and corresponding edges.
        (mbegin %store-monad
          (export-graph (list drv) 'port
                        #:node-type %derivation-node-type
                        #:backend backend)
          (let-values (((nodes edges) (nodes+edges)))
            ;; XXX: For some reason we need to throw in some 'basename'.
            (return (and (match nodes
                           (((ids labels) ...)
                            (let ((ids (map basename ids)))
                              (every (lambda (item)
                                       (member (basename item) ids))
                                     (list txt
                                           (derivation-file-name drv)
                                           (derivation-file-name guile))))))
                         (every (cut member <>
                                     (map (lambda (edge)
                                            (map basename edge))
                                          edges))
                                (list (map (compose basename derivation-file-name)
                                           (list drv guile))
                                      (list (basename (derivation-file-name drv))
                                            (basename txt))))))))))))

(test-assert "reference DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
                           (guile (package->derivation %bootstrap-guile))
                           (drv   (gexp->derivation "output"
                                                    #~(symlink #$txt #$output)
                                                    #:guile-for-build
                                                    guile))
                           (out -> (derivation->output-path drv)))
        ;; We should see only OUT and TXT, with an edge from the former to the
        ;; latter.
        (mbegin %store-monad
          (built-derivations (list drv))
          (export-graph (list (derivation->output-path drv)) 'port
                        #:node-type %reference-node-type
                        #:backend backend)
          (let-values (((nodes edges) (nodes+edges)))
            (return
             (and (equal? (match nodes
                            (((ids labels) ...)
                             ids))
                          (list out txt))
                  (equal? edges `((,out ,txt)))))))))))

(test-assert "referrer DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (mlet* %store-monad ((txt   (text-file "referrer-node" (random-text)))
                           (drv   (gexp->derivation "referrer"
                                                    #~(symlink #$txt #$output)))
                           (out -> (derivation->output-path drv)))
        ;; We should see only TXT and OUT, with an edge from the former to the
        ;; latter.
        (mbegin %store-monad
          (built-derivations (list drv))
          (export-graph (list txt) 'port
                        #:node-type %referrer-node-type
                        #:backend backend)
          (let-values (((nodes edges) (nodes+edges)))
            (return
             (and (equal? (match nodes
                            (((ids labels) ...)
                             ids))
                          (list txt out))
                  (equal? edges `((,txt ,out)))))))))))

(test-assert "module graph"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (export-graph '((gnu packages guile)) 'port
                    #:node-type %module-node-type
                    #:backend backend))

    (let-values (((nodes edges) (nodes+edges)))
      (and (member '(gnu packages guile)
                   (match nodes
                     (((ids labels) ...) ids)))
           (->bool (and (member (list '(gnu packages guile)
                                      '(gnu packages libunistring))
                                edges)
                        (member (list '(gnu packages guile)
                                      '(gnu packages bdw-gc))
                                edges)))))))

(test-assert "node-edges"
  (run-with-store %store
    (let ((packages (fold-packages cons '())))
      (mlet %store-monad ((edges (node-edges %package-node-type packages)))
        (return (and (null? (edges hello))
                     (lset= eq?
                            (edges guile-2.0)
                            (match (package-direct-inputs guile-2.0)
                              (((labels packages _ ...) ...)
                               packages)))))))))

(test-assert "node-transitive-edges + node-back-edges"
  (run-with-store %store
    (let ((packages   (fold-packages cons '()))
          (bootstrap? (lambda (package)
                        (string-contains
                         (location-file (package-location package))
                         "bootstrap.scm")))
          (trivial?   (lambda (package)
                        (eq? (package-build-system package)
                             trivial-build-system))))
      (mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
        (let* ((glibc      (canonical-package glibc))
               (dependents (node-transitive-edges (list glibc) edges))
               (diff       (lset-difference eq? packages dependents)))
          ;; All the packages depend on libc, except bootstrap packages and
          ;; some that use TRIVIAL-BUILD-SYSTEM.
          (return (null? (remove (lambda (package)
                                   (or (trivial? package)
                                       (bootstrap? package)))
                                 diff))))))))

(test-assert "node-transitive-edges, no duplicates"
  (run-with-store %store
    (let* ((p0  (dummy-package "p0"))
           (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
           (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
           (p2  (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
      (mlet %store-monad ((edges (node-edges %package-node-type
                                             (list p2 p1a p1b p0))))
        (return (lset= eq? (node-transitive-edges (list p2) edges)
                       (list p1a p1b p0)))))))

(test-assert "node-transitive-edges, references"
  (run-with-store %store
    (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile))
                         (d1 (gexp->derivation "d1"
                                               #~(begin
                                                   (mkdir #$output)
                                                   (symlink #$%bootstrap-guile
                                                            (string-append
                                                             #$output "/l")))))
                         (d2 (gexp->derivation "d2"
                                               #~(begin
                                                   (mkdir #$output)
                                                   (symlink #$d1
                                                            (string-append
                                                             #$output "/l")))))
                         (_  (built-derivations (list d2)))
                         (->node -> (node-type-convert %reference-node-type))
                         (o2      (->node (derivation->output-path d2)))
                         (o1      (->node (derivation->output-path d1)))
                         (o0      (->node (derivation->output-path d0)))
                         (edges   (node-edges %reference-node-type
                                              (append o0 o1 o2)))
                         (reqs    ((store-lift requisites) o2)))
      (return (lset= string=?
                     (append o2 (node-transitive-edges o2 edges)) reqs)))))

(test-equal "node-reachable-count"
  '(3 3)
  (run-with-store %store
    (let* ((p0  (dummy-package "p0"))
           (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
           (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
           (p2  (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
      (mlet* %store-monad ((all -> (list p2 p1a p1b p0))
                           (edges  (node-edges %package-node-type all))
                           (back   (node-back-edges %package-node-type all)))
        (return (list (node-reachable-count (list p2) edges)
                      (node-reachable-count (list p0) back)))))))

(test-equal "shortest-path, packages + derivations"
  '(("p5" "p4" "p1" "p0")
    ("p3" "p2" "p1" "p0")
    #f
    ("p5-0.drv" "p4-0.drv" "p1-0.drv" "p0-0.drv"))
  (run-with-store %store
    (let* ((p0 (dummy-package "p0"))
           (p1 (dummy-package "p1" (inputs `(("p0" ,p0)))))
           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
           (p3 (dummy-package "p3" (inputs `(("p2" ,p2)))))
           (p4 (dummy-package "p4" (inputs `(("p1" ,p1)))))
           (p5 (dummy-package "p5" (inputs `(("p4" ,p4) ("p3" ,p3))))))
      (mlet* %store-monad ((path1 (shortest-path p5 p0 %package-node-type))
                           (path2 (shortest-path p3 p0 %package-node-type))
                           (nope  (shortest-path p3 p4 %package-node-type))
                           (drv5  (package->derivation p5))
                           (drv0  (package->derivation p0))
                           (path3 (shortest-path drv5 drv0
                                                 %derivation-node-type)))
        (return (append (map (lambda (path)
                               (and path (map package-name path)))
                             (list path1 path2 nope))
                        (list (map (node-type-label %derivation-node-type)
                                   path3))))))))

(test-equal "shortest-path, reverse packages"
  '("libffi" "guile" "guile-json")
  (run-with-store %store
    (mlet %store-monad ((path (shortest-path (specification->package "libffi")
                                             guile-json
                                             %reverse-package-node-type)))
      (return (map package-name path)))))

(test-equal "shortest-path, references"
  `(("d2" "d1" ,(package-full-name %bootstrap-guile "-"))
    (,(package-full-name %bootstrap-guile "-") "d1" "d2"))
  (run-with-store %store
    (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile))
                         (d1 (gexp->derivation "d1"
                                               #~(begin
                                                   (mkdir #$output)
                                                   (symlink #$%bootstrap-guile
                                                            (string-append
                                                             #$output "/l")))))
                         (d2 (gexp->derivation "d2"
                                               #~(begin
                                                   (mkdir #$output)
                                                   (symlink #$d1
                                                            (string-append
                                                             #$output "/l")))))
                         (_  (built-derivations (list d2)))
                         (->node -> (node-type-convert %reference-node-type))
                         (o2   (->node (derivation->output-path d2)))
                         (o0   (->node (derivation->output-path d0)))
                         (path (shortest-path (first o2) (first o0)
                                              %reference-node-type))
                         (rpath (shortest-path (first o0) (first o2)
                                               %referrer-node-type)))
      (return (list (map (node-type-label %reference-node-type) path)
                    (map (node-type-label %referrer-node-type) rpath))))))

(test-end "graph")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2018 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-gremlin)
  #:use-module (guix elf)
  #:use-module ((guix utils) #:select (call-with-temporary-directory))
  #:use-module (guix build utils)
  #:use-module (guix build gremlin)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 match))

(define %guile-executable
  (match (false-if-exception (readlink "/proc/self/exe"))
    ((? string? program)
     (and (file-exists? program) (elf-file? program)
          program))
    (_
     #f)))

(define read-elf
  (compose parse-elf get-bytevector-all))

(define c-compiler
  (or (which "gcc") (which "cc") (which "g++")))

(test-begin "gremlin")

(unless %guile-executable (test-skip 1))
(test-assert "elf-dynamic-info-needed, executable"
  (let* ((elf     (call-with-input-file %guile-executable read-elf))
         (dyninfo (elf-dynamic-info elf)))
    (or (not dyninfo)                             ;static executable
        (lset<= string=?
                (list (string-append "libguile-" (effective-version))
                      "libc")
                (map (lambda (lib)
                       (string-take lib (string-contains lib ".so")))
                     (elf-dynamic-info-needed dyninfo))))))

(test-equal "expand-origin"
  '("OOO/../lib"
    "OOO"
    "../OOO/bar/OOO/baz"
    "ORIGIN/foo")
  (map (cut expand-origin <> "OOO")
       '("$ORIGIN/../lib"
         "${ORIGIN}"
         "../${ORIGIN}/bar/$ORIGIN/baz"
         "ORIGIN/foo")))

(unless c-compiler
  (test-skip 1))
(test-equal "strip-runpath"
  "hello\n"
  (call-with-temporary-directory
   (lambda (directory)
     (with-directory-excursion directory
       (call-with-output-file "t.c"
         (lambda (port)
           (display "int main () { puts(\"hello\"); }" port)))
       (invoke c-compiler "t.c"
               "-Wl,--enable-new-dtags" "-Wl,-rpath=/foo" "-Wl,-rpath=/bar")
       (let* ((dyninfo (elf-dynamic-info
                        (parse-elf (call-with-input-file "a.out"
                                     get-bytevector-all))))
              (old     (elf-dynamic-info-runpath dyninfo))
              (new     (strip-runpath "a.out"))
              (new*    (strip-runpath "a.out")))
         (validate-needed-in-runpath "a.out")
         (and (member "/foo" old) (member "/bar" old)
              (not (member "/foo" new))
              (not (member "/bar" new))
              (equal? new* new)
              (let* ((pipe (open-input-pipe "./a.out"))
                     (str  (get-string-all pipe)))
                (close-pipe pipe)
                str)))))))

(test-end "gremlin")


code:
# GNU Guix --- Functional package management for GNU
# Copyright © 2013, 2014, 2015, 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/>.

#
# Test the 'guix archive' command-line utility.
#

guix archive --version

archive="t-archive-$$"
archive_alt="t-archive-alt-$$"
tmpdir="t-archive-dir-$$"
rm -f "$archive" "$archive_alt"
rm -rf "$tmpdir"

trap 'rm -f "$archive" "$archive_alt"; chmod -R +w "$tmpdir"; rm -rf "$tmpdir"' EXIT

guix archive --export guile-bootstrap > "$archive"
guix archive --export guile-bootstrap:out > "$archive_alt"
cmp "$archive" "$archive_alt"

guix archive --export							\
    -e '(@ (gnu packages bootstrap) %bootstrap-guile)' > "$archive_alt"
cmp "$archive" "$archive_alt"

guix archive --export `guix build guile-bootstrap` > "$archive_alt"
cmp "$archive" "$archive_alt"

# Check the exit value upon import.
guix archive --import < "$archive"

! guix archive something-that-does-not-exist

# This one must not be listed as missing.
guix build guile-bootstrap > "$archive"
guix archive --missing < "$archive"
test "`guix archive --missing < "$archive"`" = ""

# Two out of three should be listed as missing.
echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" >> "$archive"
echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar" >> "$archive"
guix archive --missing < "$archive" > "$archive_alt"
echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" > "$archive"
echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar" >> "$archive"
cmp "$archive" "$archive_alt"

# This is not a valid store file name, so an error.
echo something invalid > "$archive"
! guix archive --missing < "$archive"

# Check '--extract'.
guile -c "(use-modules (guix serialization))
  (call-with-output-file \"$archive\"
    (lambda (port)
      (write-file \"$(guix build guile-bootstrap)\" port)))"
guix archive -x "$tmpdir" < "$archive"
test -x "$tmpdir/bin/guile"
test -d "$tmpdir/lib/guile"

# Check '--list'.
guix archive -t < "$archive" | grep "^D /share/guile"
guix archive -t < "$archive" | grep "^x /bin/guile"
guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm"

! echo foo | guix archive --authorize


code:
# GNU Guix --- Functional package management for GNU
# Copyright © 2013, 2014, 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/>.

#
# Test the 'guix authenticate' command-line utility.
#

guix authenticate --version

sig="t-signature-$$"
hash="t-hash-$$"
rm -f "$sig" "$hash"

trap 'rm -f "$sig" "$hash"' EXIT

key="$abs_top_srcdir/tests/signing-key.sec"
key_len="`echo -n $key | wc -c`"

# A hexadecimal string as long as a sha256 hash.
hash="2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"
hash_len="`echo -n $hash | wc -c`"

echo "sign $key_len:$key $hash_len:$hash" | guix authenticate > "$sig"
test -f "$sig"
case "$(cat $sig)" in
    "0 "*) ;;
    *)     echo "broken signature: $(cat $sig)"
	   exit 42;;
esac

# Remove the leading "0".
sed -i "$sig" -e's/^0 //g'

hash2="$(echo verify $(cat "$sig") | guix authenticate)"
test "$(echo $hash2 | cut -d : -f 2)" = "$hash"

# Detect corrupt signatures.
code="$(echo "verify 5:wrong" | guix authenticate | cut -f1 -d ' ')"
test "$code" -ne 0

# Detect invalid signatures.
# The signature has (payload (data ... (hash sha256 #...#))).  We proceed by
# modifying this hash.
sed -i "$sig"											\
    -e's|#[A-Z0-9]\{64\}#|#0000000000000000000000000000000000000000000000000000000000000000#|g'
code="$(echo "verify $(cat $sig)" | guix authenticate | cut -f1 -d ' ')"
test "$code" -ne 0

# Make sure byte strings are correctly encoded.  The hash string below is
# "café" repeated 8 times.  Libgcrypt would normally choose to write it as a
# string rather than a hex sequence.  We want that string to be Latin-1
# encoded independently of the current locale: <https://bugs.gnu.org/43421>.
hash="636166e9636166e9636166e9636166e9636166e9636166e9636166e9636166e9"
latin1_cafe="caf$(printf '\351')"
echo "sign 21:tests/signing-key.sec 64:$hash" | guix authenticate \
    | LC_ALL=C grep "hash sha256 \"$latin1_cafe"

# Test for <http://bugs.gnu.org/17312>: make sure 'guix authenticate' produces
# valid signatures when run in the C locale.
hash="5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c"

LC_ALL=C
export LC_ALL

echo "sign $key_len:$key $hash_len:$hash" | guix authenticate > "$sig"

# Remove the leading "0".
sed -i "$sig" -e's/^0 //g'

echo "verify $(cat $sig)" | guix authenticate
hash2="$(echo "verify $(cat $sig)" | guix authenticate | cut -f2 -d ' ')"
test "$(echo $hash2 | cut -d : -f 2)" = "$hash"


code:
# GNU Guix --- Functional package management for GNU
# Copyright © 2018, 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/>.

#
# Test 'guix build --with-branch'.
#

guix build --version

# 'guix build --with-branch' requires access to the network to clone the
# Git repository below.

if ! guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
then
    # Skipping.
    exit 77
fi

orig_drv="`guix build guile-gcrypt -d`"
latest_drv="`guix build guile-gcrypt --with-branch=guile-gcrypt=master -d`"
test -n "$latest_drv"
test "$orig_drv" != "$latest_drv"

# FIXME: '-S' currently doesn't work with non-derivation source.
# checkout="`guix build guile-gcrypt --with-branch=guile-gcrypt=master -S`"
checkout="`guix gc --references "$latest_drv" | grep guile-gcrypt | grep -v -E '(-builder|\.drv)'`"
test -d "$checkout"
test -f "$checkout/COPYING"

orig_drv="`guix build guix -d`"
latest_drv="`guix build guix --with-branch=guile-gcrypt=master -d`"
guix gc -R "$latest_drv" | grep guile-gcrypt-git.master
test "$orig_drv" != "$latest_drv"

v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=9e3eacdec1d -d`"
guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.9e3eacd
test "$v0_1_0_drv" != "$latest_drv"
test "$v0_1_0_drv" != "$orig_drv"

v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=v0.1.0 -d`"
guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-0.1.0
guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-8fe64e8 # this is the tag ID
test "$v0_1_0_drv" != "$latest_drv"
test "$v0_1_0_drv" != "$orig_drv"

! guix build guix --with-commit=guile-gcrypt=000 -d


code:
# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
# Copyright © 2021 Chris Marusich <cmmarusich@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/>.

#
# Test the `guix build' command-line utility.
#

guix build --version

# Should fail.
! guix build -e +

# Source-less packages are accepted; they just return nothing.
guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S
test "`guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S`" = ""

# Should pass.
guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' |	\
    grep -e '-guile-'
guix build hello -d |				\
    grep -e '-hello-[0-9\.]\+\.drv$'

# Passing a .drv.
drv="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' -d`"
out="`guix build "$drv"`"
out2="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
test "$out" = "$out2"

# Passing the name of a .drv that doesn't exist.  The daemon should try to
# substitute the .drv.  Here we just look for the "cannot build missing
# derivation" error that indicates that the daemon did try to substitute the
# .drv.
guix build "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo.drv" 2>&1 \
    | grep "missing derivation"

# Passing a URI.
GUIX_DAEMON_SOCKET="file://$GUIX_STATE_DIRECTORY/daemon-socket/socket"	\
guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'

( if GUIX_DAEMON_SOCKET="weird://uri"					\
     guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)';	\
  then exit 1; fi )

# Passing one '-s' flag.
test `guix build sed -s x86_64-linux -d | wc -l` = 1

# Passing multiple '-s' flags.
all_systems="-s x86_64-linux -s i686-linux -s armhf-linux -s aarch64-linux \
-s powerpc64le-linux"
test `guix build sed $all_systems -d | sort -u | wc -l` = 5

# Check there's no weird memoization effect leading to erroneous results.
# See <https://bugs.gnu.org/40482>.
drv1="`guix build sed -s x86_64-linux -s armhf-linux -d | sort`"
drv2="`guix build sed -s armhf-linux -s x86_64-linux -d | sort`"
test "$drv1" = "$drv2"

# Check --sources option with its arguments
module_dir="t-guix-build-$$"
mkdir "$module_dir"
trap "rm -rf $module_dir" EXIT

cat > "$module_dir/foo.scm"<<EOF
(define-module (foo)
  #:use-module (guix tests)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix build-system trivial))

(define-public foo
  (package
    (name "foo")
    (version "42")
    (source (origin
              (method url-fetch)
              (uri "http://www.example.com/foo.tar.gz")
              (sha256
               (base32
                "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))))
    (build-system trivial-build-system)
    (inputs
     (quasiquote (("bar" ,bar))))
    (home-page "www.example.com")
    (synopsis "Dummy package")
    (description "foo is a dummy package for testing.")
    (license #f)))

(define-public bar
  (package
    (name "bar")
    (version "9001")
    (source (origin
              (method url-fetch)
              (uri "http://www.example.com/bar.tar.gz")
              (sha256
               (base32
                "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy"))))
    (build-system trivial-build-system)
    (inputs
     (quasiquote
      (("data" ,(origin
                 (method url-fetch)
                 (uri "http://www.example.com/bar.dat")
                 (sha256
                  (base32
                   "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz")))))))
    (home-page "www.example.com")
    (synopsis "Dummy package")
    (description "bar is a dummy package for testing.")
    (license #f)))

(define-public baz
  (dummy-package "baz" (replacement foo)))

(define-public superseded
  (deprecated-package "superseded" bar))

EOF

GUIX_PACKAGE_PATH="$module_dir"
export GUIX_PACKAGE_PATH

# foo.tar.gz
guix build -d -S foo
guix build -d -S foo | grep -e 'foo\.tar\.gz'

# 'baz' has a replacement so we should be getting the replacement's source.
(unset GUIX_BUILD_OPTIONS;
 test "`guix build -d -S baz`" = "`guix build -d -S foo`")

guix build -d --sources=package foo
guix build -d --sources=package foo | grep -e 'foo\.tar\.gz'

# bar.tar.gz and bar.dat
guix build -d --sources bar
test `guix build -d --sources bar \
      | grep -e 'bar\.tar\.gz' -e 'bar\.dat' \
      | wc -l` -eq 2

# bar.tar.gz and bar.dat
guix build -d --sources=all bar
test `guix build -d --sources bar \
      | grep -e 'bar\.tar\.gz' -e 'bar\.dat' \
      | wc -l` -eq 2

# Should include foo.tar.gz, bar.tar.gz, and bar.dat
guix build -d --sources=transitive foo
test `guix build -d --sources=transitive foo \
      | grep -e 'foo\.tar\.gz' -e 'bar\.tar\.gz' -e 'bar\.dat' \
      | wc -l` -eq 3

# Unbound variable in thunked field.
cat > "$module_dir/foo.scm" <<EOF
(define-module (foo)
  #:use-module (guix tests)
  #:use-module (guix build-system trivial))

(define-public foo
  (dummy-package "package-with-something-wrong"
    (build-system trivial-build-system)
    (inputs (quasiquote (("sed" ,sed))))))  ;unbound variable
EOF

! guix build package-with-something-wrong -n
guix build package-with-something-wrong -n 2> "$module_dir/err" || true
grep "unbound" "$module_dir/err"		     # actual error
grep "forget.*(gnu packages base)" "$module_dir/err" # hint

# Unbound variable at the top level.
cat > "$module_dir/foo.scm" <<EOF
(define-module (foo)
  #:use-module (guix tests))

(define-public foo
  (dummy-package "package-with-something-wrong"
    (build-system gnu-build-system)))      ;unbound variable
EOF

guix build sed -n 2> "$module_dir/err"
grep "unbound" "$module_dir/err"		     # actual error
grep "forget.*(guix build-system gnu)" "$module_dir/err" # hint

rm -f "$module_dir"/*

# Unbound variable: don't suggest modules that do not export the variable.
cat > "$module_dir/aa-private.scm" <<EOF
(define-module (aa-private))
(define make-thing #f)
(set! make-thing make-thing)   ;don't inline
EOF

cat > "$module_dir/bb-public.scm" <<EOF
(define-module (bb-public) #:export (make-thing))
(define make-thing identity)
EOF

cat > "$module_dir/cc-user.scm" <<EOF
;; Make those module available in the global name space.
(load-from-path "aa-private.scm")
(load-from-path "bb-public.scm")

(define-module (cc-user))
(make-thing 42)
EOF
! guix build -f "$module_dir/cc-user.scm" -n 2> "$module_dir/err"
cat "$module_dir/err"
grep "make-thing.*unbound" "$module_dir/err"		 # actual error
grep "forget.*(bb-public)" "$module_dir/err"		 # hint

rm -f "$module_dir"/*

# Wrong 'define-module' clause reported by 'warn-about-load-error'.
cat > "$module_dir/foo.scm" <<EOF
(define-module (something foo)
  #:use-module (guix)
  #:use-module (gnu))
EOF
guix build guile-bootstrap -n 2> "$module_dir/err"
grep "does not match file name" "$module_dir/err"

rm "$module_dir"/*

# Should all return valid log files.
drv="`guix build -d -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
out="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
log="`guix build --log-file $drv`"
echo "$log" | grep log/.*guile.*drv
test -f "$log"
test "`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' --log-file`" \
    = "$log"
test "`guix build --log-file guile-bootstrap`" = "$log"
test "`guix build --log-file $out`" = "$log"

# Should fail because the name/version combination could not be found.
! guix build hello-0.0.1 -n

# Keep a symlink to the result, registered as a root.
result="t-result-$$"
guix build -r "$result"					\
    -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'
test -x "$result/bin/guile"

# Should fail, because $result already exists.
! guix build -r "$result" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'

rm -f "$result"

# Check relative file name canonicalization: <https://bugs.gnu.org/35271>.
mkdir "$result"
guix build -r "$result/x" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'
test -x "$result/x/bin/guile"
rm "$result/x"
rmdir "$result"

# Cross building.
guix build coreutils --target=mips64el-linux-gnu --dry-run --no-substitutes

# Likewise, but with '-e' (see <https://bugs.gnu.org/38093>).
guix build --target=arm-linux-gnueabihf --dry-run \
     -e '(@ (gnu packages base) coreutils)'

# Replacements.
drv1=`guix build guix --with-input=guile@2.0=guile@2.2 -d`
drv2=`guix build guix -d`
test "$drv1" != "$drv2"

drv1=`guix build guile -d`
drv2=`guix build guile --with-input=gimp=ruby -d`
test "$drv1" = "$drv2"

# See <https://bugs.gnu.org/42156>.
drv1=`guix build glib -d`
drv2=`guix build glib -d --with-input=libreoffice=inkscape`
test "$drv1" = "$drv2"

# '--with-graft' should have no effect when using '--no-grafts'.
# See <https://bugs.gnu.org/43890>.
drv1=`guix build inkscape -d --no-grafts`
drv2=`guix build inkscape -d --no-grafts --with-graft=glib=glib-networking`
test "$drv1" = "$drv2"

# Rewriting implicit inputs.
drv1=`guix build hello -d`
drv2=`guix build hello -d --with-input=gcc=gcc-toolchain`
test "$drv1" != "$drv2"
guix gc -R "$drv2" | grep `guix build -d gcc-toolchain`

! guix build guile --with-input=libunistring=something-really-silly

# Deprecated/superseded packages.
test "`guix build superseded -d`" = "`guix build bar -d`"

# Parsing package names and versions.
guix build -n time		# PASS
guix build -n time@1.9		# PASS, version found
! guix build -n time@3.2	# FAIL, version not found
! guix build -n something-that-will-never-exist # FAIL

# Invoking a monadic procedure.
guix build -e "(begin
                 (use-modules (guix gexp))
                 (lambda ()
                   (gexp->derivation \"test\"
                                     (gexp (mkdir (ungexp output))))))" \
   --dry-run

# Running a gexp.
guix build -e '#~(mkdir #$output)' -d
guix build -e '#~(mkdir #$output)' -d | grep 'gexp\.drv'

# Same with a file-like object.
guix build -e '(computed-file "foo" #~(mkdir #$output))' -d
guix build -e '(computed-file "foo" #~(mkdir #$output))' -d | grep 'foo\.drv'

# Building from a package file.
cat > "$module_dir/package.scm"<<EOF
(use-modules (gnu))
(use-package-modules bootstrap)

%bootstrap-guile
EOF
guix build --file="$module_dir/package.scm"

# Building from a monadic procedure file.
cat > "$module_dir/proc.scm"<<EOF
(use-modules (guix gexp))
(lambda ()
  (gexp->derivation "test"
                    (gexp (mkdir (ungexp output)))))
EOF
guix build --file="$module_dir/proc.scm" --dry-run

# Building from a gexp file.
cat > "$module_dir/gexp.scm"<<EOF
(use-modules (guix gexp))

(gexp (mkdir (ungexp output)))
EOF
guix build --file="$module_dir/gexp.scm" -d
guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv'

# Building from a manifest file.
cat > "$module_dir/manifest.scm"<<EOF
(specifications->manifest '("hello" "guix"))
EOF
test `guix build -d --manifest="$module_dir/manifest.scm" \
      | grep -e '-hello-' -e '-guix-' \
      | wc -l` -eq 2

# Building from a manifest that contains a non-package object.
cat > "$module_dir/manifest.scm"<<EOF
(manifest
  (list (manifest-entry (name "foo") (version "0")
			(item (computed-file "computed-thingie"
					     #~(mkdir (ungexp output)))))))
EOF
guix build -d -m "$module_dir/manifest.scm" \
    | grep 'computed-thingie\.drv$'

rm "$module_dir"/*.scm

# Using 'GUIX_BUILD_OPTIONS'.
GUIX_BUILD_OPTIONS="--dry-run --no-grafts"
export GUIX_BUILD_OPTIONS

guix build emacs

GUIX_BUILD_OPTIONS="--something-completely-crazy"
! guix build emacs


code:
# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2014, 2015, 2016, 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/>.

#
# Test the daemon and its interaction with 'guix substitute'.
#

set -e

guix-daemon --version
guix build --version

drv="`guix build emacs -d`"
out="`guile -c '								\
  (use-modules (guix) (guix grafts) (gnu packages emacs))			\
  (define store (open-connection))						\
  (%graft? #f)
  (display (derivation->output-path (package-derivation store emacs)))'`"

hash_part="`basename $out | cut -c 1-32`"
narinfo="$hash_part.narinfo"
substitute_dir="`echo $GUIX_BINARY_SUBSTITUTE_URL | sed -'es,file://,,g'`"

cat > "$substitute_dir/nix-cache-info"<<EOF
StoreDir: `dirname $drv`
WantMassQuery: 0
EOF

cat > "$substitute_dir/$narinfo"<<EOF
StorePath: $out
URL: /nowhere/example.nar
Compression: none
NarSize: 1234
References:
System: `guile -c '(use-modules (guix)) (display (%current-system))'`
Deriver: $drv
EOF

# Remove the cached narinfo.
rm -f "$XDG_CACHE_HOME/guix/substitute/$hash_part"

# Make sure we see the substitute.
guile -c "
  (use-modules (guix))
  (define store (open-connection))
  (set-build-options store #:use-substitutes? #t
                     #:substitute-urls (list \"$GUIX_BINARY_SUBSTITUTE_URL\"))
  (exit (has-substitutes? store \"$out\"))"

# Now, run guix-daemon --no-substitutes.
socket="$GUIX_STATE_DIRECTORY/alternate-socket"
guix-daemon --no-substitutes --listen="$socket" --disable-chroot &
daemon_pid=$!
trap 'kill $daemon_pid' EXIT

# Make sure we DON'T see the substitute.
guile -c "
  (use-modules (guix))
  (define store (open-connection \"$socket\"))

  ;; This setting MUST NOT override the daemon's --no-substitutes.
  (set-build-options store #:use-substitutes? #t
                     #:substitute-urls (list \"$GUIX_BINARY_SUBSTITUTE_URL\"))

  (exit (not (has-substitutes? store \"$out\")))"

kill "$daemon_pid"

# Pass several '--listen' options, and make sure they are all honored.
guix-daemon --disable-chroot --listen="$socket" --listen="$socket-second" \
	    --listen="localhost" --listen="localhost:9876" &
daemon_pid=$!

for uri in "$socket" "$socket-second" \
		     "guix://localhost" "guix://localhost:9876"
do
    GUIX_DAEMON_SOCKET="$uri" guix build guile-bootstrap
done

kill "$daemon_pid"

# Make sure 'profiles/per-user' is created when connecting over TCP.

orig_GUIX_STATE_DIRECTORY="$GUIX_STATE_DIRECTORY"
GUIX_STATE_DIRECTORY="$GUIX_STATE_DIRECTORY-2"

guix-daemon --disable-chroot --listen="localhost:9877" &
daemon_pid=$!

GUIX_DAEMON_SOCKET="guix://localhost:9877"
export GUIX_DAEMON_SOCKET

test ! -d "$GUIX_STATE_DIRECTORY/profiles/per-user"

guix build guile-bootstrap -d

test -d "$GUIX_STATE_DIRECTORY/profiles/per-user/$USER"

kill "$daemon_pid"
unset GUIX_DAEMON_SOCKET
GUIX_STATE_DIRECTORY="$orig_GUIX_STATE_DIRECTORY"

# Check the failed build cache.

guix-daemon --no-substitutes --listen="$socket" --disable-chroot	\
  --cache-failures &
daemon_pid=$!

guile -c "
  (use-modules (guix) (guix grafts) (guix tests) (srfi srfi-34))
  (define store (open-connection-for-tests \"$socket\"))

  ;; Disable grafts to avoid building more than needed.
  (%graft? #f)

  (define (build-without-failing drv)
    (lambda (store)
      (guard (c ((store-protocol-error? c) (values #t store)))
        (build-derivations store (list drv))
        (values #f store))))

  ;; Make sure failed builds are cached and can be removed from
  ;; the cache.
  (run-with-store store
    (mlet* %store-monad ((drv (gexp->derivation \"failure\"
                                                #~(begin
                                                    (ungexp output)
                                                     #f)))
                         (out -> (derivation->output-path drv))
                         (ok?    (build-without-failing drv)))
      ;; Note the mixture of monadic and direct style.  Don't try
      ;; this at home!
      (return (exit (and ok?
                         (equal? (query-failed-paths store) (list out))
                         (begin
                           (clear-failed-paths store (list out))
                           (null? (query-failed-paths store)))))))
    #:guile-for-build (%guile-for-build)) "

kill "$daemon_pid"

# Make sure the daemon's default 'build-cores' setting is honored.

guix-daemon --listen="$socket" --disable-chroot --cores=42 &
daemon_pid=$!

GUIX_DAEMON_SOCKET="$socket" \
guile -c '
  (use-modules (guix) (guix tests))

  (with-store store
    (let* ((build  (add-text-to-store store "build.sh"
                                      "echo $NIX_BUILD_CORES > $out"))
           (bash   (add-to-store store "bash" #t "sha256"
                                 (search-bootstrap-binary "bash"
                                                          (%current-system))))
           (drv    (derivation store "the-thing" bash
                               `("-e" ,build)
                               #:inputs `((,bash) (,build))
                               #:env-vars `(("x" . ,(random-text))))))
      (and (build-derivations store (list drv))
           (exit
            (= 42 (pk (call-with-input-file (derivation->output-path drv)
                        read)))))))'

kill "$daemon_pid"

# Make sure the daemon's default 'timeout' and 'max-silent-time' settings are
# honored.

client_code='
  (use-modules (guix) (guix tests) (srfi srfi-34))

  (with-store store
    (let* ((build  (add-text-to-store store "build.sh"
                                      "while true ; do : ; done"))
           (bash   (add-to-store store "bash" #t "sha256"
                                 (search-bootstrap-binary "bash"
                                                          (%current-system))))
           (drv    (derivation store "the-thing" bash
                               `("-e" ,build)
                               #:inputs `((,bash) (,build))
                               #:env-vars `(("x" . ,(random-text))))))
      (exit (guard (c ((store-protocol-error? c)
                       (->bool
                        (string-contains (pk (store-protocol-error-message c))
                                         "failed"))))
              (build-derivations store (list drv))
              #f))))'

for option in --max-silent-time=1 --timeout=1
do
    guix-daemon --listen="$socket" --disable-chroot "$option" &
    daemon_pid=$!

    GUIX_DAEMON_SOCKET="$socket" guile -c "$client_code"
    kill "$daemon_pid"
done

# Make sure garbage collection from a TCP connection does not work.

tcp_socket="127.0.0.1:9998"
guix-daemon --listen="$tcp_socket" &
daemon_pid=$!

GUIX_DAEMON_SOCKET="guix://$tcp_socket"
export GUIX_DAEMON_SOCKET

! guix gc

unset GUIX_DAEMON_SOCKET
kill "$daemon_pid"

# Log compression.

guix-daemon --listen="$socket" --disable-chroot --debug --log-compression=gzip &
daemon_pid=$!

stamp="compressed-build-log-test-$$-`date +%H%M%S`"
client_code="
  (use-modules (guix) (gnu packages bootstrap))

  (with-store store
    (run-with-store store
      (mlet %store-monad ((drv (lower-object
				(computed-file \"compressed-log-test\"
					       #~(begin
						   (display \"$stamp\")
                                                   (newline)
						   (mkdir #\$output))
					       #:guile %bootstrap-guile))))
	(display (derivation-file-name drv))
	(newline)
	(return #t))))
"

GUIX_DAEMON_SOCKET="$socket"
export GUIX_DAEMON_SOCKET

drv=`guile -c "$client_code"`
guix build "$drv"

log=`guix build "$drv" --log-file`
test -f "$log"
case "$log" in
    *.gz) test "`gunzip -c < "$log"`" = "$stamp" ;;
    *)    false ;;
esac


code:
# GNU Guix --- Functional package management for GNU
# Copyright © 2018 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/>.

#
# Test 'guix describe'.
#

guix describe --version

tmpfile="t-guix-describe-$$"
trap "rm -f $tmpfile" EXIT
rm -f "$tmpfile"

if [ -d "$abs_top_srcdir/.git" ]
then
    # Since we're in a Git checkout, we can at least check that these things
    # work.
    guix describe | grep -i "checkout"
    if git --version > /dev/null 2>&1
    then
	result="`guix describe | grep commit: | cut -d : -f 2-`"
	commit="`git log | head -1 | cut -c 7-`"
	test "x$result" = "x$commit"
    fi
    guix describe -f channels
    case "`guix describe -f channels | grep url`" in
	*"(url \"$abs_top_srcdir\")") true;;
	*) false;;
    esac
else
    exit 77
fi


code:
# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2015, 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/>.

#
# Test the `guix download' command-line utility.
#

guix download --version

# Make sure it fails here.
! guix download http://does.not/exist

! guix download unknown://some/where;

! guix download /does-not-exist

# This one should succeed.
guix download "file://$abs_top_srcdir/README"

# And this one, without the URI scheme.
guix download "$abs_top_srcdir/README"

# This one too, even if it cannot talk to the daemon.
output="t-download-$$"
trap 'rm -f "$output"' EXIT
GUIX_DAEMON_SOCKET="/nowhere" guix download -o "$output" \
		  "file://$abs_top_srcdir/README"
cmp "$output" "$abs_top_srcdir/README"

# This one should fail.
! guix download "file:///does-not-exist" "file://$abs_top_srcdir/README"


code:
# GNU Guix --- Functional package management for GNU
# Copyright © 2015 David Thompson <davet@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/>.

#
# Test 'guix environment'.
#

set -e

guix environment --version

if ! guile -c '((@ (guix scripts environment) assert-container-features))'
then
    # User containers are not supported; skip this test.
    exit 77
fi

tmpdir="t-guix-environment-$$"
trap 'rm -r "$tmpdir"' EXIT

mkdir "$tmpdir"

# Make sure the exit value is preserved.
if guix environment --container --ad-hoc --bootstrap guile-bootstrap \
        -- guile -c '(exit 42)'
then
    false
else
    test $? = 42
fi

# Make sure "localhost" resolves.
guix environment --container --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c '(exit (pair? (getaddrinfo "localhost" "80")))'

# We should get ECONNREFUSED, not ENETUNREACH, which would indicate that "lo"
# is down.
guix environment --container --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c "(exit (= ECONNREFUSED
  (catch 'system-error
    (lambda ()
      (let ((sock (socket AF_INET SOCK_STREAM 0)))
        (connect sock AF_INET INADDR_LOOPBACK 12345)))
    (lambda args
      (pk 'errno (system-error-errno args))))))"

# Make sure '--preserve' is honored.
result="`FOOBAR=42; export FOOBAR; guix environment -C --ad-hoc --bootstrap \
   guile-bootstrap -E ^FOO -- guile -c '(display (getenv \"FOOBAR\"))'`"
test "$result" = "42"

# By default, the UID inside the container should be the same as outside.
uid="`id -u`"
inner_uid="`guix environment -C --ad-hoc --bootstrap guile-bootstrap \
  -- guile -c '(display (getuid))'`"
test $inner_uid = $uid

# When '--user' is passed, the UID should be 1000.  (Note: Use a separate HOME
# so that we don't run into problems when the test directory is under /home.)
export tmpdir
inner_uid="`HOME=$tmpdir guix environment -C --ad-hoc --bootstrap guile-bootstrap \
  --user=gnu-guix -- guile -c '(display (getuid))'`"
test $inner_uid = 1000

if test "x$USER" = "x"; then USER="`id -un`"; fi

# Check whether /etc/passwd and /etc/group are valid.
guix environment -C --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c "(exit (string=? \"$USER\" (passwd:name (getpwuid (getuid)))))"
guix environment -C --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c '(exit (string? (group:name (getgrgid (getgid)))))'
guix environment -C --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c '(use-modules (srfi srfi-1))
                  (exit (every group:name
                               (map getgrgid (vector->list (getgroups)))))'

# Make sure file-not-found errors in mounts are reported.
if guix environment --container --ad-hoc --bootstrap guile-bootstrap \
	--expose=/does-not-exist -- guile -c 1 2> "$tmpdir/error"
then
    false
else
    grep "/does-not-exist" "$tmpdir/error"
    grep "[Nn]o such file" "$tmpdir/error"
fi

# Make sure that the right directories are mapped.
mount_test_code="
(use-modules (ice-9 rdelim)
             (ice-9 match)
             (srfi srfi-1))

(define mappings
  (filter-map (lambda (line)
                (match (string-split line #\space)
                  ;; Empty line.
                  ((\"\") #f)
                  ;; Ignore the root file system.
                  ((_ \"/\" _ _ _ _)
                   #f)
                  ;; Ignore these types of file systems, except if they
                  ;; correspond to a parent file system.
                  ((_ mount (or \"tmpfs\" \"proc\" \"sysfs\" \"devtmpfs\"
                                \"devpts\" \"cgroup\" \"mqueue\") _ _ _)
                   (and (string-prefix? (getcwd) mount)
		        mount))
                  ((_ mount _ _ _ _)
                   mount)))
              (string-split (call-with-input-file \"/proc/mounts\" read-string)
                            #\newline)))

(for-each (lambda (mount)
            (display mount)
            (newline))
          mappings)"

guix environment --container --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c "$mount_test_code" > $tmpdir/mounts

cat "$tmpdir/mounts"
test `wc -l < $tmpdir/mounts` -eq 4

current_dir="`cd $PWD; pwd -P`"
grep -e "$current_dir$" $tmpdir/mounts # current directory
grep $(guix build guile-bootstrap) $tmpdir/mounts
grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash

rm $tmpdir/mounts

# Make sure 'GUIX_ENVIRONMENT' is set to '~/.guix-profile' when requested
# within a container.
(
  linktest='
(exit (and (string=? (getenv "GUIX_ENVIRONMENT")
                     (string-append (getenv "HOME") "/.guix-profile"))
           (string-prefix? "'"$NIX_STORE_DIR"'"
                           (readlink (string-append (getenv "HOME")
                                                    "/.guix-profile")))))'

  cd "$tmpdir" \
     && guix environment --bootstrap --container --link-profile \
             --ad-hoc guile-bootstrap --pure \
             -- guile -c "$linktest"
)

# Test that user can be mocked.
usertest='(exit (and (string=? (getenv "HOME") "/home/foognu")
                     (string=? (passwd:name (getpwuid 1000)) "foognu")
                     (file-exists? "/home/foognu/umock")))'
touch "$tmpdir/umock"
HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \
     --ad-hoc guile-bootstrap --pure \
     --share="$tmpdir/umock" \
     -- guile -c "$usertest"

# if not sharing CWD, chdir home
(
  cd "$tmpdir" \
    && guix environment --bootstrap --container --no-cwd --user=foo  \
            --ad-hoc guile-bootstrap --pure \
            -- /bin/sh -c 'test $(pwd) == "/home/foo" -a ! -d '"$tmpdir"
)

# Check the exit code.

abnormal_exit_code="
(use-modules (system foreign))
;; Purposely make Guile crash with a segfault. :)
(pointer->string (make-pointer 123) 123)"

if guix environment --bootstrap --container \
	--ad-hoc guile-bootstrap -- guile -c "$abnormal_exit_code"
then false;
else
    test $? -gt 127
fi