guix/guix/serialization.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012-2021, 2025, 2026 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 (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)
  #:use-module (ice-9 binary-ports)
  #:use-module ((ice-9 rdelim) #:prefix rdelim:)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:autoload   (system foreign) (pointer->bytevector bytevector->pointer)
  #: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-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

            &nar-error
            nar-error?
            nar-error-port
            nar-error-file

            &nar-read-error
            nar-read-error?
            nar-read-error-token

            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))

;;; Comment:
;;;
;;; Serialization procedures used by the RPCs and the Nar format.  This module
;;; is for internal consumption.
;;;
;;; Code:

;; 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 sub-bytevector
  ;; 'bytevector-slice' was added in Guile 3.0.9, but this code might be
  ;; running on older versions of Guile when running 'guix pull' from 1.4.0
  ;; for instance.
  (match (and=> (false-if-exception
              (resolve-interface '(rnrs bytevectors gnu)))
             (lambda (module)
               (module-ref module 'bytevector-slice)))
    (#f
     (lambda (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")))))
    (slice
     (cut slice <> 0 <>))))

(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)))
    (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))
    (put-bytevector p b)))

(define (read-long-long p)
  (let ((b (get-bytevector-n* p 8)))
    (bytevector-u64-ref b 0 (endianness little))))

(define write-padding
  (let ((zero (make-bytevector 8 0)))
    (lambda (n p)
      (let ((m (modulo n 8)))
        (or (zero? m)
            (put-bytevector p zero 0 (- 8 m)))))))

(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 (write-string s p)
  (write-bytevector (string->utf8 s) p))

(define (read-byte-string p)
  (let* ((len (read-int p))
         (m   (modulo len 8))
         (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)))

(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 (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))

(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
             ((first . second)
              (write-string first p)
              (write-string second p)))
            l))

(define (read-string-pairs p)
  (let ((len (read-int p)))
    (unfold (cut >= <> len)
            (lambda (i)
              (cons (read-string p) (read-string p)))
            1+
            0)))

(define (write-store-path f p)
  (write-string f p))                             ; TODO: assert path

(define (read-store-path p)
  (read-string p))                                ; TODO: assert path

(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))))))

;; 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)
  (utf8-string     read-string write-string)   ;avoid name clash with '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?
  (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-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-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.
  "nix-archive-1")

(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.

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))
    (define-values (type size)
      (file-type+size f))

    (write-literal-strings p "(")
    (case type
      ((regular executable)
       (write-literal-strings p "type" "regular")
       (when (eq? 'executable type)
         (write-literal-strings p "executable" ""))
       (let ((input (file-port f)))
         (dynamic-wind
           (const #t)
           (lambda ()
             (write-contents-from-port input p size))
           (lambda ()
             (close-port input)))))
      ((directory)
       (write-literal-strings p "type" "directory")
       (let ((entries (postprocess-entries (directory-entries f))))
         (for-each (lambda (e)
                     (let* ((f (string-append f "/" e)))
                       (write-literal-strings p "entry" "(" "name")
                       (write-string e p)
                       (write-literal-strings p "node")
                       (dump f)
                       (write-literal-strings p ")")))
                   entries)))
      ((symlink)
       (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-literal-strings p ")")))

(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
         (condition (&message (message "invalid nar signature"))
                    (&nar-read-error (port port)
                                     (token signature)
                                     (file #f))))))

    (let read ((file file)
               (result seed))
      (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")
         (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)
            (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))
           (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")
                   (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 "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)))))))))

(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:

;;; serialization.scm ends here