guix_mirror_bot pushed a commit to branch master
in repository guix.
commit 0c1ea038e9ddfc8feab972296c2f31050cbf3728
Author: Ludovic Courtès <[email protected]>
AuthorDate: Sun Nov 16 22:58:50 2025 +0100
serialization: Formally declare serializable types.
* guix/serialization.scm (write-boolean, read-boolean)
(read-base16, write-base16): New procedures.
(<substitutable>, <path-info>): New record types.
(read-substitutable-path-list, read-path-info): New procedures.
(define-serializable-types): New macro.
<top level>: Use it.
* guix/store.scm (<substitutable>, <path-info>)
(read-substitutable-path-list, read-path-info): Move to serialization.scm.
(read-arg, write-arg): Remove.
* guix/store.scm (open-connection, process-stderr)
(add-to-store, add-file-tree-to-store, run-gc)
(export-path, export-paths): Use ‘write-value’ and ‘read-value’.
(store-path): Rename to…
(make-store-path): … this.
(output-path, fixed-output-path): Adjust accordingly.
Change-Id: I0b8863e48cb59205fa7812e8202f9a175ec8606b
Signed-off-by: Ludovic Courtès <[email protected]>
---
guix/serialization.scm | 152 +++++++++++++++++++++++++++++--
guix/store.scm | 239 +++++++++++++++----------------------------------
2 files changed, 221 insertions(+), 170 deletions(-)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 9656e5ac2a..d6ebc27833 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021
Ludovic Courtès <[email protected]>
+;;; Copyright © 2012-2021, 2025 Ludovic Courtès <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,8 +17,11 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix serialization)
+ #:autoload (guix base16) (base16-string->bytevector
+ bytevector->base16-string)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@@ -27,16 +30,23 @@
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
#:use-module (system foreign)
- #:export (write-int read-int
+ #:export (write-value
+ read-value
+ write-bytevector
+ read-maybe-utf8-string
+ (dump . dump-port*)
+
+ ;; The following bindings are exported for backward compatibility
+ ;; but one should use 'read-value' and 'write-value' instead.
+ 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
+ read-string read-latin1-string
write-string-list read-string-list
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?
@@ -49,6 +59,21 @@
write-file
write-file-tree
+
+ substitutable?
+ substitutable-path
+ substitutable-deriver
+ substitutable-references
+ substitutable-download-size
+ substitutable-nar-size
+
+ path-info?
+ path-info-deriver
+ path-info-hash
+ path-info-references
+ path-info-registration-time
+ path-info-nar-size
+
fold-archive
restore-file
dump-file))
@@ -101,6 +126,12 @@
(let ((b (get-bytevector-n* p 8)))
(bytevector-u32-ref b 0 (endianness little))))
+(define (write-boolean b p)
+ (write-int (if b 1 0) p))
+
+(define (read-boolean p)
+ (not (zero? (read-int p))))
+
(define (write-long-long n p)
(let ((b (make-bytevector 8 0)))
(bytevector-u64-set! b 0 n (endianness little))
@@ -161,6 +192,12 @@ substitute invalid byte sequences with question marks.
This is a
(set-port-conversion-strategy! port 'substitute)
(rdelim:read-string port)))
+(define (read-base16 p)
+ (base16-string->bytevector (read-string p)))
+
+(define (write-base16 bv p)
+ (write-string (bytevector->base16-string bv) p))
+
(define (write-string-list l p)
(write-int (length l) p)
(for-each (cut write-string <> p) l))
@@ -229,6 +266,111 @@ any run-time allocations or computations."
bytes)
#`(put-bytevector port #,bv))))))
+;; Information about a substitutable store path.
+(define-record-type <substitutable>
+ (substitutable path deriver refs dl-size nar-size)
+ substitutable?
+ (path substitutable-path)
+ (deriver substitutable-deriver)
+ (refs substitutable-references)
+ (dl-size substitutable-download-size)
+ (nar-size substitutable-nar-size))
+
+(define (read-substitutable-path-list p)
+ (let loop ((len (read-int p))
+ (result '()))
+ (if (zero? len)
+ (reverse result)
+ (let ((path (read-store-path p))
+ (deriver (read-store-path p))
+ (refs (read-store-path-list p))
+ (dl-size (read-long-long p))
+ (nar-size (read-long-long p)))
+ (loop (- len 1)
+ (cons (substitutable path deriver refs dl-size nar-size)
+ result))))))
+
+;; Information about a store path.
+(define-record-type <path-info>
+ (make-path-info deriver hash references registration-time nar-size)
+ path-info?
+ (deriver path-info-deriver) ;string | #f
+ (hash path-info-hash)
+ (references path-info-references)
+ (registration-time path-info-registration-time)
+ (nar-size path-info-nar-size))
+
+(define (read-path-info p)
+ (let ((deriver (match (read-store-path p)
+ ("" #f)
+ (x x)))
+ (hash (base16-string->bytevector (read-string p)))
+ (refs (read-store-path-list p))
+ (registration-time (read-int p))
+ (nar-size (read-long-long p)))
+ (make-path-info deriver hash refs registration-time nar-size)))
+
+(define-syntax define-serializable-types
+ (syntax-rules ()
+ "Define READ-ANY and WRITE-ANY as macros that dispatch serialization and
+deserialization of known data types. These two macros can then be used like
so:
+
+ (READ-ANY integer PORT)
+
+and:
+
+ (WRITE-ANY store-path VALUE PORT)
+
+The former returns the value it read; the latter returns the unspecified
+value."
+ ((_ read-any write-any (type read write) ...)
+ (begin
+ ;; Define syntactic keywords.
+ (define-syntax type
+ (lambda (s)
+ #`(syntax-error "invalid use of serializable type name" #,s)))
+ ...
+ (export type ...)
+
+ (define-syntax write-any
+ (syntax-rules (type ...)
+ "Write the following TYPE value to the given port."
+ ((_ type arg port)
+ (write arg port))
+ ...))
+ (define-syntax read-any
+ (syntax-rules (type ...)
+ "Read from the given port a value of TYPE."
+ ((_ type port)
+ (read port))
+ ...))))))
+
+(define no-op (const #t))
+
+;; Serializable types known to the client/daemon protocol.
+(define-serializable-types read-value write-value
+ (integer read-int write-int)
+ (long-long read-long-long write-long-long)
+ (boolean read-boolean write-boolean)
+ (bytevector read-byte-string write-bytevector)
+ (string read-string write-string)
+ (string-list read-string-list write-string-list)
+ (string-pairs read-string-pairs write-string-pairs)
+ (store-path read-store-path write-store-path)
+ (store-path-list read-store-path-list write-store-path-list)
+ (base16 read-base16 write-base16)
+ (path-info read-path-info write-path-info/not-implemented)
+ (substitutable-path-list read-substitutable-path-list
+ write-substitutable-path-list/not-implemented)
+
+ ;; When reading a file, just return the input port and let the caller (a
+ ;; server) call 'restore-file' or whatever is relevant for the operation.
+ (file identity write-file)
+
+ ;; User-provided as used in the 'export-path' and 'import-paths' remote
+ ;; procedures.
+ (stream no-op no-op))
+
(define-condition-type &nar-read-error &nar-error
nar-read-error?
diff --git a/guix/store.scm b/guix/store.scm
index 42f3246f99..45dc275ab1 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2024 Ludovic Courtès <[email protected]>
+;;; Copyright © 2012-2025 Ludovic Courtès <[email protected]>
;;; Copyright © 2018 Jan Nieuwenhuizen <[email protected]>
;;; Copyright © 2019, 2020 Mathieu Othacehe <[email protected]>
;;; Copyright © 2020 Florian Pelz <[email protected]>
@@ -55,6 +55,22 @@
uri-host
uri-port
uri-path)
+
+ ;; Bindings re-exported for backward compatibility.
+ #:re-export (substitutable?
+ substitutable-path
+ substitutable-deriver
+ substitutable-references
+ substitutable-download-size
+ substitutable-nar-size
+
+ path-info?
+ path-info-deriver
+ path-info-hash
+ path-info-references
+ path-info-registration-time
+ path-info-nar-size)
+
#:export (%daemon-socket-uri
%gc-roots-directory
%default-substitute-urls
@@ -133,23 +149,10 @@
add-permanent-root
remove-permanent-root
- substitutable?
- substitutable-path
- substitutable-deriver
- substitutable-references
- substitutable-download-size
- substitutable-nar-size
has-substitutes?
substitutable-paths
substitutable-path-info
- path-info?
- path-info-deriver
- path-info-hash
- path-info-references
- path-info-registration-time
- path-info-nar-size
-
built-in-builders
substitute-urls
references
@@ -194,7 +197,7 @@
grafting?
%store-prefix
- store-path
+ (make-store-path . store-path)
output-path
fixed-output-path
store-path?
@@ -291,100 +294,6 @@
(make-parameter (or (getenv "GUIX_DAEMON_SOCKET")
%default-socket-path)))
-
-
-;; Information about a substitutable store path.
-(define-record-type <substitutable>
- (substitutable path deriver refs dl-size nar-size)
- substitutable?
- (path substitutable-path)
- (deriver substitutable-deriver)
- (refs substitutable-references)
- (dl-size substitutable-download-size)
- (nar-size substitutable-nar-size))
-
-(define (read-substitutable-path-list p)
- (let loop ((len (read-int p))
- (result '()))
- (if (zero? len)
- (reverse result)
- (let ((path (read-store-path p))
- (deriver (read-store-path p))
- (refs (read-store-path-list p))
- (dl-size (read-long-long p))
- (nar-size (read-long-long p)))
- (loop (- len 1)
- (cons (substitutable path deriver refs dl-size nar-size)
- result))))))
-
-;; Information about a store path.
-(define-record-type <path-info>
- (path-info deriver hash references registration-time nar-size)
- path-info?
- (deriver path-info-deriver) ;string | #f
- (hash path-info-hash)
- (references path-info-references)
- (registration-time path-info-registration-time)
- (nar-size path-info-nar-size))
-
-(define (read-path-info p)
- (let ((deriver (match (read-store-path p)
- ("" #f)
- (x x)))
- (hash (base16-string->bytevector (read-string p)))
- (refs (read-store-path-list p))
- (registration-time (read-int p))
- (nar-size (read-long-long p)))
- (path-info deriver hash refs registration-time nar-size)))
-
-(define-syntax write-arg
- (syntax-rules (integer boolean bytevector
- string string-list string-pairs
- store-path store-path-list base16)
- ((_ integer arg p)
- (write-int arg p))
- ((_ boolean arg p)
- (write-int (if arg 1 0) p))
- ((_ bytevector arg p)
- (write-bytevector arg p))
- ((_ string arg p)
- (write-string arg p))
- ((_ string-list arg p)
- (write-string-list arg p))
- ((_ string-pairs arg p)
- (write-string-pairs arg p))
- ((_ store-path arg p)
- (write-store-path arg p))
- ((_ store-path-list arg p)
- (write-store-path-list arg p))
- ((_ base16 arg p)
- (write-string (bytevector->base16-string arg) p))))
-
-(define-syntax read-arg
- (syntax-rules (integer boolean string store-path
- store-path-list string-list string-pairs
- substitutable-path-list path-info base16)
- ((_ integer p)
- (read-int p))
- ((_ boolean p)
- (not (zero? (read-int p))))
- ((_ string p)
- (read-string p))
- ((_ store-path p)
- (read-store-path p))
- ((_ store-path-list p)
- (read-store-path-list p))
- ((_ string-list p)
- (read-string-list p))
- ((_ string-pairs p)
- (read-string-pairs p))
- ((_ substitutable-path-list p)
- (read-substitutable-path-list p))
- ((_ path-info p)
- (read-path-info p))
- ((_ base16 p)
- (base16-string->bytevector (read-string p)))))
-
;; remote-store.cc
@@ -596,23 +505,23 @@ daemon. Return a server object."
((output flush)
(buffering-output-port port
(make-bytevector 8192))))
- (write-int %worker-magic-1 port)
- (let ((r (read-int port)))
+ (write-value integer %worker-magic-1 port)
+ (let ((r (read-value integer port)))
(unless (= r %worker-magic-2)
(handshake-error))
- (let ((v (read-int port)))
+ (let ((v (read-value integer port)))
(unless (= (protocol-major %protocol-version)
(protocol-major v))
(handshake-error))
- (write-int %protocol-version port)
+ (write-value integer %protocol-version port)
(when (>= (protocol-minor v) 14)
- (write-int (if cpu-affinity 1 0) port)
+ (write-value integer (if cpu-affinity 1 0) port)
(when cpu-affinity
- (write-int cpu-affinity port)))
+ (write-value integer cpu-affinity port)))
(when (>= (protocol-minor v) 11)
- (write-int (if reserve-space? 1 0) port))
+ (write-value integer (if reserve-space? 1 0) port))
(letrec* ((actual-built-in-builders
(if built-in-builders
(delay built-in-builders)
@@ -744,10 +653,10 @@ encoding conversion errors."
(define %stderr-last #x616c7473) ; "alts", we're done
(define %stderr-error #x63787470) ; "cxtp", error reporting
- (let ((k (read-int p)))
+ (let ((k (read-value integer p)))
(cond ((= k %stderr-write)
;; Write a byte stream to USER-PORT.
- (let* ((len (read-int p))
+ (let* ((len (read-value integer p))
(m (modulo len 8)))
(dump-port p user-port len
#:buffer-size (if (<= len 16384) 16384 65536))
@@ -759,7 +668,7 @@ encoding conversion errors."
;; Read a byte stream from USER-PORT.
;; Note: Avoid 'get-bytevector-n' to work around
;; <http://bugs.gnu.org/17591> in Guile up to 2.0.11.
- (let* ((max-len (read-int p))
+ (let* ((max-len (read-value integer p))
(data (make-bytevector max-len))
(len (get-bytevector-n! user-port data 0 max-len)))
(write-bytevector data p len)
@@ -781,7 +690,7 @@ encoding conversion errors."
;; errors like DB schema version mismatches, so check for EOF.
(status (if (and (>= (store-connection-minor-version server)
8)
(not (eof-object? (lookahead-u8 p))))
- (read-int p)
+ (read-value integer p)
1)))
(raise (condition (&store-protocol-error
(message error)
@@ -864,9 +773,9 @@ encoding conversion errors."
(let-syntax ((send (syntax-rules ()
((_ (type option) ...)
(begin
- (write-arg type option buffered)
+ (write-value type option buffered)
...)))))
- (write-int (operation-id set-options) buffered)
+ (write-value integer (operation-id set-options) buffered)
(send (boolean keep-failed?) (boolean keep-going?)
(boolean fallback?) (integer verbosity))
(when (< (store-connection-minor-version server) #x61)
@@ -1018,15 +927,15 @@ bytevector) as its internal buffer, and a thunk to flush
this output port."
(let* ((s (store-connection-socket server))
(buffered (store-connection-output-port server)))
(record-operation 'name)
- (write-int (operation-id name) buffered)
- (write-arg type arg buffered)
+ (write-value integer (operation-id name) buffered)
+ (write-value type arg buffered)
...
(write-buffered-output server)
;; Loop until the server is done sending error output.
(let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server))))
- (values (read-arg return s) ...))))))
+ (values (read-value return s) ...))))))
(define-syntax-rule (define-operation (name args ...)
docstring return ...)
@@ -1144,16 +1053,16 @@ path."
(record-operation 'add-to-store)
(let ((port (store-connection-socket server))
(buffered (store-connection-output-port server)))
- (write-int (operation-id add-to-store) buffered)
- (write-string basename buffered)
- (write-int 1 buffered) ;obsolete, must be #t
- (write-int (if recursive? 1 0) buffered)
- (write-string hash-algo buffered)
+ (write-value integer (operation-id add-to-store) buffered)
+ (write-value string basename buffered)
+ (write-value integer 1 buffered) ;obsolete,
must be #t
+ (write-value boolean recursive? buffered)
+ (write-value string hash-algo buffered)
(write-file file-name buffered #:select? select?)
(write-buffered-output server)
(let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server))))
- (read-store-path port)))))
+ (read-value store-path port)))))
(lambda* (server basename recursive? hash-algo file-name
#:key (select? true))
"Add the contents of FILE-NAME under BASENAME to the store
@@ -1258,11 +1167,11 @@ an arbitrary directory layout in the store without
creating a derivation."
(record-operation 'add-to-store/tree)
(let ((port (store-connection-socket server))
(buffered (store-connection-output-port server)))
- (write-int (operation-id add-to-store) buffered)
- (write-string basename buffered)
- (write-int 1 buffered) ;obsolete, must be #t
- (write-int (if recursive? 1 0) buffered)
- (write-string hash-algo buffered)
+ (write-value integer (operation-id add-to-store) buffered)
+ (write-value string basename buffered)
+ (write-value integer 1 buffered) ;obsolete,
must be #t
+ (write-value integer (if recursive? 1 0) buffered)
+ (write-value string hash-algo buffered)
(write-file-tree basename buffered
#:file-type+size file-type+size
#:file-port file-port
@@ -1271,7 +1180,7 @@ an arbitrary directory layout in the store without
creating a derivation."
(write-buffered-output server)
(let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server))))
- (let ((result (read-store-path port)))
+ (let ((result (read-value store-path port)))
(hash-set! cache tree result)
result)))))
@@ -1688,25 +1597,25 @@ bytes, before the GC can stop. Return the list of
store paths delete,
and the number of bytes freed."
(let ((s (store-connection-socket server))
(buffered (store-connection-output-port server)))
- (write-int (operation-id collect-garbage) buffered)
- (write-int action buffered)
- (write-store-path-list to-delete buffered)
- (write-arg boolean #f buffered) ; ignore-liveness?
- (write-long-long min-freed buffered)
- (write-int 0 buffered) ; obsolete
+ (write-value integer (operation-id collect-garbage) buffered)
+ (write-value integer action buffered)
+ (write-value store-path-list to-delete buffered)
+ (write-value boolean #f buffered) ;ignore-liveness?
+ (write-value long-long min-freed buffered)
+ (write-value integer 0 buffered) ;obsolete
(when (>= (store-connection-minor-version server) 5)
;; Obsolete `use-atime' and `max-atime' parameters.
- (write-int 0 buffered)
- (write-int 0 buffered))
+ (write-value integer 0 buffered)
+ (write-value integer 0 buffered))
(write-buffered-output server)
;; Loop until the server is done sending error output.
(let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server))))
- (let ((paths (read-store-path-list s))
- (freed (read-long-long s))
- (obsolete (read-long-long s)))
+ (let ((paths (read-value store-path-list s))
+ (freed (read-value long-long s))
+ (obsolete (read-value long-long s)))
(unless (null? paths)
;; To be on the safe side, completely invalidate both caches.
;; Otherwise we could end up returning store paths that are no longer
@@ -1748,22 +1657,22 @@ collected, and the number of bytes freed."
is raised if the set of paths read from PORT is not signed (as per
'export-path #:sign? #t'.) Return the list of store paths imported."
(let ((s (store-connection-socket server)))
- (write-int (operation-id import-paths) s)
+ (write-value integer (operation-id import-paths) s)
(let loop ((done? (process-stderr server port)))
(or done? (loop (process-stderr server port))))
- (read-store-path-list s)))
+ (read-value store-path-list s)))
(define* (export-path server path port #:key (sign? #t))
"Export PATH to PORT. When SIGN? is true, sign it."
(let ((s (store-connection-socket server))
(buffered (store-connection-output-port server)))
- (write-int (operation-id export-path) buffered)
- (write-store-path path buffered)
- (write-arg boolean sign? buffered)
+ (write-value integer (operation-id export-path) buffered)
+ (write-value store-path path buffered)
+ (write-value boolean sign? buffered)
(write-buffered-output server)
(let loop ((done? (process-stderr server port)))
(or done? (loop (process-stderr server port))))
- (= 1 (read-int s))))
+ (= 1 (read-value integer s))))
(define* (export-paths server paths port #:key (sign? #t) recursive?
(start (const #f))
@@ -1792,9 +1701,9 @@ itself. FINISH is called when the last store item has
been called."
(match paths
(()
(apply finish state)
- (write-int 0 port))
+ (write-value integer 0 port))
((head tail ...)
- (write-int 1 port)
+ (write-value integer 1 port)
(and (export-path server head port #:sign? sign?)
(loop tail
(call-with-values
@@ -2273,7 +2182,7 @@ in SIZE bytes."
(logxor o (bytevector-u8-ref bv i)))
(loop (+ 1 i))))))
-(define (store-path type hash name) ; makeStorePath
+(define (make-store-path type hash name) ; makeStorePath
"Return the store path for NAME/HASH/TYPE."
(let* ((s (string-append type ":sha256:"
(bytevector->base16-string hash) ":"
@@ -2287,10 +2196,10 @@ in SIZE bytes."
(define (output-path output hash name) ; makeOutputPath
"Return an output path for OUTPUT (the name of the output as a string) of
the derivation called NAME with hash HASH."
- (store-path (string-append "output:" output) hash
- (if (string=? output "out")
- name
- (string-append name "-" output))))
+ (make-store-path (string-append "output:" output) hash
+ (if (string=? output "out")
+ name
+ (string-append name "-" output))))
(define* (fixed-output-path name hash
#:key
@@ -2301,14 +2210,14 @@ the derivation called NAME with hash HASH."
HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for
'add-to-store'."
(if (and recursive? (eq? hash-algo 'sha256))
- (store-path "source" hash name)
+ (make-store-path "source" hash name)
(let ((tag (string-append "fixed:" output ":"
(if recursive? "r:" "")
(symbol->string hash-algo) ":"
(bytevector->base16-string hash) ":")))
- (store-path (string-append "output:" output)
- (sha256 (string->utf8 tag))
- name))))
+ (make-store-path (string-append "output:" output)
+ (sha256 (string->utf8 tag))
+ name))))
(define (store-path? path)
"Return #t if PATH is a store path."
