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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018, 2019, 2020 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 (guix modules)
  #:use-module (gnu packages)
  #:use-module ((gnu packages base) #:select (glibc-utf8-locales))
  #:use-module (gnu packages bootstrap)
  #:use-module ((gnu packages compression) #:select (squashfs-tools))
  #:use-module ((gnu packages guile) #:select (guile-sqlite3))
  #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
  #: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
                    (content (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 "self-contained-tarball + localstatedir, UTF-8 file names" store
    (mlet* %store-monad
        ((guile   (set-guile-for-build (default-guile)))
         (tree    (interned-file-tree
                   `("directory-with-utf8-file-names" directory
                     ("α" regular (data "alpha"))
                     ("λ" regular (data "lambda")))))
         (tarball (self-contained-tarball "tar-pack" tree
                                          #:localstatedir? #t))
         (check   (gexp->derivation
                   "check-tarball"
                   (with-extensions (list guile-sqlite3 guile-gcrypt)
                     (with-imported-modules (source-module-closure
                                             '((guix store database)))
                       #~(begin
                           (use-modules (guix store database)
                                        (rnrs io ports)
                                        (srfi srfi-1))

                           (define (valid-file? basename data)
                             (define file
                               (string-append "./" #$tree "/" basename))

                             (string=? (call-with-input-file (pk 'file file)
                                         get-string-all)
                                       data))

                           (setenv "PATH"
                                   (string-append #$%tar-bootstrap "/bin"))
                           (system* "tar" "xvf" #$tarball)

                           (sql-schema
                            #$(local-file (search-path %load-path
                                                       "guix/store/schema.sql")))
                           (with-database "var/guix/db/db.sqlite" db
                             ;; Make sure non-ASCII file names are properly
                             ;; handled.
                             (setenv "GUIX_LOCPATH"
                                     #+(file-append glibc-utf8-locales
                                                    "/lib/locale"))
                             (setlocale LC_ALL "en_US.utf8")

                             (mkdir #$output)
                             (exit
                              (and (every valid-file?
                                          '("α" "λ")
                                          '("alpha" "lambda"))
                                   (integer? (path-id db #$tree)))))))))))
      (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
b3802495	2	;;; Copyright © 2017, 2018, 2019, 2020 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)
b3802495 LC	30	#:use-module (guix modules)
	31	#:use-module (gnu packages)
	32	#:use-module ((gnu packages base) #:select (glibc-utf8-locales))
850edd77	33	#:use-module (gnu packages bootstrap)
3c45b53e	34	#:use-module ((gnu packages compression) #:select (squashfs-tools))
b3802495 LC	35	#:use-module ((gnu packages guile) #:select (guile-sqlite3))
b3802495 LC	36	#:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
850edd77 LC	37	#:use-module (srfi srfi-64))
850edd77 LC	38
b27ef1d4 LC	39	(define %store
	40	(open-connection-for-tests))
	41
850edd77 LC	42	;; Globally disable grafts because they can trigger early builds.
	43	(%graft? #f)
	44
19c924af	45	(define-syntax-rule (test-assertm name store exp)
850edd77	46	(test-assert name
f5a2fb1b LC	47	(let ((guile (package-derivation store %bootstrap-guile)))
	48	(run-with-store store exp
	49	#:guile-for-build guile))))
850edd77 LC	50
	51	(define %gzip-compressor
	52	;; Compressor that uses the bootstrap 'gzip'.
	53	((@ (guix scripts pack) compressor) "gzip"
48b44430 LC	54	"gz"
48b44430 LC	55	#~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n")))
850edd77 LC	56
	57	(define %tar-bootstrap %bootstrap-coreutils&co)
	58
	59	\f
	60	(test-begin "pack")
	61
b27ef1d4 LC	62	(unless (network-reachable?) (test-skip 1))
	63	(test-assertm "self-contained-tarball" %store
	64	(mlet* %store-monad
181e0ddd LC	65	((profile -> (profile
	66	(content (packages->manifest (list %bootstrap-guile)))
	67	(hooks '())
	68	(locales? #f)))
b27ef1d4 LC	69	(tarball (self-contained-tarball "pack" profile
	70	#:symlinks '(("/bin/Guile"
	71	-> "bin/guile"))
	72	#:compressor %gzip-compressor
	73	#:archiver %tar-bootstrap))
	74	(check (gexp->derivation
	75	"check-tarball"
72dc64f8 LC	76	(with-imported-modules '((guix build utils))
	77	#~(begin
	78	(use-modules (guix build utils)
	79	(srfi srfi-1))
	80
	81	(define store
	82	;; The unpacked store.
	83	(string-append "." (%store-directory) "/"))
	84
	85	(define (canonical? file)
	86	;; Return #t if FILE is read-only and its mtime is 1.
	87	(let ((st (lstat file)))
	88	(or (not (string-prefix? store file))
	89	(eq? 'symlink (stat:type st))
	90	(and (= 1 (stat:mtime st))
	91	(zero? (logand #o222
	92	(stat:mode st)))))))
	93
	94	(define bin
	95	(string-append "." #$profile "/bin"))
	96
	97	(setenv "PATH"
	98	(string-append #$%tar-bootstrap "/bin"))
	99	(system* "tar" "xvf" #$tarball)
	100	(mkdir #$output)
	101	(exit
	102	(and (file-exists? (string-append bin "/guile"))
	103	(file-exists? store)
	104	(every canonical?
	105	(find-files "." (const #t)
	106	#:directories? #t))
	107	(string=? (string-append #$%bootstrap-guile "/bin")
	108	(readlink bin))
	109	(string=? (string-append ".." #$profile
	110	"/bin/guile")
	111	(readlink "bin/Guile")))))))))
b27ef1d4	112	(built-derivations (list check))))
850edd77	113
f5a2fb1b LC	114	;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
	115	;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus,
	116	;; run it on the user's store, if it's available, on the grounds that these
	117	;; dependencies may be already there, or we can get substitutes or build them
	118	;; quite inexpensively; see <https://bugs.gnu.org/32184>.
	119
	120	(with-external-store store
1ff53787 LC	121	(unless store (test-skip 1))
	122	(test-assertm "self-contained-tarball + localstatedir" store
	123	(mlet* %store-monad
	124	((guile (set-guile-for-build (default-guile)))
	125	(profile (profile-derivation (packages->manifest
	126	(list %bootstrap-guile))
	127	#:hooks '()
	128	#:locales? #f))
	129	(tarball (self-contained-tarball "tar-pack" profile
	130	#:localstatedir? #t))
	131	(check (gexp->derivation
	132	"check-tarball"
	133	#~(let ((bin (string-append "." #$profile "/bin")))
	134	(setenv "PATH"
	135	(string-append #$%tar-bootstrap "/bin"))
	136	(system* "tar" "xvf" #$tarball)
	137	(mkdir #$output)
	138	(exit
	139	(and (file-exists? "var/guix/db/db.sqlite")
	140	(string=? (string-append #$%bootstrap-guile "/bin")
	141	(readlink bin))))))))
	142	(built-derivations (list check))))
	143
f5a2fb1b	144	(unless store (test-skip 1))
b3802495 LC	145	(test-assertm "self-contained-tarball + localstatedir, UTF-8 file names" store
	146	(mlet* %store-monad
	147	((guile (set-guile-for-build (default-guile)))
	148	(tree (interned-file-tree
	149	`("directory-with-utf8-file-names" directory
	150	("α" regular (data "alpha"))
	151	("λ" regular (data "lambda")))))
	152	(tarball (self-contained-tarball "tar-pack" tree
	153	#:localstatedir? #t))
	154	(check (gexp->derivation
	155	"check-tarball"
	156	(with-extensions (list guile-sqlite3 guile-gcrypt)
	157	(with-imported-modules (source-module-closure
	158	'((guix store database)))
	159	#~(begin
	160	(use-modules (guix store database)
	161	(rnrs io ports)
	162	(srfi srfi-1))
	163
	164	(define (valid-file? basename data)
	165	(define file
	166	(string-append "./" #$tree "/" basename))
	167
	168	(string=? (call-with-input-file (pk 'file file)
	169	get-string-all)
	170	data))
	171
	172	(setenv "PATH"
	173	(string-append #$%tar-bootstrap "/bin"))
	174	(system* "tar" "xvf" #$tarball)
	175
	176	(sql-schema
	177	#$(local-file (search-path %load-path
	178	"guix/store/schema.sql")))
	179	(with-database "var/guix/db/db.sqlite" db
	180	;; Make sure non-ASCII file names are properly
	181	;; handled.
	182	(setenv "GUIX_LOCPATH"
	183	#+(file-append glibc-utf8-locales
	184	"/lib/locale"))
	185	(setlocale LC_ALL "en_US.utf8")
	186
	187	(mkdir #$output)
	188	(exit
	189	(and (every valid-file?
	190	'("α" "λ")
	191	'("alpha" "lambda"))
	192	(integer? (path-id db #$tree)))))))))))
	193	(built-derivations (list check))))
	194
	195	(unless store (test-skip 1))
f5a2fb1b LC	196	(test-assertm "docker-image + localstatedir" store
	197	(mlet* %store-monad
	198	((guile (set-guile-for-build (default-guile)))
	199	(profile (profile-derivation (packages->manifest
	200	(list %bootstrap-guile))
	201	#:hooks '()
	202	#:locales? #f))
	203	(tarball (docker-image "docker-pack" profile
	204	#:symlinks '(("/bin/Guile" -> "bin/guile"))
	205	#:localstatedir? #t))
	206	(check (gexp->derivation
	207	"check-tarball"
	208	(with-imported-modules '((guix build utils))
	209	#~(begin
	210	(use-modules (guix build utils)
	211	(ice-9 match))
	212
	213	(define bin
	214	(string-append "." #$profile "/bin"))
	215
	216	(setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
	217	(mkdir "base")
	218	(with-directory-excursion "base"
	219	(invoke "tar" "xvf" #$tarball))
	220
	221	(match (find-files "base" "layer.tar")
	222	((layer)
	223	(invoke "tar" "xvf" layer)))
	224
	225	(when
	226	(and (file-exists? (string-append bin "/guile"))
	227	(file-exists? "var/guix/db/db.sqlite")
7979a287	228	(file-is-directory? "tmp")
f5a2fb1b LC	229	(string=? (string-append #$%bootstrap-guile "/bin")
	230	(pk 'binlink (readlink bin)))
	231	(string=? (string-append #$profile "/bin/guile")
	232	(pk 'guilelink (readlink "bin/Guile"))))
	233	(mkdir #$output)))))))
598a6b87 LC	234	(built-derivations (list check))))
	235
	236	(unless store (test-skip 1))
	237	(test-assertm "squashfs-image + localstatedir" store
	238	(mlet* %store-monad
	239	((guile (set-guile-for-build (default-guile)))
	240	(profile (profile-derivation (packages->manifest
	241	(list %bootstrap-guile))
	242	#:hooks '()
	243	#:locales? #f))
	244	(image (squashfs-image "squashfs-pack" profile
	245	#:symlinks '(("/bin" -> "bin"))
	246	#:localstatedir? #t))
	247	(check (gexp->derivation
	248	"check-tarball"
	249	(with-imported-modules '((guix build utils))
	250	#~(begin
	251	(use-modules (guix build utils)
	252	(ice-9 match))
	253
	254	(define bin
	255	(string-append "." #$profile "/bin"))
	256
	257	(setenv "PATH"
3c45b53e	258	(string-append #$squashfs-tools "/bin"))
598a6b87 LC	259	(invoke "unsquashfs" #$image)
	260	(with-directory-excursion "squashfs-root"
	261	(when (and (file-exists? (string-append bin
	262	"/guile"))
	263	(file-exists? "var/guix/db/db.sqlite")
	264	(string=? (string-append #$%bootstrap-guile "/bin")
	265	(pk 'binlink (readlink bin)))
9c2e5856 LC	266
	267	;; This is a relative symlink target.
	268	(string=? (string-drop
	269	(string-append #$profile "/bin")
	270	1)
598a6b87 LC	271	(pk 'guilelink (readlink "bin"))))
598a6b87 LC	272	(mkdir #$output))))))))
f5a2fb1b LC	273	(built-derivations (list check)))))
f5a2fb1b LC	274
850edd77	275	(test-end)
19c924af LC	276
	277	;; Local Variables:
	278	;; eval: (put 'test-assertm 'scheme-indent-function 2)
	279	;; End: