#:export (write-int read-int
write-long-long read-long-long
write-padding
- write-string read-string read-latin1-string
+ 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
;; 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)
(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
(bytevector-copy! s 0 b 8 l)
(put-bytevector p b)))
-(define (read-string p)
+(define (read-byte-string p)
(let* ((len (read-int p))
(m (modulo len 8))
- (bv (get-bytevector-n p len))
- (str (utf8->string bv)))
+ (bv (get-bytevector-n* p len)))
(or (zero? m)
- (get-bytevector-n p (- 8 m)))
- str))
+ (get-bytevector-n* p (- 8 m)))
+ bv))
-(define (read-latin1-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)))
- (or (zero? m)
- (get-bytevector-n p (- 8 m)))
+(define (read-string p)
+ (utf8->string (read-byte-string p)))
+(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) when the minimum requirement is
;; upgraded to Guile >= 2.0.9.
- (list->string (map integer->char (bytevector->u8-list str)))))
+ (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)
+ (get-string-all 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
(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
(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<?))))
+ ;; '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 (negate (cut member <> '("." ".."))) string<?)))
(for-each (lambda (e)
(let ((f (string-append f "/" e)))
(write-string "entry" 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))
- (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
HCoop / jackhill / guix / guix.git / blobdiff