diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/nar.scm | 150 | ||||
| -rw-r--r-- | tests/nar.scm | 95 |
3 files changed, 228 insertions, 18 deletions
diff --git a/Makefile.am b/Makefile.am index a8bd2f8daf..930ea6ce72 100644 --- a/Makefile.am +++ b/Makefile.am @@ -296,6 +296,7 @@ TESTS = \ tests/packages.scm \ tests/snix.scm \ tests/store.scm \ + tests/nar.scm \ tests/union.scm \ tests/guix-build.sh \ tests/guix-download.sh \ diff --git a/guix/nar.scm b/guix/nar.scm index b42f03c514..9ae76ff2a9 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -19,12 +19,23 @@ (define-module (guix nar) #:use-module (guix utils) #:use-module (guix serialization) + #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module (rnrs bytevectors) #: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 ftw) - #:export (write-file)) + #:use-module (ice-9 match) + #:export (nar-error? + nar-read-error? + nar-read-error-file + nar-read-error-port + nar-read-error-token + + write-file + restore-file)) ;;; Comment: ;;; @@ -32,6 +43,31 @@ ;;; ;;; Code: +(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? + nar-error?) + +(define-condition-type &nar-read-error &nar-error + nar-read-error? + (port nar-read-error-port) ; port from which we read + (file nar-read-error-file) ; file we were restoring, or #f + (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) @@ -45,33 +81,55 @@ (close-port port) (apply throw args)))))) - (define (dump in size) - (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 buf-size))) - (if (eof-object? read) - left - (begin - (put-bytevector p buf 0 read) - (loop (- left read)))))))) - (write-string "contents" p) (write-long-long size p) (call-with-binary-input-file file ;; Use `sendfile' when available (Guile 2.0.8+). (if (compile-time-value (defined? 'sendfile)) (cut sendfile p <> size 0) - (cut dump <> size))) + (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 %archive-version-1 "nix-archive-1") (define p port) (write-string %archive-version-1 p) @@ -104,7 +162,63 @@ sub-directories of FILE as needed." (write-string ")" p))) entries))) (else - (error "ENOSYS"))) + (raise (condition (&message (message "ENOSYS")) + (&nar-error))))) (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)) + (match (list (read-string port) (read-string port) (read-string port)) + (("(" "type" "regular") + (call-with-output-file file (cut read-contents port <>)) + (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))))))) + (("(" "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)))))))) + ;;; nar.scm ends here diff --git a/tests/nar.scm b/tests/nar.scm new file mode 100644 index 0000000000..2d9bffd487 --- /dev/null +++ b/tests/nar.scm @@ -0,0 +1,95 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-nar) + #:use-module (guix nar) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (ice-9 ftw)) + +;; Test the (guix nar) module. + +(define (rm-rf dir) + (file-system-fold (const #t) ; enter? + (lambda (file stat result) ; leaf + (delete-file file)) + (const #t) ; down + (lambda (dir stat result) ; up + (rmdir dir)) + (const #t) ; skip + (const #t) ; error + #t + dir + lstat)) + + +(test-begin "nar") + +(test-assert "write-file + restore-file" + (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) + "/guix")) + (output (string-append (dirname input) + "/test-nar-" + (number->string (getpid)))) + (nar (string-append output ".nar"))) + (dynamic-wind + (lambda () #t) + (lambda () + (call-with-output-file nar + (cut write-file input <>)) + (call-with-input-file nar + (cut restore-file <> output)) + (let* ((strip (cute string-drop <> (string-length input))) + (sibling (compose (cut string-append output <>) strip)) + (file=? (lambda (a b) + (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) + (case (stat:type (lstat a)) + ((regular) + (equal? + (call-with-input-file a get-bytevector-all) + (call-with-input-file b get-bytevector-all))) + ((symlink) + (string=? (readlink a) (readlink b))) + (else + (error "what?" (lstat a)))))))) + (file-system-fold (const #t) + (lambda (name stat result) ; leaf + (and result + (file=? name (sibling name)))) + (lambda (name stat result) ; down + result) + (lambda (name stat result) ; up + result) + (const #f) ; skip + (lambda (name stat errno result) + (pk 'error name stat errno) + #f) + (> (stat:nlink (stat output)) 2) + input + lstat))) + (lambda () + (false-if-exception (delete-file nar)) + (false-if-exception (rm-rf output)) + )))) + +(test-end "nar") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) |