tests: pack: Fix indentation.
* tests/pack.scm: Fix indentation.
Maxim Cournoyer
parent
68380db4c4
commit
ac1d530d56
247
tests/pack.scm
247
tests/pack.scm
|
|
@ -74,44 +74,43 @@
|
|||
-> "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))
|
||||
(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 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 (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"))
|
||||
(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")))))))))
|
||||
(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
|
||||
|
|
@ -131,17 +130,16 @@
|
|||
#: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))))))))
|
||||
(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))
|
||||
|
|
@ -154,45 +152,44 @@
|
|||
("λ" 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))
|
||||
(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))
|
||||
(define (valid-file? basename data)
|
||||
(define file
|
||||
(string-append "./" #$tree "/" basename))
|
||||
|
||||
(string=? (call-with-input-file (pk 'file file)
|
||||
get-string-all)
|
||||
data))
|
||||
(string=? (call-with-input-file (pk 'file file)
|
||||
get-string-all)
|
||||
data))
|
||||
|
||||
(setenv "PATH"
|
||||
(string-append #$%tar-bootstrap "/bin"))
|
||||
(system* "tar" "xvf" #$tarball)
|
||||
(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")
|
||||
(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)))))))))))
|
||||
(mkdir #$output)
|
||||
(exit
|
||||
(and (every valid-file?
|
||||
'("α" "λ")
|
||||
'("alpha" "lambda"))
|
||||
(integer? (path-id db #$tree)))))))))))
|
||||
(built-derivations (list check))))
|
||||
|
||||
(unless store (test-skip 1))
|
||||
|
|
@ -206,34 +203,33 @@
|
|||
(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))
|
||||
(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"))
|
||||
(define bin
|
||||
(string-append "." #$profile "/bin"))
|
||||
|
||||
(setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
|
||||
(mkdir "base")
|
||||
(with-directory-excursion "base"
|
||||
(invoke "tar" "xvf" #$tarball))
|
||||
(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)))
|
||||
(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)))))))
|
||||
(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))
|
||||
|
|
@ -247,32 +243,31 @@
|
|||
(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))
|
||||
(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"))
|
||||
(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)))
|
||||
(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))))))))
|
||||
;; This is a relative symlink target.
|
||||
(string=? (string-drop
|
||||
(string-append #$profile "/bin")
|
||||
1)
|
||||
(pk 'guilelink (readlink "bin"))))
|
||||
(mkdir #$output))))))))
|
||||
(built-derivations (list check))))
|
||||
|
||||
(unless store (test-skip 1))
|
||||
|
|
|
|||
Reference in New Issue