nar: Implement restoration from Nar.
* guix/nar.scm (&nar-error, &nar-read-error): New condition types. (dump): New procedure. (write-contents)[dump]: Remove. Use the one above instead. (read-contents, write-file, restore-file): New procedures. (%archive-version-1): New variable.
This commit is contained in:
Ludovic Courtès
parent
52e5910cdc
commit
53c63ee937
|
|
@ -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 \
|
||||
|
|
|
|||
150
guix/nar.scm
150
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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
Loading…
Reference in New Issue