guix/serialization.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix serialization)
  20   #:use-module (guix combinators)
  21   #:use-module (rnrs bytevectors)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-26)
  24   #:use-module (srfi srfi-34)
  25   #:use-module (srfi srfi-35)
  26   #:use-module (ice-9 binary-ports)
  27   #:use-module ((ice-9 rdelim) #:prefix rdelim:)
  28   #:use-module (ice-9 match)
  29   #:use-module (ice-9 ftw)
  30   #:export (write-int read-int
  31             write-long-long read-long-long
  32             write-padding
  33             write-bytevector write-string
  34             read-string read-latin1-string read-maybe-utf8-string
  35             write-string-list read-string-list
  36             write-string-pairs
  37             write-store-path read-store-path
  38             write-store-path-list read-store-path-list
  39
  40             &nar-error
  41             nar-error?
  42             nar-error-port
  43             nar-error-file
  44
  45             &nar-read-error
  46             nar-read-error?
  47             nar-read-error-token
  48
  49             write-file
  50             write-file-tree
  51             restore-file))
  52
  53 ;;; Comment:
  54 ;;;
  55 ;;; Serialization procedures used by the RPCs and the Nar format.  This module
  56 ;;; is for internal consumption.
  57 ;;;
  58 ;;; Code:
  59
  60 ;; Similar to serialize.cc in Nix.
  61
  62 (define-condition-type &nar-error &error      ; XXX: inherit from &store-error ?
  63   nar-error?
  64   (file  nar-error-file)                       ; file we were restoring, or #f
  65   (port  nar-error-port))                      ; port from which we read
  66
  67 (define currently-restored-file
  68   ;; Name of the file being restored.  Used internally for error reporting.
  69   (make-parameter #f))
  70
  71
  72 (define (get-bytevector-n* port count)
  73   (let ((bv (get-bytevector-n port count)))
  74     (when (or (eof-object? bv)
  75               (< (bytevector-length bv) count))
  76       (raise (condition (&nar-error
  77                          (file (currently-restored-file))
  78                          (port port)))))
  79     bv))
  80
  81 (define (write-int n p)
  82   (let ((b (make-bytevector 8 0)))
  83     (bytevector-u32-set! b 0 n (endianness little))
  84     (put-bytevector p b)))
  85
  86 (define (read-int p)
  87   (let ((b (get-bytevector-n* p 8)))
  88     (bytevector-u32-ref b 0 (endianness little))))
  89
  90 (define (write-long-long n p)
  91   (let ((b (make-bytevector 8 0)))
  92     (bytevector-u64-set! b 0 n (endianness little))
  93     (put-bytevector p b)))
  94
  95 (define (read-long-long p)
  96   (let ((b (get-bytevector-n* p 8)))
  97     (bytevector-u64-ref b 0 (endianness little))))
  98
  99 (define write-padding
 100   (let ((zero (make-bytevector 8 0)))
 101     (lambda (n p)
 102       (let ((m (modulo n 8)))
 103         (or (zero? m)
 104             (put-bytevector p zero 0 (- 8 m)))))))
 105
 106 (define* (write-bytevector s p
 107                            #:optional (l (bytevector-length s)))
 108   (let* ((m (modulo l 8))
 109          (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
 110     (bytevector-u32-set! b 0 l (endianness little))
 111     (bytevector-copy! s 0 b 8 l)
 112     (put-bytevector p b)))
 113
 114 (define (write-string s p)
 115   (write-bytevector (string->utf8 s) p))
 116
 117 (define (read-byte-string p)
 118   (let* ((len (read-int p))
 119          (m   (modulo len 8))
 120          (bv  (get-bytevector-n* p len)))
 121     (or (zero? m)
 122         (get-bytevector-n* p (- 8 m)))
 123     bv))
 124
 125 (define (read-string p)
 126   (utf8->string (read-byte-string p)))
 127
 128 (define (read-latin1-string p)
 129   "Read an ISO-8859-1 string from P."
 130   ;; Note: do not use 'get-string-n' to work around Guile bug
 131   ;; <http://bugs.gnu.org/19621>.  See <http://bugs.gnu.org/19610> for
 132   ;; a discussion.
 133   (let ((bv (read-byte-string p)))
 134     ;; XXX: Rewrite using (ice-9 iconv).
 135     (list->string (map integer->char (bytevector->u8-list bv)))))
 136
 137 (define (read-maybe-utf8-string p)
 138   "Read a serialized string from port P.  Attempt to decode it as UTF-8 and
 139 substitute invalid byte sequences with question marks.  This is a
 140 \"permissive\" UTF-8 decoder."
 141   ;; XXX: We rely on the port's decoding mechanism to do permissive decoding
 142   ;; and substitute invalid byte sequences with question marks, but this is
 143   ;; not very efficient.  Eventually Guile may provide a lightweight
 144   ;; permissive UTF-8 decoder.
 145   (let* ((bv   (read-byte-string p))
 146          (port (open-bytevector-input-port bv)))
 147     (set-port-encoding! port "UTF-8")
 148     (set-port-conversion-strategy! port 'substitute)
 149     (rdelim:read-string port)))
 150
 151 (define (write-string-list l p)
 152   (write-int (length l) p)
 153   (for-each (cut write-string <> p) l))
 154
 155 (define (write-string-pairs l p)
 156   (write-int (length l) p)
 157   (for-each (match-lambda
 158              ((first . second)
 159               (write-string first p)
 160               (write-string second p)))
 161             l))
 162
 163 (define (read-string-list p)
 164   (let ((len (read-int p)))
 165     (unfold (cut >= <> len)
 166             (lambda (i)
 167               (read-string p))
 168             1+
 169             0)))
 170
 171 (define (write-store-path f p)
 172   (write-string f p))                             ; TODO: assert path
 173
 174 (define (read-store-path p)
 175   (read-string p))                                ; TODO: assert path
 176
 177 (define write-store-path-list write-string-list)
 178 (define read-store-path-list read-string-list)
 179
 180 \f
 181 (define-condition-type &nar-read-error &nar-error
 182   nar-read-error?
 183   (token nar-read-error-token))                 ; faulty token, or #f
 184
 185
 186 (define (dump in out size)
 187   "Copy SIZE bytes from IN to OUT."
 188   (define buf-size 65536)
 189   (define buf (make-bytevector buf-size))
 190
 191   (let loop ((left size))
 192     (if (<= left 0)
 193         0
 194         (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
 195           (if (eof-object? read)
 196               left
 197               (begin
 198                 (put-bytevector out buf 0 read)
 199                 (loop (- left read))))))))
 200
 201 (define (write-contents file p size)
 202   "Write SIZE bytes from FILE to output port P."
 203   (define (call-with-binary-input-file file proc)
 204     ;; Open FILE as a binary file.  This avoids scan-for-encoding, and thus
 205     ;; avoids any initial buffering.  Disable file name canonicalization to
 206     ;; avoid stat'ing like crazy.
 207     (with-fluids ((%file-port-name-canonicalization #f))
 208       (let ((port (open-file file "rb")))
 209         (dynamic-wind
 210           (const #t)
 211           (cut proc port)
 212           (lambda ()
 213             (close-port port))))))
 214
 215   (call-with-binary-input-file file
 216     (lambda (input)
 217       (write-contents-from-port input p size))))
 218
 219 (define (write-contents-from-port input output size)
 220   "Write SIZE bytes from port INPUT to port OUTPUT."
 221   (write-string "contents" output)
 222   (write-long-long size output)
 223   ;; Use 'sendfile' when both OUTPUT and INPUT are file ports.
 224   (if (and (file-port? output) (file-port? input))
 225       (sendfile output input size 0)
 226       (dump input output size))
 227   (write-padding size output))
 228
 229 (define (read-contents in out)
 230   "Read the contents of a file from the Nar at IN, write it to OUT, and return
 231 the size in bytes."
 232   (define executable?
 233     (match (read-string in)
 234       ("contents"
 235        #f)
 236       ("executable"
 237        (match (list (read-string in) (read-string in))
 238          (("" "contents") #t)
 239          (x (raise
 240              (condition (&message
 241                          (message "unexpected executable file marker"))
 242                         (&nar-read-error (port in)
 243                                          (file #f)
 244                                          (token x))))))
 245        #t)
 246       (x
 247        (raise
 248         (condition (&message (message "unsupported nar file type"))
 249                    (&nar-read-error (port in) (file #f) (token x)))))))
 250
 251   (let ((size (read-long-long in)))
 252     ;; Note: `sendfile' cannot be used here because of port buffering on IN.
 253     (dump in out size)
 254
 255     (when executable?
 256       (chmod out #o755))
 257     (let ((m (modulo size 8)))
 258       (unless (zero? m)
 259         (get-bytevector-n* in (- 8 m))))
 260     size))
 261
 262 (define %archive-version-1
 263   ;; Magic cookie for Nix archives.
 264   "nix-archive-1")
 265
 266 (define* (write-file file port
 267                      #:key (select? (const #t)))
 268   "Write the contents of FILE to PORT in Nar format, recursing into
 269 sub-directories of FILE as needed.  For each directory entry, call (SELECT?
 270 FILE STAT), where FILE is the entry's absolute file name and STAT is the
 271 result of 'lstat'; exclude entries for which SELECT? does not return true."
 272   (write-file-tree file port
 273                    #:file-type+size
 274                    (lambda (file)
 275                      (let* ((stat (lstat file))
 276                             (size (stat:size stat)))
 277                        (case (stat:type stat)
 278                          ((directory)
 279                           (values 'directory size))
 280                          ((regular)
 281                           (values (if (zero? (logand (stat:mode stat)
 282                                                      #o100))
 283                                       'regular
 284                                       'executable)
 285                                   size))
 286                          (else
 287                           (values (stat:type stat) size))))) ;bah!
 288                    #:file-port (cut open-file <> "r0b")
 289                    #:symlink-target readlink
 290
 291                    #:directory-entries
 292                    (lambda (directory)
 293                      ;; 'scandir' defaults to 'string-locale<?' to sort files,
 294                      ;; but this happens to be case-insensitive (at least in
 295                      ;; 'en_US' locale on libc 2.18.)  Conversely, we want
 296                      ;; files to be sorted in a case-sensitive fashion.
 297                      (define basenames
 298                        (scandir directory (negate (cut member <> '("." "..")))
 299                                 string<?))
 300
 301                      (filter-map (lambda (base)
 302                                    (let ((file (string-append directory
 303                                                               "/" base)))
 304                                      (and (select? file (lstat file))
 305                                           base)))
 306                                  basenames))
 307
 308                    ;; The 'scandir' call above gives us filtered and sorted
 309                    ;; entries, so no post-processing is needed.
 310                    #:postprocess-entries identity))
 311
 312 (define (filter/sort-directory-entries lst)
 313   "Remove dot and dot-dot entries from LST, and sort it in lexicographical
 314 order."
 315   (delete-duplicates
 316    (sort (remove (cute member <> '("." "..")) lst)
 317          string<?)
 318    string=?))
 319
 320 (define* (write-file-tree file port
 321                           #:key
 322                           file-type+size
 323                           file-port
 324                           symlink-target
 325                           directory-entries
 326                           (postprocess-entries filter/sort-directory-entries))
 327   "Write the contents of FILE to PORT in Nar format, recursing into
 328 sub-directories of FILE as needed.
 329
 330 This procedure does not make any file-system I/O calls.  Instead, it calls the
 331 user-provided FILE-TYPE+SIZE, FILE-PORT, SYMLINK-TARGET, and DIRECTORY-ENTRIES
 332 procedures, which roughly correspond to 'lstat', 'readlink', and 'scandir'.
 333 POSTPROCESS-ENTRIES ensures that directory entries are valid; leave it as-is
 334 unless you know that DIRECTORY-ENTRIES provide filtered and sorted entries, in
 335 which case you can use 'identity'."
 336   (define p port)
 337
 338   (write-string %archive-version-1 p)
 339
 340   (let dump ((f file))
 341     (define-values (type size)
 342       (file-type+size f))
 343
 344     (write-string "(" p)
 345     (case type
 346       ((regular executable)
 347        (write-string "type" p)
 348        (write-string "regular" p)
 349        (when (eq? 'executable type)
 350          (write-string "executable" p)
 351          (write-string "" p))
 352        (let ((input (file-port f)))
 353          (dynamic-wind
 354            (const #t)
 355            (lambda ()
 356              (write-contents-from-port input p size))
 357            (lambda ()
 358              (close-port input)))))
 359       ((directory)
 360        (write-string "type" p)
 361        (write-string "directory" p)
 362        (let ((entries (postprocess-entries (directory-entries f))))
 363          (for-each (lambda (e)
 364                      (let* ((f (string-append f "/" e)))
 365                        (write-string "entry" p)
 366                        (write-string "(" p)
 367                        (write-string "name" p)
 368                        (write-string e p)
 369                        (write-string "node" p)
 370                        (dump f)
 371                        (write-string ")" p)))
 372                    entries)))
 373       ((symlink)
 374        (write-string "type" p)
 375        (write-string "symlink" p)
 376        (write-string "target" p)
 377        (write-string (symlink-target f) p))
 378       (else
 379        (raise (condition (&message (message "unsupported file type"))
 380                          (&nar-error (file f) (port port))))))
 381     (write-string ")" p)))
 382
 383 (define port-conversion-strategy
 384   (fluid->parameter %default-port-conversion-strategy))
 385
 386 (define (restore-file port file)
 387   "Read a file (possibly a directory structure) in Nar format from PORT.
 388 Restore it as FILE."
 389   (parameterize ((currently-restored-file file)
 390
 391                  ;; Error out if we can convert file names to the current
 392                  ;; locale.  (XXX: We'd prefer UTF-8 encoding for file names
 393                  ;; regardless of the locale, but that's what Guile gives us
 394                  ;; so far.)
 395                  (port-conversion-strategy 'error))
 396     (let ((signature (read-string port)))
 397       (unless (equal? signature %archive-version-1)
 398         (raise
 399          (condition (&message (message "invalid nar signature"))
 400                     (&nar-read-error (port port)
 401                                      (token signature)
 402                                      (file #f))))))
 403
 404     (let restore ((file file))
 405       (define (read-eof-marker)
 406         (match (read-string port)
 407           (")" #t)
 408           (x (raise
 409               (condition
 410                (&message (message "invalid nar end-of-file marker"))
 411                (&nar-read-error (port port) (file file) (token x)))))))
 412
 413       (currently-restored-file file)
 414
 415       (match (list (read-string port) (read-string port) (read-string port))
 416         (("(" "type" "regular")
 417          (call-with-output-file file (cut read-contents port <>))
 418          (read-eof-marker))
 419         (("(" "type" "symlink")
 420          (match (list (read-string port) (read-string port))
 421            (("target" target)
 422             (symlink target file)
 423             (read-eof-marker))
 424            (x (raise
 425                (condition
 426                 (&message (message "invalid symlink tokens"))
 427                 (&nar-read-error (port port) (file file) (token x)))))))
 428         (("(" "type" "directory")
 429          (let ((dir file))
 430            (mkdir dir)
 431            (let loop ((prefix (read-string port)))
 432              (match prefix
 433                ("entry"
 434                 (match (list (read-string port)
 435                              (read-string port) (read-string port)
 436                              (read-string port))
 437                   (("(" "name" file "node")
 438                    (restore (string-append dir "/" file))
 439                    (match (read-string port)
 440                      (")" #t)
 441                      (x
 442                       (raise
 443                        (condition
 444                         (&message
 445                          (message "unexpected directory entry termination"))
 446                         (&nar-read-error (port port)
 447                                          (file file)
 448                                          (token x))))))
 449                    (loop (read-string port)))))
 450                (")" #t)                            ; done with DIR
 451                (x
 452                 (raise
 453                  (condition
 454                   (&message (message "unexpected directory inter-entry marker"))
 455                   (&nar-read-error (port port) (file file) (token x)))))))))
 456         (x
 457          (raise
 458           (condition
 459            (&message (message "unsupported nar entry type"))
 460            (&nar-read-error (port port) (file file) (token x)))))))))
 461
 462 ;;; Local Variables:
 463 ;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
 464 ;;; End:
 465
 466 ;;; serialization.scm ends here