;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix serialization)
- #:use-module (guix utils)
+ #:use-module (guix combinators)
#: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 binary-ports)
+ #:use-module ((ice-9 rdelim) #:prefix rdelim:)
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
#:export (write-int read-int
write-long-long read-long-long
write-padding
- write-string read-string read-latin1-string
+ write-bytevector write-string
+ read-string read-latin1-string read-maybe-utf8-string
write-string-list read-string-list
write-string-pairs
write-store-path read-store-path
nar-read-error-token
write-file
+ write-file-tree
restore-file))
;;; Comment:
;; Similar to serialize.cc in Nix.
+(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
+
+(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)
(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
(or (zero? m)
(put-bytevector p zero 0 (- 8 m)))))))
-(define (write-string s p)
- (let* ((s (string->utf8 s))
- (l (bytevector-length s))
- (m (modulo l 8))
+(define* (write-bytevector s p
+ #:optional (l (bytevector-length s)))
+ (let* ((m (modulo l 8))
(b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
(bytevector-u32-set! b 0 l (endianness little))
(bytevector-copy! s 0 b 8 l)
(put-bytevector p b)))
-(define (read-string p)
- (let* ((len (read-int p))
- (m (modulo len 8))
- (bv (get-bytevector-n p len))
- (str (utf8->string bv)))
- (or (zero? m)
- (get-bytevector-n p (- 8 m)))
- str))
+(define (write-string s p)
+ (write-bytevector (string->utf8 s) p))
-(define (read-latin1-string p)
+(define (read-byte-string p)
(let* ((len (read-int p))
(m (modulo len 8))
- ;; 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)))
+ (bv (get-bytevector-n* p len)))
(or (zero? m)
- (get-bytevector-n p (- 8 m)))
+ (get-bytevector-n* p (- 8 m)))
+ bv))
+
+(define (read-string p)
+ (utf8->string (read-byte-string p)))
- ;; XXX: Rewrite using (ice-9 iconv) when the minimum requirement is
- ;; upgraded to Guile >= 2.0.9.
- (list->string (map integer->char (bytevector->u8-list str)))))
+(define (read-latin1-string p)
+ "Read an ISO-8859-1 string from P."
+ ;; 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.
+ (let ((bv (read-byte-string p)))
+ ;; XXX: Rewrite using (ice-9 iconv).
+ (list->string (map integer->char (bytevector->u8-list bv)))))
+
+(define (read-maybe-utf8-string p)
+ "Read a serialized string from port P. Attempt to decode it as UTF-8 and
+substitute invalid byte sequences with question marks. This is a
+\"permissive\" UTF-8 decoder."
+ ;; XXX: We rely on the port's decoding mechanism to do permissive decoding
+ ;; and substitute invalid byte sequences with question marks, but this is
+ ;; not very efficient. Eventually Guile may provide a lightweight
+ ;; permissive UTF-8 decoder.
+ (let* ((bv (read-byte-string p))
+ (port (open-bytevector-input-port bv)))
+ (set-port-encoding! port "UTF-8")
+ (set-port-conversion-strategy! port 'substitute)
+ (rdelim:read-string port)))
(define (write-string-list l p)
(write-int (length l) p)
(define read-store-path-list read-string-list)
\f
-(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
(lambda ()
(close-port port))))))
- (write-string "contents" p)
- (write-long-long size p)
(call-with-binary-input-file file
- ;; Use `sendfile' when available (Guile 2.0.8+).
- (if (and (compile-time-value (defined? 'sendfile))
- (file-port? p))
- (cut sendfile p <> size 0)
- (cut dump <> p size)))
- (write-padding size p))
+ (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)
+ (write-long-long size output)
+ ;; Use 'sendfile' when both OUTPUT and INPUT are file ports.
+ (if (and (file-port? output) (file-port? input))
+ (sendfile output input size 0)
+ (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
(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
;; Magic cookie for Nix archives.
"nix-archive-1")
-(define (write-file file port)
+(define* (write-file file port
+ #:key (select? (const #t)))
+ "Write the contents of FILE to PORT in Nar format, recursing into
+sub-directories of FILE as needed. For each directory entry, call (SELECT?
+FILE STAT), where FILE is the entry's absolute file name and STAT is the
+result of 'lstat'; exclude entries for which SELECT? does not return true."
+ (write-file-tree file port
+ #:file-type+size
+ (lambda (file)
+ (let* ((stat (lstat file))
+ (size (stat:size stat)))
+ (case (stat:type stat)
+ ((directory)
+ (values 'directory size))
+ ((regular)
+ (values (if (zero? (logand (stat:mode stat)
+ #o100))
+ 'regular
+ 'executable)
+ size))
+ (else
+ (values (stat:type stat) size))))) ;bah!
+ #:file-port (cut open-file <> "r0b")
+ #:symlink-target readlink
+
+ #:directory-entries
+ (lambda (directory)
+ ;; 'scandir' defaults to 'string-locale<?' to sort files,
+ ;; but this happens to be case-insensitive (at least in
+ ;; 'en_US' locale on libc 2.18.) Conversely, we want
+ ;; files to be sorted in a case-sensitive fashion.
+ (define basenames
+ (scandir directory (negate (cut member <> '("." "..")))
+ string<?))
+
+ (filter-map (lambda (base)
+ (let ((file (string-append directory
+ "/" base)))
+ (and (select? file (lstat file))
+ base)))
+ basenames))
+
+ ;; The 'scandir' call above gives us filtered and sorted
+ ;; entries, so no post-processing is needed.
+ #:postprocess-entries identity))
+
+(define (filter/sort-directory-entries lst)
+ "Remove dot and dot-dot entries from LST, and sort it in lexicographical
+order."
+ (delete-duplicates
+ (sort (remove (cute member <> '("." "..")) lst)
+ string<?)
+ string=?))
+
+(define* (write-file-tree file port
+ #:key
+ file-type+size
+ file-port
+ symlink-target
+ directory-entries
+ (postprocess-entries filter/sort-directory-entries))
"Write the contents of FILE to PORT in Nar format, recursing into
-sub-directories of FILE as needed."
+sub-directories of FILE as needed.
+
+This procedure does not make any file-system I/O calls. Instead, it calls the
+user-provided FILE-TYPE+SIZE, FILE-PORT, SYMLINK-TARGET, and DIRECTORY-ENTRIES
+procedures, which roughly correspond to 'lstat', 'readlink', and 'scandir'.
+POSTPROCESS-ENTRIES ensures that directory entries are valid; leave it as-is
+unless you know that DIRECTORY-ENTRIES provide filtered and sorted entries, in
+which case you can use 'identity'."
(define p port)
(write-string %archive-version-1 p)
(let dump ((f file))
- (let ((s (lstat f)))
- (write-string "(" p)
- (case (stat:type s)
- ((regular)
- (write-string "type" p)
- (write-string "regular" p)
- (if (not (zero? (logand (stat:mode s) #o100)))
- (begin
- (write-string "executable" p)
- (write-string "" p)))
- (write-contents f p (stat:size s)))
- ((directory)
- (write-string "type" p)
- (write-string "directory" p)
- (let ((entries
- ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories
- ;; unconditionally, including "." and "..", regardless of the
- ;; 'select?' predicate passed to it, so we have to filter
- ;; those out externally.
- (filter (negate (cut member <> '("." "..")))
- ;; 'scandir' defaults to 'string-locale<?' to sort
- ;; files, but this happens to be case-insensitive (at
- ;; least in 'en_US' locale on libc 2.18.) Conversely,
- ;; we want files to be sorted in a case-sensitive
- ;; fashion.
- (scandir f (const #t) string<?))))
- (for-each (lambda (e)
- (let ((f (string-append f "/" e)))
- (write-string "entry" p)
- (write-string "(" p)
- (write-string "name" p)
- (write-string e p)
- (write-string "node" p)
- (dump f)
- (write-string ")" p)))
- entries)))
- ((symlink)
- (write-string "type" p)
- (write-string "symlink" p)
- (write-string "target" p)
- (write-string (readlink f) p))
- (else
- (raise (condition (&message (message "unsupported file type"))
- (&nar-error (file f) (port port))))))
- (write-string ")" p))))
+ (define-values (type size)
+ (file-type+size f))
+
+ (write-string "(" p)
+ (case type
+ ((regular executable)
+ (write-string "type" p)
+ (write-string "regular" p)
+ (when (eq? 'executable type)
+ (write-string "executable" p)
+ (write-string "" p))
+ (let ((input (file-port f)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (write-contents-from-port input p size))
+ (lambda ()
+ (close-port input)))))
+ ((directory)
+ (write-string "type" p)
+ (write-string "directory" p)
+ (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-string e p)
+ (write-string "node" p)
+ (dump f)
+ (write-string ")" p)))
+ entries)))
+ ((symlink)
+ (write-string "type" p)
+ (write-string "symlink" p)
+ (write-string "target" p)
+ (write-string (symlink-target f) p))
+ (else
+ (raise (condition (&message (message "unsupported file type"))
+ (&nar-error (file f) (port port))))))
+ (write-string ")" p)))
+
+(define port-conversion-strategy
+ (fluid->parameter %default-port-conversion-strategy))
(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)
+
+ ;; 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
+ (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)))))))))
+
+;;; Local Variables:
+;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
+;;; End:
;;; serialization.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff