ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

tests: pack: Fix indentation.

Browse source 
* tests/pack.scm: Fix indentation.
This commit is contained in:
Maxim Cournoyer 2023-02-02 14:43:58 -05:00
parent 68380db4c4
commit ac1d530d56
No known key found for this signature in database
GPG key ID: 1260E46482E63562
1 changed files with 121 additions and 126 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

247
tests/pack.scm
View file

@ -74,44 +74,43 @@ (define %ar-bootstrap %bootstrap-binutils)
-> "bin/guile")) -> "bin/guile"))
#:compressor %gzip-compressor #:compressor %gzip-compressor
#:archiver %tar-bootstrap)) #:archiver %tar-bootstrap))
(check (gexp->derivation (check (gexp->derivation "check-tarball"
"check-tarball" (with-imported-modules '((guix build utils))
(with-imported-modules '((guix build utils)) #~(begin
#~(begin (use-modules (guix build utils)
(use-modules (guix build utils) (srfi srfi-1))
(srfi srfi-1))
(define store (define store
;; The unpacked store. ;; The unpacked store.
(string-append "." (%store-directory) "/")) (string-append "." (%store-directory) "/"))
(define (canonical? file) (define (canonical? file)
;; Return #t if FILE is read-only and its mtime is 1. ;; Return #t if FILE is read-only and its mtime is 1.
(let ((st (lstat file))) (let ((st (lstat file)))
(or (not (string-prefix? store file)) (or (not (string-prefix? store file))
(eq? 'symlink (stat:type st)) (eq? 'symlink (stat:type st))
(and (= 1 (stat:mtime st)) (and (= 1 (stat:mtime st))
(zero? (logand #o222 (zero? (logand #o222
(stat:mode st))))))) (stat:mode st)))))))
(define bin (define bin
(string-append "." #$profile "/bin")) (string-append "." #$profile "/bin"))
(setenv "PATH" (setenv "PATH"
(string-append #$%tar-bootstrap "/bin")) (string-append #$%tar-bootstrap "/bin"))
(system* "tar" "xvf" #$tarball) (system* "tar" "xvf" #$tarball)
(mkdir #$output) (mkdir #$output)
(exit (exit
(and (file-exists? (string-append bin "/guile")) (and (file-exists? (string-append bin "/guile"))
(file-exists? store) (file-exists? store)
(every canonical? (every canonical?
(find-files "." (const #t) (find-files "." (const #t)
#:directories? #t)) #:directories? #t))
(string=? (string-append #$%bootstrap-guile "/bin") (string=? (string-append #$%bootstrap-guile "/bin")
(readlink bin)) (readlink bin))
(string=? (string-append ".." #$profile (string=? (string-append ".." #$profile
"/bin/guile") "/bin/guile")
(readlink "bin/Guile"))))))))) (readlink "bin/Guile")))))))))
(built-derivations (list check)))) (built-derivations (list check))))
;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of ;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
@ -131,17 +130,16 @@ (define bin
#:locales? #f)) #:locales? #f))
(tarball (self-contained-tarball "tar-pack" profile (tarball (self-contained-tarball "tar-pack" profile
#:localstatedir? #t)) #:localstatedir? #t))
(check (gexp->derivation (check (gexp->derivation "check-tarball"
"check-tarball" #~(let ((bin (string-append "." #$profile "/bin")))
#~(let ((bin (string-append "." #$profile "/bin"))) (setenv "PATH"
(setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
(string-append #$%tar-bootstrap "/bin")) (system* "tar" "xvf" #$tarball)
(system* "tar" "xvf" #$tarball) (mkdir #$output)
(mkdir #$output) (exit
(exit (and (file-exists? "var/guix/db/db.sqlite")
(and (file-exists? "var/guix/db/db.sqlite") (string=? (string-append #$%bootstrap-guile "/bin")
(string=? (string-append #$%bootstrap-guile "/bin") (readlink bin))))))))
(readlink bin))))))))
(built-derivations (list check)))) (built-derivations (list check))))
(unless store (test-skip 1)) (unless store (test-skip 1))
@ -154,45 +152,44 @@ (define bin
("λ" regular (data "lambda"))))) ("λ" regular (data "lambda")))))
(tarball (self-contained-tarball "tar-pack" tree (tarball (self-contained-tarball "tar-pack" tree
#:localstatedir? #t)) #:localstatedir? #t))
(check (gexp->derivation (check (gexp->derivation "check-tarball"
"check-tarball" (with-extensions (list guile-sqlite3 guile-gcrypt)
(with-extensions (list guile-sqlite3 guile-gcrypt) (with-imported-modules (source-module-closure
(with-imported-modules (source-module-closure '((guix store database)))
'((guix store database))) #~(begin
#~(begin (use-modules (guix store database)
(use-modules (guix store database) (rnrs io ports)
(rnrs io ports) (srfi srfi-1))
(srfi srfi-1))
(define (valid-file? basename data) (define (valid-file? basename data)
(define file (define file
(string-append "./" #$tree "/" basename)) (string-append "./" #$tree "/" basename))
(string=? (call-with-input-file (pk 'file file) (string=? (call-with-input-file (pk 'file file)
get-string-all) get-string-all)
data)) data))
(setenv "PATH" (setenv "PATH"
(string-append #$%tar-bootstrap "/bin")) (string-append #$%tar-bootstrap "/bin"))
(system* "tar" "xvf" #$tarball) (system* "tar" "xvf" #$tarball)
(sql-schema (sql-schema
#$(local-file (search-path %load-path #$(local-file (search-path %load-path
"guix/store/schema.sql"))) "guix/store/schema.sql")))
(with-database "var/guix/db/db.sqlite" db (with-database "var/guix/db/db.sqlite" db
;; Make sure non-ASCII file names are properly ;; Make sure non-ASCII file names are properly
;; handled. ;; handled.
(setenv "GUIX_LOCPATH" (setenv "GUIX_LOCPATH"
#+(file-append glibc-utf8-locales #+(file-append glibc-utf8-locales
"/lib/locale")) "/lib/locale"))
(setlocale LC_ALL "en_US.utf8") (setlocale LC_ALL "en_US.utf8")
(mkdir #$output) (mkdir #$output)
(exit (exit
(and (every valid-file? (and (every valid-file?
'("α" "λ") '("α" "λ")
'("alpha" "lambda")) '("alpha" "lambda"))
(integer? (path-id db #$tree))))))))))) (integer? (path-id db #$tree)))))))))))
(built-derivations (list check)))) (built-derivations (list check))))
(unless store (test-skip 1)) (unless store (test-skip 1))
@ -206,34 +203,33 @@ (define file
(tarball (docker-image "docker-pack" profile (tarball (docker-image "docker-pack" profile
#:symlinks '(("/bin/Guile" -> "bin/guile")) #:symlinks '(("/bin/Guile" -> "bin/guile"))
#:localstatedir? #t)) #:localstatedir? #t))
(check (gexp->derivation (check (gexp->derivation "check-tarball"
"check-tarball" (with-imported-modules '((guix build utils))
(with-imported-modules '((guix build utils)) #~(begin
#~(begin (use-modules (guix build utils)
(use-modules (guix build utils) (ice-9 match))
(ice-9 match))
(define bin (define bin
(string-append "." #$profile "/bin")) (string-append "." #$profile "/bin"))
(setenv "PATH" (string-append #$%tar-bootstrap "/bin")) (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
(mkdir "base") (mkdir "base")
(with-directory-excursion "base" (with-directory-excursion "base"
(invoke "tar" "xvf" #$tarball)) (invoke "tar" "xvf" #$tarball))
(match (find-files "base" "layer.tar") (match (find-files "base" "layer.tar")
((layer) ((layer)
(invoke "tar" "xvf" layer))) (invoke "tar" "xvf" layer)))
(when (when
(and (file-exists? (string-append bin "/guile")) (and (file-exists? (string-append bin "/guile"))
(file-exists? "var/guix/db/db.sqlite") (file-exists? "var/guix/db/db.sqlite")
(file-is-directory? "tmp") (file-is-directory? "tmp")
(string=? (string-append #$%bootstrap-guile "/bin") (string=? (string-append #$%bootstrap-guile "/bin")
(pk 'binlink (readlink bin))) (pk 'binlink (readlink bin)))
(string=? (string-append #$profile "/bin/guile") (string=? (string-append #$profile "/bin/guile")
(pk 'guilelink (readlink "bin/Guile")))) (pk 'guilelink (readlink "bin/Guile"))))
(mkdir #$output))))))) (mkdir #$output)))))))
(built-derivations (list check)))) (built-derivations (list check))))
(unless store (test-skip 1)) (unless store (test-skip 1))
@ -247,32 +243,31 @@ (define bin
(image (squashfs-image "squashfs-pack" profile (image (squashfs-image "squashfs-pack" profile
#:symlinks '(("/bin" -> "bin")) #:symlinks '(("/bin" -> "bin"))
#:localstatedir? #t)) #:localstatedir? #t))
(check (gexp->derivation (check (gexp->derivation "check-tarball"
"check-tarball" (with-imported-modules '((guix build utils))
(with-imported-modules '((guix build utils)) #~(begin
#~(begin (use-modules (guix build utils)
(use-modules (guix build utils) (ice-9 match))
(ice-9 match))
(define bin (define bin
(string-append "." #$profile "/bin")) (string-append "." #$profile "/bin"))
(setenv "PATH" (setenv "PATH"
(string-append #$squashfs-tools "/bin")) (string-append #$squashfs-tools "/bin"))
(invoke "unsquashfs" #$image) (invoke "unsquashfs" #$image)
(with-directory-excursion "squashfs-root" (with-directory-excursion "squashfs-root"
(when (and (file-exists? (string-append bin (when (and (file-exists? (string-append bin
"/guile")) "/guile"))
(file-exists? "var/guix/db/db.sqlite") (file-exists? "var/guix/db/db.sqlite")
(string=? (string-append #$%bootstrap-guile "/bin") (string=? (string-append #$%bootstrap-guile "/bin")
(pk 'binlink (readlink bin))) (pk 'binlink (readlink bin)))
;; This is a relative symlink target. ;; This is a relative symlink target.
(string=? (string-drop (string=? (string-drop
(string-append #$profile "/bin") (string-append #$profile "/bin")
1) 1)
(pk 'guilelink (readlink "bin")))) (pk 'guilelink (readlink "bin"))))
(mkdir #$output)))))))) (mkdir #$output))))))))
(built-derivations (list check)))) (built-derivations (list check))))
(unless store (test-skip 1)) (unless store (test-skip 1))