;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module ((ice-9 rdelim) #:prefix rdelim:)
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
+ #:use-module (system foreign)
#:export (write-int read-int
write-long-long read-long-long
write-padding
write-bytevector write-string
read-string read-latin1-string read-maybe-utf8-string
write-string-list read-string-list
- write-string-pairs
+ write-string-pairs read-string-pairs
write-store-path read-store-path
write-store-path-list read-store-path-list
+ (dump . dump-port*)
&nar-error
nar-error?
write-file
write-file-tree
- restore-file))
+ fold-archive
+ restore-file
+ dump-file))
;;; Comment:
;;;
;; Similar to serialize.cc in Nix.
-(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ?
+(define-condition-type &nar-error &error ; XXX: inherit from &store-error ?
nar-error?
(file nar-error-file) ; file we were restoring, or #f
(port nar-error-port)) ; port from which we read
(port port)))))
bv))
+(define (sub-bytevector bv len)
+ "Return a bytevector that aliases the first LEN bytes of BV."
+ (define max (bytevector-length bv))
+ (cond ((= len max) bv)
+ ((< len max)
+ ;; Yes, this is safe because the result of each conversion procedure
+ ;; has its life cycle synchronized with that of its argument.
+ (pointer->bytevector (bytevector->pointer bv) len))
+ (else
+ (error "sub-bytevector called to get a super bytevector"))))
+
(define (write-int n p)
(let ((b (make-bytevector 8 0)))
(bytevector-u32-set! b 0 n (endianness little))
(define (read-byte-string p)
(let* ((len (read-int p))
(m (modulo len 8))
- (bv (get-bytevector-n* p len)))
- (or (zero? m)
- (get-bytevector-n* p (- 8 m)))
- bv))
+ (pad (if (zero? m) 0 (- 8 m)))
+ (bv (get-bytevector-n* p (+ len pad))))
+ (sub-bytevector bv len)))
(define (read-string p)
(utf8->string (read-byte-string p)))
(write-int (length l) p)
(for-each (cut write-string <> p) l))
+(define (read-string-list p)
+ (let ((len (read-int p)))
+ (unfold (cut >= <> len)
+ (lambda (i)
+ (read-string p))
+ 1+
+ 0)))
+
(define (write-string-pairs l p)
(write-int (length l) p)
(for-each (match-lambda
(write-string second p)))
l))
-(define (read-string-list p)
+(define (read-string-pairs p)
(let ((len (read-int p)))
(unfold (cut >= <> len)
(lambda (i)
- (read-string p))
+ (cons (read-string p) (read-string p)))
1+
0)))
(define write-store-path-list write-string-list)
(define read-store-path-list read-string-list)
+(define-syntax write-literal-strings
+ (lambda (s)
+ "Write the given literal strings to PORT in an optimized fashion, without
+any run-time allocations or computations."
+ (define (padding len)
+ (let ((m (modulo len 8)))
+ (if (zero? m)
+ 0
+ (- 8 m))))
+
+ (syntax-case s ()
+ ((_ port strings ...)
+ (let* ((bytes (map string->utf8 (syntax->datum #'(strings ...))))
+ (len (fold (lambda (bv size)
+ (+ size 8 (bytevector-length bv)
+ (padding (bytevector-length bv))))
+ 0
+ bytes))
+ (bv (make-bytevector len))
+ (zeros (make-bytevector 8 0)))
+ (fold (lambda (str offset)
+ (let ((len (bytevector-length str)))
+ (bytevector-u32-set! bv offset len (endianness little))
+ (bytevector-copy! str 0 bv (+ 8 offset) len)
+ (bytevector-copy! zeros 0 bv (+ 8 offset len)
+ (padding len))
+ (+ offset 8 len (padding len))))
+ 0
+ bytes)
+ #`(put-bytevector port #,bv))))))
+
\f
(define-condition-type &nar-read-error &nar-error
nar-read-error?
(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)
- ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus
- ;; avoids any initial buffering. Disable file name canonicalization to
- ;; avoid stat'ing like crazy.
- (with-fluids ((%file-port-name-canonicalization #f))
- (let ((port (open-file file "rb")))
- (dynamic-wind
- (const #t)
- (cut proc port)
- (lambda ()
- (close-port port))))))
-
- (call-with-binary-input-file file
- (lambda (input)
- (write-contents-from-port input p size))))
-
(define (write-contents-from-port input output size)
"Write SIZE bytes from port INPUT to port OUTPUT."
(write-string "contents" output)
(dump input output size))
(write-padding size output))
-(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 (read-file-type port)
+ "Read the file type tag from PORT, and return either 'regular or
+'executable."
+ (match (read-string port)
+ ("contents"
+ 'regular)
+ ("executable"
+ (match (list (read-string port) (read-string port))
+ (("" "contents") 'executable)
+ (x (raise
+ (condition (&message
+ (message "unexpected executable file marker"))
+ (&nar-read-error (port port)
+ (file #f)
+ (token x)))))))
+ (x
+ (raise
+ (condition (&message (message "unsupported nar file type"))
+ (&nar-read-error (port port) (file #f) (token x)))))))
(define %archive-version-1
;; Magic cookie for Nix archives.
(define-values (type size)
(file-type+size f))
- (write-string "(" p)
+ (write-literal-strings p "(")
(case type
((regular executable)
- (write-string "type" p)
- (write-string "regular" p)
+ (write-literal-strings p "type" "regular")
(when (eq? 'executable type)
- (write-string "executable" p)
- (write-string "" p))
+ (write-literal-strings p "executable" ""))
(let ((input (file-port f)))
(dynamic-wind
(const #t)
(lambda ()
(close-port input)))))
((directory)
- (write-string "type" p)
- (write-string "directory" p)
+ (write-literal-strings p "type" "directory")
(let ((entries (postprocess-entries (directory-entries f))))
(for-each (lambda (e)
(let* ((f (string-append f "/" e)))
- (write-string "entry" p)
- (write-string "(" p)
- (write-string "name" p)
+ (write-literal-strings p "entry" "(" "name")
(write-string e p)
- (write-string "node" p)
+ (write-literal-strings p "node")
(dump f)
- (write-string ")" p)))
+ (write-literal-strings p ")")))
entries)))
((symlink)
- (write-string "type" p)
- (write-string "symlink" p)
- (write-string "target" p)
+ (write-literal-strings p "type" "symlink" "target")
(write-string (symlink-target f) p))
(else
(raise (condition (&message (message "unsupported file type"))
(&nar-error (file f) (port port))))))
- (write-string ")" p)))
+ (write-literal-strings p ")")))
-(define (restore-file port file)
- "Read a file (possibly a directory structure) in Nar format from PORT.
-Restore it as FILE."
- (parameterize ((currently-restored-file file))
+(define port-conversion-strategy
+ (fluid->parameter %default-port-conversion-strategy))
+
+(define (fold-archive proc seed port file)
+ "Read a file (possibly a directory structure) in Nar format from PORT. Call
+PROC on each file or directory read from PORT using:
+
+ (PROC FILE TYPE CONTENTS RESULT)
+
+using SEED as the first RESULT. TYPE is a symbol like 'regular, and CONTENTS
+depends on TYPE."
+ (parameterize ((currently-restored-file file)
+
+ ;; Error out if we can convert file names to the current
+ ;; locale. (XXX: We'd prefer UTF-8 encoding for file names
+ ;; regardless of the locale, but that's what Guile gives us
+ ;; so far.)
+ (port-conversion-strategy 'error))
(let ((signature (read-string port)))
(unless (equal? signature %archive-version-1)
(raise
(token signature)
(file #f))))))
- (let restore ((file file))
+ (let read ((file file)
+ (result seed))
(define (read-eof-marker)
(match (read-string port)
(")" #t)
(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))
+ (let* ((type (read-file-type port))
+ (size (read-long-long port))
+
+ ;; The caller must read exactly SIZE bytes from PORT.
+ (result (proc file type `(,port . ,size) result)))
+ (let ((m (modulo size 8)))
+ (unless (zero? m)
+ (get-bytevector-n* port (- 8 m))))
+ (read-eof-marker)
+ result))
(("(" "type" "symlink")
(match (list (read-string port) (read-string port))
(("target" target)
- (symlink target file)
- (read-eof-marker))
+ (let ((result (proc file 'symlink target result)))
+ (read-eof-marker)
+ result))
(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)))
+ (let loop ((prefix (read-string port))
+ (result (proc file 'directory #f result)))
(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
+ (let ((result (read (string-append dir "/" file) result)))
+ (match (read-string port)
+ (")" #f)
+ (x
+ (raise
+ (condition
+ (&message
+ (message "unexpected directory entry termination"))
+ (&nar-read-error (port port)
+ (file file)
+ (token x))))))
+ (loop (read-string port) result)))))
+ (")" ;done with DIR
+ (proc file 'directory-complete #f result))
(x
(raise
(condition
(&message (message "unsupported nar entry type"))
(&nar-read-error (port port) (file file) (token x)))))))))
+(define (dump-file file input size type)
+ "Dump SIZE bytes from INPUT to FILE.
+
+This procedure is suitable for use as the #:dump-file argument to
+'restore-file'."
+ (call-with-output-file file
+ (lambda (output)
+ (dump input output size))))
+
+(define* (restore-file port file
+ #:key (dump-file dump-file))
+ "Read a file (possibly a directory structure) in Nar format from PORT.
+Restore it as FILE with canonical permissions and timestamps. To write a
+regular or executable file, call:
+
+ (DUMP-FILE FILE INPUT SIZE TYPE)
+
+The default is to dump SIZE bytes from INPUT to FILE, but callers can provide
+a custom procedure, for instance to deduplicate FILE on the fly."
+ (fold-archive (lambda (file type content result)
+ (match type
+ ('directory
+ (mkdir file))
+ ('directory-complete
+ (chmod file #o555)
+ (utime file 1 1 0 0))
+ ('symlink
+ (symlink content file)
+ (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW))
+ ((or 'regular 'executable)
+ (match content
+ ((input . size)
+ (dump-file file input size type)
+ (chmod file (if (eq? type 'executable)
+ #o555
+ #o444))
+ (utime file 1 1 0 0))))))
+ #t
+ port
+ file))
+
;;; Local Variables:
;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
;;; End: