diff options
| -rw-r--r-- | guix/serialization.scm | 140 | ||||
| -rw-r--r-- | tests/nar.scm | 62 |
2 files changed, 169 insertions, 33 deletions
diff --git a/guix/serialization.scm b/guix/serialization.scm index b41a0a09d1..129374f541 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -47,6 +47,7 @@ nar-read-error-token write-file + write-file-tree restore-file)) ;;; Comment: @@ -211,14 +212,19 @@ substitute invalid byte sequences with question marks. This is a (lambda () (close-port port)))))) - (write-string "contents" p) - (write-long-long size p) (call-with-binary-input-file file - ;; Use 'sendfile' when P is a file port. - (if (file-port? p) - (cut sendfile p <> size 0) - (cut dump <> p size))) - (write-padding size p)) + (lambda (input) + (write-contents-from-port input p size)))) + +(define (write-contents-from-port input output size) + "Write SIZE bytes from port INPUT to port OUTPUT." + (write-string "contents" output) + (write-long-long size output) + ;; Use 'sendfile' when both OUTPUT and INPUT are file ports. + (if (and (file-port? output) (file-port? input)) + (sendfile output input size 0) + (dump input output size)) + (write-padding size output)) (define (read-contents in out) "Read the contents of a file from the Nar at IN, write it to OUT, and return @@ -263,47 +269,113 @@ the size in bytes." sub-directories of FILE as needed. For each directory entry, call (SELECT? FILE STAT), where FILE is the entry's absolute file name and STAT is the result of 'lstat'; exclude entries for which SELECT? does not return true." + (write-file-tree file port + #:file-type+size + (lambda (file) + (let* ((stat (lstat file)) + (size (stat:size stat))) + (case (stat:type stat) + ((directory) + (values 'directory size)) + ((regular) + (values (if (zero? (logand (stat:mode stat) + #o100)) + 'regular + 'executable) + size)) + (else + (values (stat:type stat) size))))) ;bah! + #:file-port (cut open-file <> "r0b") + #:symlink-target readlink + + #:directory-entries + (lambda (directory) + ;; 'scandir' defaults to 'string-locale<?' to sort files, + ;; but this happens to be case-insensitive (at least in + ;; 'en_US' locale on libc 2.18.) Conversely, we want + ;; files to be sorted in a case-sensitive fashion. + (define basenames + (scandir directory (negate (cut member <> '("." ".."))) + string<?)) + + (filter-map (lambda (base) + (let ((file (string-append directory + "/" base))) + (and (not (member base '("." ".."))) + (select? file (lstat file)) + base))) + basenames)) + + ;; The 'scandir' call above gives us filtered and sorted + ;; entries, so no post-processing is needed. + #:postprocess-entries identity)) + +(define (filter/sort-directory-entries lst) + "Remove dot and dot-dot entries from LST, and sort it in lexicographical +order." + (delete-duplicates + (sort (remove (cute member <> '("." "..")) lst) + string<?) + string=?)) + +(define* (write-file-tree file port + #:key + file-type+size + file-port + symlink-target + directory-entries + (postprocess-entries filter/sort-directory-entries)) + "Write the contents of FILE to PORT in Nar format, recursing into +sub-directories of FILE as needed. + +This procedure does not make any file-system I/O calls. Instead, it calls the +user-provided FILE-TYPE+SIZE, FILE-PORT, SYMLINK-TARGET, and DIRECTORY-ENTRIES +procedures, which roughly correspond to 'lstat', 'readlink', and 'scandir'. +POSTPROCESS-ENTRIES ensures that directory entries are valid; leave it as-is +unless you know that DIRECTORY-ENTRIES provide filtered and sorted entries, in +which case you can use 'identity'." (define p port) (write-string %archive-version-1 p) - (let dump ((f file) (s (lstat file))) + (let dump ((f file)) + (define-values (type size) + (file-type+size f)) + (write-string "(" p) - (case (stat:type s) - ((regular) + (case type + ((regular executable) (write-string "type" p) (write-string "regular" p) - (if (not (zero? (logand (stat:mode s) #o100))) - (begin - (write-string "executable" p) - (write-string "" p))) - (write-contents f p (stat:size s))) + (when (eq? 'executable type) + (write-string "executable" p) + (write-string "" p)) + (let ((input (file-port f))) + (dynamic-wind + (const #t) + (lambda () + (write-contents-from-port input p size)) + (lambda () + (close-port input))))) ((directory) (write-string "type" p) (write-string "directory" p) - (let ((entries - ;; 'scandir' defaults to 'string-locale<?' to sort files, but - ;; this happens to be case-insensitive (at least in 'en_US' - ;; locale on libc 2.18.) Conversely, we want files to be - ;; sorted in a case-sensitive fashion. - (scandir f (negate (cut member <> '("." ".."))) string<?))) + (let ((entries (postprocess-entries (directory-entries f)))) (for-each (lambda (e) - (let* ((f (string-append f "/" e)) - (s (lstat f))) - (when (select? f s) - (write-string "entry" p) - (write-string "(" p) - (write-string "name" p) - (write-string e p) - (write-string "node" p) - (dump f s) - (write-string ")" p)))) + (let* ((f (string-append f "/" e))) + (write-string "entry" p) + (write-string "(" p) + (write-string "name" p) + (write-string e p) + (write-string "node" p) + (dump f) + (write-string ")" p))) entries))) ((symlink) (write-string "type" p) (write-string "symlink" p) (write-string "target" p) - (write-string (readlink f) p)) + (write-string (symlink-target f) p)) (else (raise (condition (&message (message "unsupported file type")) (&nar-error (file f) (port port)))))) @@ -379,4 +451,8 @@ Restore it as FILE." (&message (message "unsupported nar entry type")) (&nar-read-error (port port) (file file) (token x))))))))) +;;; Local Variables: +;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1) +;;; End: + ;;; serialization.scm ends here diff --git a/tests/nar.scm b/tests/nar.scm index 61646db964..9b5fb984b4 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -152,6 +152,66 @@ (test-begin "nar") +(test-assert "write-file-tree + restore-file" + (let* ((file1 (search-path %load-path "guix.scm")) + (file2 (search-path %load-path "guix/base32.scm")) + (file3 "#!/bin/something") + (output (string-append %test-dir "/output"))) + (dynamic-wind + (lambda () #t) + (lambda () + (define-values (port get-bytevector) + (open-bytevector-output-port)) + (write-file-tree "root" port + #:file-type+size + (match-lambda + ("root" + (values 'directory 0)) + ("root/foo" + (values 'regular (stat:size (stat file1)))) + ("root/lnk" + (values 'symlink 0)) + ("root/dir" + (values 'directory 0)) + ("root/dir/bar" + (values 'regular (stat:size (stat file2)))) + ("root/dir/exe" + (values 'executable (string-length file3)))) + #:file-port + (match-lambda + ("root/foo" (open-input-file file1)) + ("root/dir/bar" (open-input-file file2)) + ("root/dir/exe" (open-input-string file3))) + #:symlink-target + (match-lambda + ("root/lnk" "foo")) + #:directory-entries + (match-lambda + ("root" '("foo" "dir" "lnk")) + ("root/dir" '("bar" "exe")))) + (close-port port) + + (rm-rf %test-dir) + (mkdir %test-dir) + (restore-file (open-bytevector-input-port (get-bytevector)) + output) + (and (file=? (string-append output "/foo") file1) + (string=? (readlink (string-append output "/lnk")) + "foo") + (file=? (string-append output "/dir/bar") file2) + (string=? (call-with-input-file (string-append output "/dir/exe") + get-string-all) + file3) + (> (logand (stat:mode (lstat (string-append output "/dir/exe"))) + #o100) + 0) + (equal? '("." ".." "bar" "exe") + (scandir (string-append output "/dir"))) + (equal? '("." ".." "dir" "foo" "lnk") + (scandir output)))) + (lambda () + (false-if-exception (rm-rf %test-dir)))))) + (test-assert "write-file supports non-file output ports" (let ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) |