| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; |
| 4 | ;;; This file is part of GNU Guix. |
| 5 | ;;; |
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 7 | ;;; under the terms of the GNU General Public License as published by |
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 9 | ;;; your option) any later version. |
| 10 | ;;; |
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 14 | ;;; GNU General Public License for more details. |
| 15 | ;;; |
| 16 | ;;; You should have received a copy of the GNU General Public License |
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 18 | |
| 19 | (define-module (test-pack) |
| 20 | #:use-module (guix scripts pack) |
| 21 | #:use-module (guix store) |
| 22 | #:use-module (guix derivations) |
| 23 | #:use-module (guix profiles) |
| 24 | #:use-module (guix monads) |
| 25 | #:use-module (guix grafts) |
| 26 | #:use-module (guix tests) |
| 27 | #:use-module (guix gexp) |
| 28 | #:use-module (gnu packages bootstrap) |
| 29 | #:use-module (srfi srfi-64)) |
| 30 | |
| 31 | (define %store |
| 32 | (open-connection-for-tests)) |
| 33 | |
| 34 | ;; Globally disable grafts because they can trigger early builds. |
| 35 | (%graft? #f) |
| 36 | |
| 37 | (define-syntax-rule (test-assertm name exp) |
| 38 | (test-assert name |
| 39 | (run-with-store %store exp |
| 40 | #:guile-for-build (%guile-for-build)))) |
| 41 | |
| 42 | (define %gzip-compressor |
| 43 | ;; Compressor that uses the bootstrap 'gzip'. |
| 44 | ((@ (guix scripts pack) compressor) "gzip" |
| 45 | "gz" |
| 46 | #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n"))) |
| 47 | |
| 48 | (define %tar-bootstrap %bootstrap-coreutils&co) |
| 49 | |
| 50 | \f |
| 51 | (test-begin "pack") |
| 52 | |
| 53 | (unless (network-reachable?) (test-skip 1)) |
| 54 | (test-assertm "self-contained-tarball" |
| 55 | (mlet* %store-monad |
| 56 | ((profile (profile-derivation (packages->manifest |
| 57 | (list %bootstrap-guile)) |
| 58 | #:hooks '() |
| 59 | #:locales? #f)) |
| 60 | (tarball (self-contained-tarball "pack" profile |
| 61 | #:symlinks '(("/bin/Guile" |
| 62 | -> "bin/guile")) |
| 63 | #:compressor %gzip-compressor |
| 64 | #:tar %tar-bootstrap)) |
| 65 | (check (gexp->derivation |
| 66 | "check-tarball" |
| 67 | #~(let ((guile (string-append "." #$profile "/bin"))) |
| 68 | (setenv "PATH" |
| 69 | (string-append #$%tar-bootstrap "/bin")) |
| 70 | (system* "tar" "xvf" #$tarball) |
| 71 | (mkdir #$output) |
| 72 | (exit |
| 73 | (and (file-exists? (string-append guile "/guile")) |
| 74 | (string=? (string-append #$%bootstrap-guile "/bin") |
| 75 | (readlink guile)) |
| 76 | (string=? (string-append (string-drop guile 1) |
| 77 | "/guile") |
| 78 | (readlink "bin/Guile")))))))) |
| 79 | (built-derivations (list check)))) |
| 80 | |
| 81 | (test-end) |