M Makefile.am => Makefile.am +1 -0
@@ 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 \
M guix/nar.scm => guix/nar.scm +132 -18
@@ 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
A tests/nar.scm => tests/nar.scm +95 -0
@@ 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))