guix/serialization.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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             restore-file))
  51
  52 ;;; Comment:
  53 ;;;
  54 ;;; Serialization procedures used by the RPCs and the Nar format.  This module
  55 ;;; is for internal consumption.
  56 ;;;
  57 ;;; Code:
  58
  59 ;; Similar to serialize.cc in Nix.
  60
  61 (define-condition-type &nar-error &error      ; XXX: inherit from &nix-error ?
  62   nar-error?
  63   (file  nar-error-file)                       ; file we were restoring, or #f
  64   (port  nar-error-port))                      ; port from which we read
  65
  66 (define currently-restored-file
  67   ;; Name of the file being restored.  Used internally for error reporting.
  68   (make-parameter #f))
  69
  70
  71 (define (get-bytevector-n* port count)
  72   (let ((bv (get-bytevector-n port count)))
  73     (when (or (eof-object? bv)
  74               (< (bytevector-length bv) count))
  75       (raise (condition (&nar-error
  76                          (file (currently-restored-file))
  77                          (port port)))))
  78     bv))
  79
  80 (define (write-int n p)
  81   (let ((b (make-bytevector 8 0)))
  82     (bytevector-u32-set! b 0 n (endianness little))
  83     (put-bytevector p b)))
  84
  85 (define (read-int p)
  86   (let ((b (get-bytevector-n* p 8)))
  87     (bytevector-u32-ref b 0 (endianness little))))
  88
  89 (define (write-long-long n p)
  90   (let ((b (make-bytevector 8 0)))
  91     (bytevector-u64-set! b 0 n (endianness little))
  92     (put-bytevector p b)))
  93
  94 (define (read-long-long p)
  95   (let ((b (get-bytevector-n* p 8)))
  96     (bytevector-u64-ref b 0 (endianness little))))
  97
  98 (define write-padding
  99   (let ((zero (make-bytevector 8 0)))
 100     (lambda (n p)
 101       (let ((m (modulo n 8)))
 102         (or (zero? m)
 103             (put-bytevector p zero 0 (- 8 m)))))))
 104
 105 (define (write-bytevector s p)
 106   (let* ((l (bytevector-length s))
 107          (m (modulo l 8))
 108          (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
 109     (bytevector-u32-set! b 0 l (endianness little))
 110     (bytevector-copy! s 0 b 8 l)
 111     (put-bytevector p b)))
 112
 113 (define (write-string s p)
 114   (write-bytevector (string->utf8 s) p))
 115
 116 (define (read-byte-string p)
 117   (let* ((len (read-int p))
 118          (m   (modulo len 8))
 119          (bv  (get-bytevector-n* p len)))
 120     (or (zero? m)
 121         (get-bytevector-n* p (- 8 m)))
 122     bv))
 123
 124 (define (read-string p)
 125   (utf8->string (read-byte-string p)))
 126
 127 (define (read-latin1-string p)
 128   "Read an ISO-8859-1 string from P."
 129   ;; Note: do not use 'get-string-n' to work around Guile bug
 130   ;; <http://bugs.gnu.org/19621>.  See <http://bugs.gnu.org/19610> for
 131   ;; a discussion.
 132   (let ((bv (read-byte-string p)))
 133     ;; XXX: Rewrite using (ice-9 iconv).
 134     (list->string (map integer->char (bytevector->u8-list bv)))))
 135
 136 (define (read-maybe-utf8-string p)
 137   "Read a serialized string from port P.  Attempt to decode it as UTF-8 and
 138 substitute invalid byte sequences with question marks.  This is a
 139 \"permissive\" UTF-8 decoder."
 140   ;; XXX: We rely on the port's decoding mechanism to do permissive decoding
 141   ;; and substitute invalid byte sequences with question marks, but this is
 142   ;; not very efficient.  Eventually Guile may provide a lightweight
 143   ;; permissive UTF-8 decoder.
 144   (let* ((bv   (read-byte-string p))
 145          (port (open-bytevector-input-port bv)))
 146     (set-port-encoding! port "UTF-8")
 147     (set-port-conversion-strategy! port 'substitute)
 148     (rdelim:read-string port)))
 149
 150 (define (write-string-list l p)
 151   (write-int (length l) p)
 152   (for-each (cut write-string <> p) l))
 153
 154 (define (write-string-pairs l p)
 155   (write-int (length l) p)
 156   (for-each (match-lambda
 157              ((first . second)
 158               (write-string first p)
 159               (write-string second p)))
 160             l))
 161
 162 (define (read-string-list p)
 163   (let ((len (read-int p)))
 164     (unfold (cut >= <> len)
 165             (lambda (i)
 166               (read-string p))
 167             1+
 168             0)))
 169
 170 (define (write-store-path f p)
 171   (write-string f p))                             ; TODO: assert path
 172
 173 (define (read-store-path p)
 174   (read-string p))                                ; TODO: assert path
 175
 176 (define write-store-path-list write-string-list)
 177 (define read-store-path-list read-string-list)
 178
 179 \f
 180 (define-condition-type &nar-read-error &nar-error
 181   nar-read-error?
 182   (token nar-read-error-token))                 ; faulty token, or #f
 183
 184
 185 (define (dump in out size)
 186   "Copy SIZE bytes from IN to OUT."
 187   (define buf-size 65536)
 188   (define buf (make-bytevector buf-size))
 189
 190   (let loop ((left size))
 191     (if (<= left 0)
 192         0
 193         (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
 194           (if (eof-object? read)
 195               left
 196               (begin
 197                 (put-bytevector out buf 0 read)
 198                 (loop (- left read))))))))
 199
 200 (define (write-contents file p size)
 201   "Write SIZE bytes from FILE to output port P."
 202   (define (call-with-binary-input-file file proc)
 203     ;; Open FILE as a binary file.  This avoids scan-for-encoding, and thus
 204     ;; avoids any initial buffering.  Disable file name canonicalization to
 205     ;; avoid stat'ing like crazy.
 206     (with-fluids ((%file-port-name-canonicalization #f))
 207       (let ((port (open-file file "rb")))
 208         (dynamic-wind
 209           (const #t)
 210           (cut proc port)
 211           (lambda ()
 212             (close-port port))))))
 213
 214   (write-string "contents" p)
 215   (write-long-long size p)
 216   (call-with-binary-input-file file
 217     ;; Use `sendfile' when available (Guile 2.0.8+).
 218     (if (and (compile-time-value (defined? 'sendfile))
 219              (file-port? p))
 220         (cut sendfile p <> size 0)
 221         (cut dump <> p size)))
 222   (write-padding size p))
 223
 224 (define (read-contents in out)
 225   "Read the contents of a file from the Nar at IN, write it to OUT, and return
 226 the size in bytes."
 227   (define executable?
 228     (match (read-string in)
 229       ("contents"
 230        #f)
 231       ("executable"
 232        (match (list (read-string in) (read-string in))
 233          (("" "contents") #t)
 234          (x (raise
 235              (condition (&message
 236                          (message "unexpected executable file marker"))
 237                         (&nar-read-error (port in)
 238                                          (file #f)
 239                                          (token x))))))
 240        #t)
 241       (x
 242        (raise
 243         (condition (&message (message "unsupported nar file type"))
 244                    (&nar-read-error (port in) (file #f) (token x)))))))
 245
 246   (let ((size (read-long-long in)))
 247     ;; Note: `sendfile' cannot be used here because of port buffering on IN.
 248     (dump in out size)
 249
 250     (when executable?
 251       (chmod out #o755))
 252     (let ((m (modulo size 8)))
 253       (unless (zero? m)
 254         (get-bytevector-n* in (- 8 m))))
 255     size))
 256
 257 (define %archive-version-1
 258   ;; Magic cookie for Nix archives.
 259   "nix-archive-1")
 260
 261 (define* (write-file file port
 262                      #:key (select? (const #t)))
 263   "Write the contents of FILE to PORT in Nar format, recursing into
 264 sub-directories of FILE as needed.  For each directory entry, call (SELECT?
 265 FILE STAT), where FILE is the entry's absolute file name and STAT is the
 266 result of 'lstat'; exclude entries for which SELECT? does not return true."
 267   (define p port)
 268
 269   (write-string %archive-version-1 p)
 270
 271   (let dump ((f file) (s (lstat file)))
 272     (write-string "(" p)
 273     (case (stat:type s)
 274       ((regular)
 275        (write-string "type" p)
 276        (write-string "regular" p)
 277        (if (not (zero? (logand (stat:mode s) #o100)))
 278            (begin
 279              (write-string "executable" p)
 280              (write-string "" p)))
 281        (write-contents f p (stat:size s)))
 282       ((directory)
 283        (write-string "type" p)
 284        (write-string "directory" p)
 285        (let ((entries
 286               ;; 'scandir' defaults to 'string-locale<?' to sort files, but
 287               ;; this happens to be case-insensitive (at least in 'en_US'
 288               ;; locale on libc 2.18.)  Conversely, we want files to be
 289               ;; sorted in a case-sensitive fashion.
 290               (scandir f (negate (cut member <> '("." ".."))) string<?)))
 291          (for-each (lambda (e)
 292                      (let* ((f (string-append f "/" e))
 293                             (s (lstat f)))
 294                        (when (select? f s)
 295                          (write-string "entry" p)
 296                          (write-string "(" p)
 297                          (write-string "name" p)
 298                          (write-string e p)
 299                          (write-string "node" p)
 300                          (dump f s)
 301                          (write-string ")" p))))
 302                    entries)))
 303       ((symlink)
 304        (write-string "type" p)
 305        (write-string "symlink" p)
 306        (write-string "target" p)
 307        (write-string (readlink f) p))
 308       (else
 309        (raise (condition (&message (message "unsupported file type"))
 310                          (&nar-error (file f) (port port))))))
 311     (write-string ")" p)))
 312
 313 (define (restore-file port file)
 314   "Read a file (possibly a directory structure) in Nar format from PORT.
 315 Restore it as FILE."
 316   (parameterize ((currently-restored-file file))
 317     (let ((signature (read-string port)))
 318       (unless (equal? signature %archive-version-1)
 319         (raise
 320          (condition (&message (message "invalid nar signature"))
 321                     (&nar-read-error (port port)
 322                                      (token signature)
 323                                      (file #f))))))
 324
 325     (let restore ((file file))
 326       (define (read-eof-marker)
 327         (match (read-string port)
 328           (")" #t)
 329           (x (raise
 330               (condition
 331                (&message (message "invalid nar end-of-file marker"))
 332                (&nar-read-error (port port) (file file) (token x)))))))
 333
 334       (currently-restored-file file)
 335
 336       (match (list (read-string port) (read-string port) (read-string port))
 337         (("(" "type" "regular")
 338          (call-with-output-file file (cut read-contents port <>))
 339          (read-eof-marker))
 340         (("(" "type" "symlink")
 341          (match (list (read-string port) (read-string port))
 342            (("target" target)
 343             (symlink target file)
 344             (read-eof-marker))
 345            (x (raise
 346                (condition
 347                 (&message (message "invalid symlink tokens"))
 348                 (&nar-read-error (port port) (file file) (token x)))))))
 349         (("(" "type" "directory")
 350          (let ((dir file))
 351            (mkdir dir)
 352            (let loop ((prefix (read-string port)))
 353              (match prefix
 354                ("entry"
 355                 (match (list (read-string port)
 356                              (read-string port) (read-string port)
 357                              (read-string port))
 358                   (("(" "name" file "node")
 359                    (restore (string-append dir "/" file))
 360                    (match (read-string port)
 361                      (")" #t)
 362                      (x
 363                       (raise
 364                        (condition
 365                         (&message
 366                          (message "unexpected directory entry termination"))
 367                         (&nar-read-error (port port)
 368                                          (file file)
 369                                          (token x))))))
 370                    (loop (read-string port)))))
 371                (")" #t)                            ; done with DIR
 372                (x
 373                 (raise
 374                  (condition
 375                   (&message (message "unexpected directory inter-entry marker"))
 376                   (&nar-read-error (port port) (file file) (token x)))))))))
 377         (x
 378          (raise
 379           (condition
 380            (&message (message "unsupported nar entry type"))
 381            (&nar-read-error (port port) (file file) (token x)))))))))
 382
 383 ;;; serialization.scm ends here