[jackhill/guix/guix.git] / tests / pack.scm

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

(define-module (test-pack)
  #:use-module (guix scripts pack)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix profiles)
  #:use-module (guix packages)
  #:use-module (guix monads)
  #:use-module (guix grafts)
  #:use-module (guix tests)
  #:use-module (guix gexp)
  #:use-module (gnu packages bootstrap)
  #:use-module ((gnu packages compression) #:select (squashfs-tools))
  #:use-module (srfi srfi-64))

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

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

(define-syntax-rule (test-assertm name store exp)
  (test-assert name
    (let ((guile (package-derivation store %bootstrap-guile)))
      (run-with-store store exp
                      #:guile-for-build guile))))

(define %gzip-compressor
  ;; Compressor that uses the bootstrap 'gzip'.
  ((@ (guix scripts pack) compressor) "gzip"
   "gz"
   #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n")))

(define %tar-bootstrap %bootstrap-coreutils&co)

\f
(test-begin "pack")

(unless (network-reachable?) (test-skip 1))
(test-assertm "self-contained-tarball" %store
  (mlet* %store-monad
      ((profile (profile-derivation (packages->manifest
                                     (list %bootstrap-guile))
                                    #:hooks '()
                                    #:locales? #f))
       (tarball (self-contained-tarball "pack" profile
                                        #:symlinks '(("/bin/Guile"
                                                      -> "bin/guile"))
                                        #:compressor %gzip-compressor
                                        #:archiver %tar-bootstrap))
       (check   (gexp->derivation
                 "check-tarball"
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (guix build utils)
                                    (srfi srfi-1))

                       (define store
                         ;; The unpacked store.
                         (string-append "." (%store-directory) "/"))

                       (define (canonical? file)
                         ;; Return #t if FILE is read-only and its mtime is 1.
                         (let ((st (lstat file)))
                           (or (not (string-prefix? store file))
                               (eq? 'symlink (stat:type st))
                               (and (= 1 (stat:mtime st))
                                    (zero? (logand #o222
                                                   (stat:mode st)))))))

                       (define bin
                         (string-append "." #$profile "/bin"))

                       (setenv "PATH"
                               (string-append #$%tar-bootstrap "/bin"))
                       (system* "tar" "xvf" #$tarball)
                       (mkdir #$output)
                       (exit
                        (and (file-exists? (string-append bin "/guile"))
                             (file-exists? store)
                             (every canonical?
                                    (find-files "." (const #t)
                                                #:directories? #t))
                             (string=? (string-append #$%bootstrap-guile "/bin")
                                       (readlink bin))
                             (string=? (string-append ".." #$profile
                                                      "/bin/guile")
                                       (readlink "bin/Guile")))))))))
    (built-derivations (list check))))

;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes.  Thus,
;; run it on the user's store, if it's available, on the grounds that these
;; dependencies may be already there, or we can get substitutes or build them
;; quite inexpensively; see <https://bugs.gnu.org/32184>.

(with-external-store store
  (unless store (test-skip 1))
  (test-assertm "self-contained-tarball + localstatedir" store
    (mlet* %store-monad
        ((guile   (set-guile-for-build (default-guile)))
         (profile (profile-derivation (packages->manifest
                                       (list %bootstrap-guile))
                                      #:hooks '()
                                      #:locales? #f))
         (tarball (self-contained-tarball "tar-pack" profile
                                          #:localstatedir? #t))
         (check   (gexp->derivation
                   "check-tarball"
                   #~(let ((bin (string-append "." #$profile "/bin")))
                       (setenv "PATH"
                               (string-append #$%tar-bootstrap "/bin"))
                       (system* "tar" "xvf" #$tarball)
                       (mkdir #$output)
                       (exit
                        (and (file-exists? "var/guix/db/db.sqlite")
                             (string=? (string-append #$%bootstrap-guile "/bin")
                                       (readlink bin))))))))
      (built-derivations (list check))))

  (unless store (test-skip 1))
  (test-assertm "docker-image + localstatedir" store
    (mlet* %store-monad
        ((guile   (set-guile-for-build (default-guile)))
         (profile (profile-derivation (packages->manifest
                                       (list %bootstrap-guile))
                                      #:hooks '()
                                      #:locales? #f))
         (tarball (docker-image "docker-pack" profile
                                #:symlinks '(("/bin/Guile" -> "bin/guile"))
                                #:localstatedir? #t))
         (check   (gexp->derivation
                   "check-tarball"
                   (with-imported-modules '((guix build utils))
                     #~(begin
                         (use-modules (guix build utils)
                                      (ice-9 match))

                         (define bin
                           (string-append "." #$profile "/bin"))

                         (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
                         (mkdir "base")
                         (with-directory-excursion "base"
                           (invoke "tar" "xvf" #$tarball))

                         (match (find-files "base" "layer.tar")
                           ((layer)
                            (invoke "tar" "xvf" layer)))

                         (when
                          (and (file-exists? (string-append bin "/guile"))
                               (file-exists? "var/guix/db/db.sqlite")
                               (file-is-directory? "tmp")
                               (string=? (string-append #$%bootstrap-guile "/bin")
                                         (pk 'binlink (readlink bin)))
                               (string=? (string-append #$profile "/bin/guile")
                                         (pk 'guilelink (readlink "bin/Guile"))))
                          (mkdir #$output)))))))
      (built-derivations (list check))))

  (unless store (test-skip 1))
  (test-assertm "squashfs-image + localstatedir" store
    (mlet* %store-monad
        ((guile   (set-guile-for-build (default-guile)))
         (profile (profile-derivation (packages->manifest
                                       (list %bootstrap-guile))
                                      #:hooks '()
                                      #:locales? #f))
         (image   (squashfs-image "squashfs-pack" profile
                                  #:symlinks '(("/bin" -> "bin"))
                                  #:localstatedir? #t))
         (check   (gexp->derivation
                   "check-tarball"
                   (with-imported-modules '((guix build utils))
                     #~(begin
                         (use-modules (guix build utils)
                                      (ice-9 match))

                         (define bin
                           (string-append "." #$profile "/bin"))

                         (setenv "PATH"
                                 (string-append #$squashfs-tools "/bin"))
                         (invoke "unsquashfs" #$image)
                         (with-directory-excursion "squashfs-root"
                           (when (and (file-exists? (string-append bin
                                                                   "/guile"))
                                      (file-exists? "var/guix/db/db.sqlite")
                                      (string=? (string-append #$%bootstrap-guile "/bin")
                                                (pk 'binlink (readlink bin)))

                                      ;; This is a relative symlink target.
                                      (string=? (string-drop
                                                 (string-append #$profile "/bin")
                                                 1)
                                                (pk 'guilelink (readlink "bin"))))
                             (mkdir #$output))))))))
      (built-derivations (list check)))))

(test-end)

;; Local Variables:
;; eval: (put 'test-assertm 'scheme-indent-function 2)
;; End:
Commit	Line	Data
850edd77	1	;;; GNU Guix --- Functional package management for GNU
9c2e5856	2	;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
44057a46	3	;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
850edd77 LC	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	(define-module (test-pack)
	21	#:use-module (guix scripts pack)
	22	#:use-module (guix store)
	23	#:use-module (guix derivations)
	24	#:use-module (guix profiles)
f5a2fb1b	25	#:use-module (guix packages)
850edd77 LC	26	#:use-module (guix monads)
	27	#:use-module (guix grafts)
	28	#:use-module (guix tests)
	29	#:use-module (guix gexp)
	30	#:use-module (gnu packages bootstrap)
3c45b53e	31	#:use-module ((gnu packages compression) #:select (squashfs-tools))
850edd77 LC	32	#:use-module (srfi srfi-64))
850edd77 LC	33
b27ef1d4 LC	34	(define %store
	35	(open-connection-for-tests))
	36
850edd77 LC	37	;; Globally disable grafts because they can trigger early builds.
	38	(%graft? #f)
	39
19c924af	40	(define-syntax-rule (test-assertm name store exp)
850edd77	41	(test-assert name
f5a2fb1b LC	42	(let ((guile (package-derivation store %bootstrap-guile)))
	43	(run-with-store store exp
	44	#:guile-for-build guile))))
850edd77 LC	45
	46	(define %gzip-compressor
	47	;; Compressor that uses the bootstrap 'gzip'.
	48	((@ (guix scripts pack) compressor) "gzip"
48b44430 LC	49	"gz"
48b44430 LC	50	#~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n")))
850edd77 LC	51
	52	(define %tar-bootstrap %bootstrap-coreutils&co)
	53
	54	\f
	55	(test-begin "pack")
	56
b27ef1d4 LC	57	(unless (network-reachable?) (test-skip 1))
	58	(test-assertm "self-contained-tarball" %store
	59	(mlet* %store-monad
	60	((profile (profile-derivation (packages->manifest
	61	(list %bootstrap-guile))
	62	#:hooks '()
	63	#:locales? #f))
	64	(tarball (self-contained-tarball "pack" profile
	65	#:symlinks '(("/bin/Guile"
	66	-> "bin/guile"))
	67	#:compressor %gzip-compressor
	68	#:archiver %tar-bootstrap))
	69	(check (gexp->derivation
	70	"check-tarball"
72dc64f8 LC	71	(with-imported-modules '((guix build utils))
	72	#~(begin
	73	(use-modules (guix build utils)
	74	(srfi srfi-1))
	75
	76	(define store
	77	;; The unpacked store.
	78	(string-append "." (%store-directory) "/"))
	79
	80	(define (canonical? file)
	81	;; Return #t if FILE is read-only and its mtime is 1.
	82	(let ((st (lstat file)))
	83	(or (not (string-prefix? store file))
	84	(eq? 'symlink (stat:type st))
	85	(and (= 1 (stat:mtime st))
	86	(zero? (logand #o222
	87	(stat:mode st)))))))
	88
	89	(define bin
	90	(string-append "." #$profile "/bin"))
	91
	92	(setenv "PATH"
	93	(string-append #$%tar-bootstrap "/bin"))
	94	(system* "tar" "xvf" #$tarball)
	95	(mkdir #$output)
	96	(exit
	97	(and (file-exists? (string-append bin "/guile"))
	98	(file-exists? store)
	99	(every canonical?
	100	(find-files "." (const #t)
	101	#:directories? #t))
	102	(string=? (string-append #$%bootstrap-guile "/bin")
	103	(readlink bin))
	104	(string=? (string-append ".." #$profile
	105	"/bin/guile")
	106	(readlink "bin/Guile")))))))))
b27ef1d4	107	(built-derivations (list check))))
850edd77	108
f5a2fb1b LC	109	;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
	110	;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus,
	111	;; run it on the user's store, if it's available, on the grounds that these
	112	;; dependencies may be already there, or we can get substitutes or build them
	113	;; quite inexpensively; see <https://bugs.gnu.org/32184>.
	114
	115	(with-external-store store
1ff53787 LC	116	(unless store (test-skip 1))
	117	(test-assertm "self-contained-tarball + localstatedir" store
	118	(mlet* %store-monad
	119	((guile (set-guile-for-build (default-guile)))
	120	(profile (profile-derivation (packages->manifest
	121	(list %bootstrap-guile))
	122	#:hooks '()
	123	#:locales? #f))
	124	(tarball (self-contained-tarball "tar-pack" profile
	125	#:localstatedir? #t))
	126	(check (gexp->derivation
	127	"check-tarball"
	128	#~(let ((bin (string-append "." #$profile "/bin")))
	129	(setenv "PATH"
	130	(string-append #$%tar-bootstrap "/bin"))
	131	(system* "tar" "xvf" #$tarball)
	132	(mkdir #$output)
	133	(exit
	134	(and (file-exists? "var/guix/db/db.sqlite")
	135	(string=? (string-append #$%bootstrap-guile "/bin")
	136	(readlink bin))))))))
	137	(built-derivations (list check))))
	138
f5a2fb1b LC	139	(unless store (test-skip 1))
	140	(test-assertm "docker-image + localstatedir" store
	141	(mlet* %store-monad
	142	((guile (set-guile-for-build (default-guile)))
	143	(profile (profile-derivation (packages->manifest
	144	(list %bootstrap-guile))
	145	#:hooks '()
	146	#:locales? #f))
	147	(tarball (docker-image "docker-pack" profile
	148	#:symlinks '(("/bin/Guile" -> "bin/guile"))
	149	#:localstatedir? #t))
	150	(check (gexp->derivation
	151	"check-tarball"
	152	(with-imported-modules '((guix build utils))
	153	#~(begin
	154	(use-modules (guix build utils)
	155	(ice-9 match))
	156
	157	(define bin
	158	(string-append "." #$profile "/bin"))
	159
	160	(setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
	161	(mkdir "base")
	162	(with-directory-excursion "base"
	163	(invoke "tar" "xvf" #$tarball))
	164
	165	(match (find-files "base" "layer.tar")
	166	((layer)
	167	(invoke "tar" "xvf" layer)))
	168
	169	(when
	170	(and (file-exists? (string-append bin "/guile"))
	171	(file-exists? "var/guix/db/db.sqlite")
7979a287	172	(file-is-directory? "tmp")
f5a2fb1b LC	173	(string=? (string-append #$%bootstrap-guile "/bin")
	174	(pk 'binlink (readlink bin)))
	175	(string=? (string-append #$profile "/bin/guile")
	176	(pk 'guilelink (readlink "bin/Guile"))))
	177	(mkdir #$output)))))))
598a6b87 LC	178	(built-derivations (list check))))
	179
	180	(unless store (test-skip 1))
	181	(test-assertm "squashfs-image + localstatedir" store
	182	(mlet* %store-monad
	183	((guile (set-guile-for-build (default-guile)))
	184	(profile (profile-derivation (packages->manifest
	185	(list %bootstrap-guile))
	186	#:hooks '()
	187	#:locales? #f))
	188	(image (squashfs-image "squashfs-pack" profile
	189	#:symlinks '(("/bin" -> "bin"))
	190	#:localstatedir? #t))
	191	(check (gexp->derivation
	192	"check-tarball"
	193	(with-imported-modules '((guix build utils))
	194	#~(begin
	195	(use-modules (guix build utils)
	196	(ice-9 match))
	197
	198	(define bin
	199	(string-append "." #$profile "/bin"))
	200
	201	(setenv "PATH"
3c45b53e	202	(string-append #$squashfs-tools "/bin"))
598a6b87 LC	203	(invoke "unsquashfs" #$image)
	204	(with-directory-excursion "squashfs-root"
	205	(when (and (file-exists? (string-append bin
	206	"/guile"))
	207	(file-exists? "var/guix/db/db.sqlite")
	208	(string=? (string-append #$%bootstrap-guile "/bin")
	209	(pk 'binlink (readlink bin)))
9c2e5856 LC	210
	211	;; This is a relative symlink target.
	212	(string=? (string-drop
	213	(string-append #$profile "/bin")
	214	1)
598a6b87 LC	215	(pk 'guilelink (readlink "bin"))))
598a6b87 LC	216	(mkdir #$output))))))))
f5a2fb1b LC	217	(built-derivations (list check)))))
f5a2fb1b LC	218
850edd77	219	(test-end)
19c924af LC	220
	221	;; Local Variables:
	222	;; eval: (put 'test-assertm 'scheme-indent-function 2)
	223	;; End: