;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Ludovic Courtès ;;; ;;; 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 . (define-module (tests-openpgp) #:use-module (guix openpgp) #:use-module (gcrypt base16) #:use-module (gcrypt hash) #:use-module (gcrypt pk-crypto) #:use-module (ice-9 binary-ports) #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) #:use-module (srfi srfi-71)) (define %radix-64-sample ;; Example of Radix-64 encoding from Section 6.6 of RFC4880. "\ -----BEGIN PGP MESSAGE----- Version: OpenPrivacy 0.99 yDgBO22WxBHv7O8X7O/jygAEzol56iUKiXmV+XmpCtmpqQUKiQrFqclFqUDBovzS vBSFjNSiVHsuAA== =njUN -----END PGP MESSAGE-----\n") (define %radix-64-sample/crc-mismatch ;; This time with a wrong CRC24 value. "\ -----BEGIN PGP MESSAGE----- yDgBO22WxBHv7O8X7O/jygAEzol56iUKiXmV+XmpCtmpqQUKiQrFqclFqUDBovzS vBSFjNSiVHsuAA== =AAAA -----END PGP MESSAGE-----\n") (define %binary-sample ;; Same message as %radix-64-sample, decoded into bytevector. (base16-string->bytevector "c838013b6d96c411efecef17ecefe3ca0004ce8979ea250a897995f979a9\ 0ad9a9a9050a890ac5a9c945a940c1a2fcd2bc14858cd4a2547b2e00")) (define %civodul-fingerprint "3CE4 6455 8A84 FDC6 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012-2024 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/>.

(unsetenv "http_proxy")

(define-module (test-derivations)
  #:use-module (guix derivations)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module ((gcrypt hash) #:prefix gcrypt:)
  #:use-module (guix base32)
  #:use-module ((guix git) #:select (with-repository))
  #:use-module (guix tests)
  #:use-module (guix tests git)
  #:use-module (guix tests http)
  #:use-module ((guix packages) #:select (package-derivation base32))
  #:use-module ((guix build utils)
                #:select (executable-file? strip-store-file-name))
  #:use-module ((guix hash) #:select (file-hash*))
  #:use-module ((git oid) #:select (oid->string))
  #:use-module ((git reference) #:select (reference-name->oid))
  #:use-module (gnu packages bootstrap)
  #:use-module ((gnu packages guile) #:select (guile-1.8))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match))

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

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

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

(define* (directory-contents dir #:optional (slurp get-bytevector-all))
  "Return an alist representing the contents of DIR."
  (define prefix-len (string-length dir))
  (sort (file-system-fold (const #t)                   ; enter?
                          (lambda (path stat result)   ; leaf
                            (alist-cons (string-drop path prefix-len)
                                        (call-with-input-file path slurp)
                                        result))
                          (lambda (path stat result) result)      ; down
                          (lambda (path stat result) result)      ; up
                          (lambda (path stat result) result)      ; skip
                          (lambda (path stat errno result) result) ; error
                          '()
                          dir)
        (lambda (e1 e2)
          (string<? (car e1) (car e2)))))


(test-begin "derivations")

(test-assert "parse & export"
  (let* ((f  (search-path %load-path "tests/test.drv"))
         (b1 (call-with-input-file f get-bytevector-all))
         (d1 (read-derivation (open-bytevector-input-port b1)
                              identity))
         (b2 (call-with-bytevector-output-port (cut write-derivation d1 <>)))
         (d2 (read-derivation (open-bytevector-input-port b2)
                              identity)))
    (and (equal? b1 b2)
         (equal? d1 d2))))

(test-skip (if %store 0 12))

(test-assert "add-to-store, flat"
  ;; Use 'readlink*' in case spec.scm is a symlink, as is the case when Guile
  ;; was installed with Stow.
  (let* ((file (readlink*
                (search-path %load-path "language/tree-il/spec.scm")))
         (drv  (add-to-store %store "flat-test" #f "sha256" file)))
    (and (eq? 'regular (stat:type (stat drv)))
         (valid-path? %store drv)
         (equal? (call-with-input-file file get-bytevector-all)
                 (call-with-input-file drv get-bytevector-all)))))

(test-assert "add-to-store, recursive"
  (let* ((dir (dirname
               (readlink* (search-path %load-path
                                       "language/tree-il/spec.scm"))))
         (drv (add-to-store %store "dir-tree-test" #t "sha256" dir)))
    (and (eq? 'directory (stat:type (stat drv)))
         (valid-path? %store drv)
         (equal? (directory-contents dir)
                 (directory-contents drv)))))

(test-assert "derivation with no inputs"
  (let* ((builder  (add-text-to-store %store "my-builder.sh"
                                      "echo hello, world\n"
                                      '()))
         (drv      (derivation %store "foo"
                               %bash `("-e" ,builder)
                               #:env-vars '(("HOME" . "/homeless")))))
    (and (store-path? (derivation-file-name drv))
         (valid-path? %store (derivation-file-name drv)))))

(test-assert "build derivation with 1 source"
  (let* ((builder (add-text-to-store %store "my-builder.sh"
                                     "echo hello, world > \"$out\"\n"
                                     '()))
         (drv     (derivation %store "foo"
                              %bash `(,builder)
                              #:env-vars '(("HOME" . "/homeless")
                                           ("zzz"  . "Z!")
                                           ("AAA"  . "A!"))
                              #:sources `(,%bash ,builder)))
         (succeeded?
          (build-derivations %store (list drv))))
    (and succeeded?
         (let ((path (derivation->output-path drv)))
           (and (valid-path? %store path)
                (string=? (call-with-input-file path read-line)
                          "hello, world"))))))

(test-assert "derivation fails but keep going"
  ;; In keep-going mode, 'build-derivations' should fail because of D1, but it
  ;; must return only after D2 has succeeded.
  (with-store store
    (let* ((d1 (derivation %store "fails"
                           %bash `("-c" "false")
                           #:sources (list %bash)))
           (d2 (build-expression->derivation %store "sleep-then-succeed"
                                             `(begin
                                                ,(random-text)
                                                ;; XXX: Hopefully that's long
                                                ;; enough that D1 has already
                                                ;; failed.
                                                (sleep 2)
                                                (mkdir %output)))))
      (set-build-options %store
                         #:use-substitutes? #f
                         #:keep-going? #t)
      (guard (c ((store-protocol-error? c)
                 (and (= 100 (store-protocol-error-status c))
                      (string-contains (store-protocol-error-message c)
                                       (derivation-file-name d1))
                      (not (valid-path? %store (derivation->output-path d1)))
                      (valid-path? %store (derivation->output-path d2)))))
        (build-derivations %store (list d1 d2))
        #f))))

(test-assert "identical files are deduplicated"
  ;; Note: DATA must be longer than %DEDUPLICATION-MINIMUM-SIZE.
  (let* ((data    (make-string 9000 #\a))
         (build1  (add-text-to-store %store "one.sh"
                                     (string-append "echo -n " data
                                                    " > \"$out\"\n")
                                     '()))
         (build2  (add-text-to-store %store "two.sh"