From 0363991a250177912d4ee6849c1b5ba05fbeaaff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Oct 2014 23:46:13 +0200 Subject: Break module cycle involving (guix store) and (guix ui). Before, there was a cycle along the lines of: (guix store) -> (guix nar) -> (guix ui) -> (guix store) This caused problems, as discussed at: http://lists.gnu.org/archive/html/guix-devel/2014-10/msg00109.html This patch removes cycles in the (guix ...) modules. * guix/nar.scm (&nar-error, &nar-read-error, dump, write-contents, read-contents, %archive-version-1, write-file, restore-file): Move to... * guix/serialization.scm: ... here. * guix/store.scm: Remove dependency on (guix nar). * guix/scripts/hash.scm, guix/scripts/offload.scm, guix/scripts/substitute-binary.scm, tests/nar.scm, tests/store.scm, tests/substitute-binary.scm: Adjust accordingly. --- guix/serialization.scm | 225 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 224 insertions(+), 1 deletion(-) (limited to 'guix/serialization.scm') 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)) + (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 -- cgit v1.2.3