nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

serialization: Check for EOF and incomplete input conditions. 

Fixes <http://bugs.gnu.org/19756>.
Reported by <sleep_walker@suse.cz>.

* guix/serialization.scm (currently-restored-file): New variable.
  (get-bytevector-n*): New procedure.
  (read-int, read-long-long, read-string, read-latin1-string,
  read-contents): Use it instead of 'get-bytevector-n'.
  (restore-file): Parameterize 'currently-restored-file' and set it.
* tests/nar.scm ("restore-file with incomplete input"): New test.
This commit is contained in:
Ludovic Courtès 2015-02-07 23:05:23 +01:00
parent cbc538fe69
commit 46b8aadbd6
2 changed files with 99 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

161
guix/serialization.scm
View File

@ -56,13 +56,32 @@
;; Similar to serialize.cc in Nix. ;; 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) (define (write-int n p)
(let ((b (make-bytevector 8 0))) (let ((b (make-bytevector 8 0)))
(bytevector-u32-set! b 0 n (endianness little)) (bytevector-u32-set! b 0 n (endianness little))
(put-bytevector p b))) (put-bytevector p b)))
(define (read-int p) (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)))) (bytevector-u32-ref b 0 (endianness little))))
(define (write-long-long n p) (define (write-long-long n p)
@ -71,7 +90,7 @@
(put-bytevector p b))) (put-bytevector p b)))
(define (read-long-long p) (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)))) (bytevector-u64-ref b 0 (endianness little))))
(define write-padding (define write-padding
@ -93,10 +112,10 @@
(define (read-string p) (define (read-string p)
(let* ((len (read-int p)) (let* ((len (read-int p))
(m (modulo len 8)) (m (modulo len 8))
(bv (get-bytevector-n p len)) (bv (get-bytevector-n* p len))
(str (utf8->string bv))) (str (utf8->string bv)))
(or (zero? m) (or (zero? m)
(get-bytevector-n p (- 8 m))) (get-bytevector-n* p (- 8 m)))
str)) str))
(define (read-latin1-string p) (define (read-latin1-string p)
@ -105,9 +124,9 @@
;; Note: do not use 'get-string-n' to work around Guile bug ;; Note: do not use 'get-string-n' to work around Guile bug
;; <http://bugs.gnu.org/19621>. See <http://bugs.gnu.org/19610> for ;; <http://bugs.gnu.org/19621>. See <http://bugs.gnu.org/19610> for
;; a discussion. ;; a discussion.
(str (get-bytevector-n p len))) (str (get-bytevector-n* p len)))
(or (zero? m) (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 ;; XXX: Rewrite using (ice-9 iconv) when the minimum requirement is
;; upgraded to Guile >= 2.0.9. ;; upgraded to Guile >= 2.0.9.
@ -143,11 +162,6 @@
(define read-store-path-list read-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 (define-condition-type &nar-read-error &nar-error
nar-read-error? nar-read-error?
(token nar-read-error-token)) ; faulty token, or #f (token nar-read-error-token)) ; faulty token, or #f
@ -222,7 +236,7 @@ the size in bytes."
(chmod out #o755)) (chmod out #o755))
(let ((m (modulo size 8))) (let ((m (modulo size 8)))
(unless (zero? m) (unless (zero? m)
(get-bytevector-n in (- 8 m)))) (get-bytevector-n* in (- 8 m))))
size)) size))
(define %archive-version-1 (define %archive-version-1
@ -286,68 +300,71 @@ sub-directories of FILE as needed."
(define (restore-file port file) (define (restore-file port file)
"Read a file (possibly a directory structure) in Nar format from PORT. "Read a file (possibly a directory structure) in Nar format from PORT.
Restore it as FILE." Restore it as FILE."
(let ((signature (read-string port))) (parameterize ((currently-restored-file file))
(unless (equal? signature %archive-version-1) (let ((signature (read-string port)))
(raise (unless (equal? signature %archive-version-1)
(condition (&message (message "invalid nar signature")) (raise
(&nar-read-error (port port) (condition (&message (message "invalid nar signature"))
(token signature) (&nar-read-error (port port)
(file #f)))))) (token signature)
(file #f))))))
(let restore ((file file)) (let restore ((file file))
(define (read-eof-marker) (define (read-eof-marker)
(match (read-string port) (match (read-string port)
(")" #t) (")" #t)
(x (raise (x (raise
(condition (condition
(&message (message "invalid nar end-of-file marker")) (&message (message "invalid nar end-of-file marker"))
(&nar-read-error (port port) (file file) (token x))))))) (&nar-read-error (port port) (file file) (token x)))))))
(match (list (read-string port) (read-string port) (read-string port)) (currently-restored-file file)
(("(" "type" "regular")
(call-with-output-file file (cut read-contents port <>)) (match (list (read-string port) (read-string port) (read-string port))
(read-eof-marker)) (("(" "type" "regular")
(("(" "type" "symlink") (call-with-output-file file (cut read-contents port <>))
(match (list (read-string port) (read-string port)) (read-eof-marker))
(("target" target) (("(" "type" "symlink")
(symlink target file) (match (list (read-string port) (read-string port))
(read-eof-marker)) (("target" target)
(x (raise (symlink target file)
(condition (read-eof-marker))
(&message (message "invalid symlink tokens")) (x (raise
(&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 (condition
(&message (message "unexpected directory inter-entry marker")) (&message (message "invalid symlink tokens"))
(&nar-read-error (port port) (file file) (token x))))))))) (&nar-read-error (port port) (file file) (token x)))))))
(x (("(" "type" "directory")
(raise (let ((dir file))
(condition (mkdir dir)
(&message (message "unsupported nar entry type")) (let loop ((prefix (read-string port)))
(&nar-read-error (port port) (file file) (token x)))))))) (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 ;;; serialization.scm ends here

11
tests/nar.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -201,6 +201,15 @@
(lambda () (lambda ()
(rm-rf input))))) (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" (test-assert "write-file + restore-file"
(let* ((input (string-append (dirname (search-path %load-path "guix.scm")) (let* ((input (string-append (dirname (search-path %load-path "guix.scm"))
"/guix")) "/guix"))