diff options
| -rw-r--r-- | guix/nar.scm | 222 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 1 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 2 | ||||
| -rw-r--r-- | guix/serialization.scm | 225 | ||||
| -rw-r--r-- | guix/store.scm | 1 | ||||
| -rw-r--r-- | tests/nar.scm | 1 | ||||
| -rw-r--r-- | tests/store.scm | 2 | ||||
| -rw-r--r-- | tests/substitute-binary.scm | 2 |
9 files changed, 231 insertions, 227 deletions
diff --git a/guix/nar.scm b/guix/nar.scm index b95cbd648d..bab727e65d 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -27,32 +27,18 @@ #:use-module (guix hash) #:use-module (guix pki) #:use-module (guix pk-crypto) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:export (nar-error? - nar-error-port - nar-error-file - - nar-read-error? - nar-read-error-token - - nar-invalid-hash-error? + #:export (nar-invalid-hash-error? nar-invalid-hash-error-expected nar-invalid-hash-error-actual nar-signature-error? nar-signature-error-signature - write-file - restore-file - restore-file-set)) ;;; Comment: @@ -61,15 +47,6 @@ ;;; ;;; Code: -(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? - nar-error? - (file nar-error-file) ; file we were restoring, or #f - (port nar-error-port)) ; port from which we read - -(define-condition-type &nar-read-error &nar-error - nar-read-error? - (token nar-read-error-token)) ; faulty token, or #f - (define-condition-type &nar-signature-error &nar-error nar-signature-error? (signature nar-signature-error-signature)) ; faulty signature or #f @@ -79,203 +56,6 @@ (expected nar-invalid-hash-error-expected) ; expected hash (a bytevector) (actual nar-invalid-hash-error-actual)) ; actual hash - -(define (dump in out size) - "Copy SIZE bytes from IN to OUT." - (define buf-size 65536) - (define buf (make-bytevector buf-size)) - - (let loop ((left size)) - (if (<= left 0) - 0 - (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) - (if (eof-object? read) - left - (begin - (put-bytevector out buf 0 read) - (loop (- left read)))))))) - -(define (write-contents file p size) - "Write SIZE bytes from FILE to output port P." - (define (call-with-binary-input-file file proc) - ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus - ;; avoids any initial buffering. Disable file name canonicalization to - ;; avoid stat'ing like crazy. - (with-fluids ((%file-port-name-canonicalization #f)) - (let ((port (open-file file "rb"))) - (dynamic-wind - (const #t) - (cut proc port) - (lambda () - (close-port port)))))) - - (write-string "contents" p) - (write-long-long size p) - (call-with-binary-input-file file - ;; Use `sendfile' when available (Guile 2.0.8+). - (if (and (compile-time-value (defined? 'sendfile)) - (file-port? p)) - (cut sendfile p <> size 0) - (cut dump <> p size))) - (write-padding size p)) - -(define (read-contents in out) - "Read the contents of a file from the Nar at IN, write it to OUT, and return -the size in bytes." - (define executable? - (match (read-string in) - ("contents" - #f) - ("executable" - (match (list (read-string in) (read-string in)) - (("" "contents") #t) - (x (raise - (condition (&message - (message "unexpected executable file marker")) - (&nar-read-error (port in) - (file #f) - (token x)))))) - #t) - (x - (raise - (condition (&message (message "unsupported nar file type")) - (&nar-read-error (port in) (file #f) (token x))))))) - - (let ((size (read-long-long in))) - ;; Note: `sendfile' cannot be used here because of port buffering on IN. - (dump in out size) - - (when executable? - (chmod out #o755)) - (let ((m (modulo size 8))) - (unless (zero? m) - (get-bytevector-n in (- 8 m)))) - size)) - -(define %archive-version-1 - ;; Magic cookie for Nix archives. - "nix-archive-1") - -(define (write-file file port) - "Write the contents of FILE to PORT in Nar format, recursing into -sub-directories of FILE as needed." - (define p port) - - (write-string %archive-version-1 p) - - (let dump ((f file)) - (let ((s (lstat f))) - (write-string "(" p) - (case (stat:type s) - ((regular) - (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))) - ((directory) - (write-string "type" p) - (write-string "directory" p) - (let ((entries - ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories - ;; unconditionally, including "." and "..", regardless of the - ;; 'select?' predicate passed to it, so we have to filter - ;; those out externally. - (filter (negate (cut member <> '("." ".."))) - ;; '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 (const #t) string<?)))) - (for-each (lambda (e) - (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)) - (else - (raise (condition (&message (message "unsupported file type")) - (&nar-error (file f) (port port)))))) - (write-string ")" p)))) - -(define (restore-file port file) - "Read a file (possibly a directory structure) in Nar format from PORT. -Restore it as FILE." - (let ((signature (read-string port))) - (unless (equal? signature %archive-version-1) - (raise - (condition (&message (message "invalid nar signature")) - (&nar-read-error (port port) - (token signature) - (file #f)))))) - - (let restore ((file file)) - (define (read-eof-marker) - (match (read-string port) - (")" #t) - (x (raise - (condition - (&message (message "invalid nar end-of-file marker")) - (&nar-read-error (port port) (file file) (token x))))))) - - (match (list (read-string port) (read-string port) (read-string port)) - (("(" "type" "regular") - (call-with-output-file file (cut read-contents port <>)) - (read-eof-marker)) - (("(" "type" "symlink") - (match (list (read-string port) (read-string port)) - (("target" target) - (symlink target file) - (read-eof-marker)) - (x (raise - (condition - (&message (message "invalid symlink tokens")) - (&nar-read-error (port port) (file file) (token x))))))) - (("(" "type" "directory") - (let ((dir file)) - (mkdir dir) - (let loop ((prefix (read-string port))) - (match prefix - ("entry" - (match (list (read-string port) - (read-string port) (read-string port) - (read-string port)) - (("(" "name" file "node") - (restore (string-append dir "/" file)) - (match (read-string port) - (")" #t) - (x - (raise - (condition - (&message - (message "unexpected directory entry termination")) - (&nar-read-error (port port) - (file file) - (token x)))))) - (loop (read-string port))))) - (")" #t) ; done with DIR - (x - (raise - (condition - (&message (message "unexpected directory inter-entry marker")) - (&nar-read-error (port port) (file file) (token x))))))))) - (x - (raise - (condition - (&message (message "unsupported nar entry type")) - (&nar-read-error (port port) (file file) (token x)))))))) ;;; diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index ea8c2ada6b..e2305d73ee 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -20,7 +20,7 @@ (define-module (guix scripts hash) #:use-module (guix base32) #:use-module (guix hash) - #:use-module (guix nar) + #:use-module (guix serialization) #:use-module (guix ui) #:use-module (guix utils) #:use-module (rnrs io ports) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 391906ff79..5d1c7c23cb 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -21,6 +21,7 @@ #:use-module (guix records) #:use-module (guix store) #:use-module (guix derivations) + #:use-module (guix serialization) #:use-module (guix nar) #:use-module (guix utils) #:use-module ((guix build utils) #:select (which mkdir-p)) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index a2d0cab727..f5ccc8d5e5 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -23,7 +23,7 @@ #:use-module (guix utils) #:use-module (guix config) #:use-module (guix records) - #:use-module (guix nar) + #:use-module (guix serialization) #:use-module (guix hash) #:use-module (guix base64) #:use-module (guix pk-crypto) diff --git a/guix/serialization.scm b/guix/serialization.scm index 284b174794..64eacf974c 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -22,7 +22,10 @@ #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:export (write-int read-int write-long-long read-long-long write-padding @@ -30,7 +33,19 @@ write-string-list read-string-list write-string-pairs write-store-path read-store-path - write-store-path-list read-store-path-list)) + write-store-path-list read-store-path-list + + &nar-error + nar-error? + nar-error-port + nar-error-file + + &nar-read-error + nar-read-error? + nar-read-error-token + + write-file + restore-file)) ;;; Comment: ;;; @@ -121,4 +136,212 @@ (define write-store-path-list write-string-list) (define read-store-path-list read-string-list) + +(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? + nar-error? + (file nar-error-file) ; file we were restoring, or #f + (port nar-error-port)) ; port from which we read + +(define-condition-type &nar-read-error &nar-error + nar-read-error? + (token nar-read-error-token)) ; faulty token, or #f + + +(define (dump in out size) + "Copy SIZE bytes from IN to OUT." + (define buf-size 65536) + (define buf (make-bytevector buf-size)) + + (let loop ((left size)) + (if (<= left 0) + 0 + (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) + (if (eof-object? read) + left + (begin + (put-bytevector out buf 0 read) + (loop (- left read)))))))) + +(define (write-contents file p size) + "Write SIZE bytes from FILE to output port P." + (define (call-with-binary-input-file file proc) + ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus + ;; avoids any initial buffering. Disable file name canonicalization to + ;; avoid stat'ing like crazy. + (with-fluids ((%file-port-name-canonicalization #f)) + (let ((port (open-file file "rb"))) + (dynamic-wind + (const #t) + (cut proc port) + (lambda () + (close-port port)))))) + + (write-string "contents" p) + (write-long-long size p) + (call-with-binary-input-file file + ;; Use `sendfile' when available (Guile 2.0.8+). + (if (and (compile-time-value (defined? 'sendfile)) + (file-port? p)) + (cut sendfile p <> size 0) + (cut dump <> p size))) + (write-padding size p)) + +(define (read-contents in out) + "Read the contents of a file from the Nar at IN, write it to OUT, and return +the size in bytes." + (define executable? + (match (read-string in) + ("contents" + #f) + ("executable" + (match (list (read-string in) (read-string in)) + (("" "contents") #t) + (x (raise + (condition (&message + (message "unexpected executable file marker")) + (&nar-read-error (port in) + (file #f) + (token x)))))) + #t) + (x + (raise + (condition (&message (message "unsupported nar file type")) + (&nar-read-error (port in) (file #f) (token x))))))) + + (let ((size (read-long-long in))) + ;; Note: `sendfile' cannot be used here because of port buffering on IN. + (dump in out size) + + (when executable? + (chmod out #o755)) + (let ((m (modulo size 8))) + (unless (zero? m) + (get-bytevector-n in (- 8 m)))) + size)) + +(define %archive-version-1 + ;; Magic cookie for Nix archives. + "nix-archive-1") + +(define (write-file file port) + "Write the contents of FILE to PORT in Nar format, recursing into +sub-directories of FILE as needed." + (define p port) + + (write-string %archive-version-1 p) + + (let dump ((f file)) + (let ((s (lstat f))) + (write-string "(" p) + (case (stat:type s) + ((regular) + (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))) + ((directory) + (write-string "type" p) + (write-string "directory" p) + (let ((entries + ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories + ;; unconditionally, including "." and "..", regardless of the + ;; 'select?' predicate passed to it, so we have to filter + ;; those out externally. + (filter (negate (cut member <> '("." ".."))) + ;; '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 (const #t) string<?)))) + (for-each (lambda (e) + (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)) + (else + (raise (condition (&message (message "unsupported file type")) + (&nar-error (file f) (port port)))))) + (write-string ")" p)))) + +(define (restore-file port file) + "Read a file (possibly a directory structure) in Nar format from PORT. +Restore it as FILE." + (let ((signature (read-string port))) + (unless (equal? signature %archive-version-1) + (raise + (condition (&message (message "invalid nar signature")) + (&nar-read-error (port port) + (token signature) + (file #f)))))) + + (let restore ((file file)) + (define (read-eof-marker) + (match (read-string port) + (")" #t) + (x (raise + (condition + (&message (message "invalid nar end-of-file marker")) + (&nar-read-error (port port) (file file) (token x))))))) + + (match (list (read-string port) (read-string port) (read-string port)) + (("(" "type" "regular") + (call-with-output-file file (cut read-contents port <>)) + (read-eof-marker)) + (("(" "type" "symlink") + (match (list (read-string port) (read-string port)) + (("target" target) + (symlink target file) + (read-eof-marker)) + (x (raise + (condition + (&message (message "invalid symlink tokens")) + (&nar-read-error (port port) (file file) (token x))))))) + (("(" "type" "directory") + (let ((dir file)) + (mkdir dir) + (let loop ((prefix (read-string port))) + (match prefix + ("entry" + (match (list (read-string port) + (read-string port) (read-string port) + (read-string port)) + (("(" "name" file "node") + (restore (string-append dir "/" file)) + (match (read-string port) + (")" #t) + (x + (raise + (condition + (&message + (message "unexpected directory entry termination")) + (&nar-read-error (port port) + (file file) + (token x)))))) + (loop (read-string port))))) + (")" #t) ; done with DIR + (x + (raise + (condition + (&message (message "unexpected directory inter-entry marker")) + (&nar-read-error (port port) (file file) (token x))))))))) + (x + (raise + (condition + (&message (message "unsupported nar entry type")) + (&nar-read-error (port port) (file file) (token x)))))))) + ;;; serialization.scm ends here diff --git a/guix/store.scm b/guix/store.scm index 79dcf22cca..452a2f1268 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -17,7 +17,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix store) - #:use-module (guix nar) #:use-module (guix utils) #:use-module (guix config) #:use-module (guix serialization) diff --git a/tests/nar.scm b/tests/nar.scm index 3188599bf1..1641d6f9b2 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -19,6 +19,7 @@ (define-module (test-nar) #:use-module (guix tests) #:use-module (guix nar) + #:use-module (guix serialization) #:use-module (guix store) #:use-module ((guix hash) #:select (open-sha256-port open-sha256-input-port)) diff --git a/tests/store.scm b/tests/store.scm index ba15524be4..88a8877d80 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -24,7 +24,7 @@ #:use-module (guix base32) #:use-module (guix packages) #:use-module (guix derivations) - #:use-module (guix nar) + #:use-module (guix serialization) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) diff --git a/tests/substitute-binary.scm b/tests/substitute-binary.scm index 163cd74593..7c1204c1ab 100644 --- a/tests/substitute-binary.scm +++ b/tests/substitute-binary.scm @@ -21,7 +21,7 @@ #:use-module (guix scripts substitute-binary) #:use-module (guix base64) #:use-module (guix hash) - #:use-module (guix nar) + #:use-module (guix serialization) #:use-module (guix pk-crypto) #:use-module (guix pki) #:use-module (guix config) |