aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/serialization.scm165
-rw-r--r--tests/nar.scm11
2 files changed, 101 insertions, 75 deletions
diff --git a/guix/serialization.scm b/guix/serialization.scm
index e36751ec1b..4f82c06862 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -56,13 +56,32 @@
;; Similar to serialize.cc in Nix.
+(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 currently-restored-file
+ ;; Name of the file being restored. Used internally for error reporting.
+ (make-parameter #f))
+
+
+(define (get-bytevector-n* port count)
+ (let ((bv (get-bytevector-n port count)))
+ (when (or (eof-object? bv)
+ (< (bytevector-length bv) count))
+ (raise (condition (&nar-error
+ (file (currently-restored-file))
+ (port port)))))
+ bv))
+
(define (write-int n p)
(let ((b (make-bytevector 8 0)))
(bytevector-u32-set! b 0 n (endianness little))
(put-bytevector p b)))
(define (read-int p)
- (let ((b (get-bytevector-n p 8)))
+ (let ((b (get-bytevector-n* p 8)))
(bytevector-u32-ref b 0 (endianness little))))
(define (write-long-long n p)
@@ -71,7 +90,7 @@
(put-bytevector p b)))
(define (read-long-long p)
- (let ((b (get-bytevector-n p 8)))
+ (let ((b (get-bytevector-n* p 8)))
(bytevector-u64-ref b 0 (endianness little))))
(define write-padding
@@ -93,10 +112,10 @@
(define (read-string p)
(let* ((len (read-int p))
(m (modulo len 8))
- (bv (get-bytevector-n p len))
+ (bv (get-bytevector-n* p len))
(str (utf8->string bv)))
(or (zero? m)
- (get-bytevector-n p (- 8 m)))
+ (get-bytevector-n* p (- 8 m)))
str))
(define (read-latin1-string p)
@@ -105,9 +124,9 @@
;; Note: do not use 'get-string-n' to work around Guile bug
;; <http://bugs.gnu.org/19621>. See <http://bugs.gnu.org/19610> for
;; a discussion.
- (str (get-bytevector-n p len)))
+ (str (get-bytevector-n* p len)))
(or (zero? m)
- (get-bytevector-n p (- 8 m)))
+ (get-bytevector-n* p (- 8 m)))
;; XXX: Rewrite using (ice-9 iconv) when the minimum requirement is
;; upgraded to Guile >= 2.0.9.
@@ -143,11 +162,6 @@
(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
@@ -222,7 +236,7 @@ the size in bytes."
(chmod out #o755))
(let ((m (modulo size 8)))
(unless (zero? m)
- (get-bytevector-n in (- 8 m))))
+ (get-bytevector-n* in (- 8 m))))
size))
(define %archive-version-1
@@ -286,68 +300,71 @@ sub-directories of FILE as needed."
(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
+ (parameterize ((currently-restored-file 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)))))))
+
+ (currently-restored-file file)
+
+ (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 "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))))))))
+ (&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/tests/nar.scm b/tests/nar.scm
index 38b2482c92..4ccd364861 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -201,6 +201,15 @@
(lambda ()
(rm-rf input)))))
+(test-equal "restore-file with incomplete input"
+ (string-append %test-dir "/foo")
+ (let ((port (open-bytevector-input-port #vu8(1 2 3))))
+ (guard (c ((nar-error? c)
+ (and (eq? port (nar-error-port c))
+ (nar-error-file c))))
+ (restore-file port (string-append %test-dir "/foo"))
+ #f)))
+
(test-assert "write-file + restore-file"
(let* ((input (string-append (dirname (search-path %load-path "guix.scm"))
"/guix"))