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) when the minimum requirement is
 134     ;; upgraded to Guile >= 2.0.9.
 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   (write-string "contents" p)
 216   (write-long-long size p)
 217   (call-with-binary-input-file file
 218     ;; Use `sendfile' when available (Guile 2.0.8+).
 219     (if (and (compile-time-value (defined? 'sendfile))
 220              (file-port? p))
 221         (cut sendfile p <> size 0)
 222         (cut dump <> p size)))
 223   (write-padding size p))
 224
 225 (define (read-contents in out)
 226   "Read the contents of a file from the Nar at IN, write it to OUT, and return
 227 the size in bytes."
 228   (define executable?
 229     (match (read-string in)
 230       ("contents"
 231        #f)
 232       ("executable"
 233        (match (list (read-string in) (read-string in))
 234          (("" "contents") #t)
 235          (x (raise
 236              (condition (&message
 237                          (message "unexpected executable file marker"))
 238                         (&nar-read-error (port in)
 239                                          (file #f)
 240                                          (token x))))))
 241        #t)
 242       (x
 243        (raise
 244         (condition (&message (message "unsupported nar file type"))
 245                    (&nar-read-error (port in) (file #f) (token x)))))))
 246
 247   (let ((size (read-long-long in)))
 248     ;; Note: `sendfile' cannot be used here because of port buffering on IN.
 249     (dump in out size)
 250
 251     (when executable?
 252       (chmod out #o755))
 253     (let ((m (modulo size 8)))
 254       (unless (zero? m)
 255         (get-bytevector-n* in (- 8 m))))
 256     size))
 257
 258 (define %archive-version-1
 259   ;; Magic cookie for Nix archives.
 260   "nix-archive-1")
 261
 262 (define* (write-file file port
 263                      #:key (select? (const #t)))
 264   "Write the contents of FILE to PORT in Nar format, recursing into
 265 sub-directories of FILE as needed.  For each directory entry, call (SELECT?
 266 FILE STAT), where FILE is the entry's absolute file name and STAT is the
 267 result of 'lstat'; exclude entries for which SELECT? does not return true."
 268   (define p port)
 269
 270   (write-string %archive-version-1 p)
 271
 272   (let dump ((f file) (s (lstat file)))
 273     (write-string "(" p)
 274     (case (stat:type s)
 275       ((regular)
 276        (write-string "type" p)
 277        (write-string "regular" p)
 278        (if (not (zero? (logand (stat:mode s) #o100)))
 279            (begin
 280              (write-string "executable" p)
 281              (write-string "" p)))
 282        (write-contents f p (stat:size s)))
 283       ((directory)
 284        (write-string "type" p)
 285        (write-string "directory" p)
 286        (let ((entries
 287               ;; 'scandir' defaults to 'string-locale<?' to sort files, but
 288               ;; this happens to be case-insensitive (at least in 'en_US'
 289               ;; locale on libc 2.18.)  Conversely, we want files to be
 290               ;; sorted in a case-sensitive fashion.
 291               (scandir f (negate (cut member <> '("." ".."))) string<?)))
 292          (for-each (lambda (e)
 293                      (let* ((f (string-append f "/" e))
 294                             (s (lstat f)))
 295                        (when (select? f s)
 296                          (write-string "entry" p)
 297                          (write-string "(" p)
 298                          (write-string "name" p)
 299                          (write-string e p)
 300                          (write-string "node" p)
 301                          (dump f s)
 302                          (write-string ")" p))))
 303                    entries)))
 304       ((symlink)
 305        (write-string "type" p)
 306        (write-string "symlink" p)
 307        (write-string "target" p)
 308        (write-string (readlink f) p))
 309       (else
 310        (raise (condition (&message (message "unsupported file type"))
 311                          (&nar-error (file f) (port port))))))
 312     (write-string ")" p)))
 313
 314 (define (restore-file port file)
 315   "Read a file (possibly a directory structure) in Nar format from PORT.
 316 Restore it as FILE."
 317   (parameterize ((currently-restored-file file))
 318     (let ((signature (read-string port)))
 319       (unless (equal? signature %archive-version-1)
 320         (raise
 321          (condition (&message (message "invalid nar signature"))
 322                     (&nar-read-error (port port)
 323                                      (token signature)
 324                                      (file #f))))))
 325
 326     (let restore ((file file))
 327       (define (read-eof-marker)
 328         (match (read-string port)
 329           (")" #t)
 330           (x (raise
 331               (condition
 332                (&message (message "invalid nar end-of-file marker"))
 333                (&nar-read-error (port port) (file file) (token x)))))))
 334
 335       (currently-restored-file file)
 336
 337       (match (list (read-string port) (read-string port) (read-string port))
 338         (("(" "type" "regular")
 339          (call-with-output-file file (cut read-contents port <>))
 340          (read-eof-marker))
 341         (("(" "type" "symlink")
 342          (match (list (read-string port) (read-string port))
 343            (("target" target)
 344             (symlink target file)
 345             (read-eof-marker))
 346            (x (raise
 347                (condition
 348                 (&message (message "invalid symlink tokens"))
 349                 (&nar-read-error (port port) (file file) (token x)))))))
 350         (("(" "type" "directory")
 351          (let ((dir file))
 352            (mkdir dir)
 353            (let loop ((prefix (read-string port)))
 354              (match prefix
 355                ("entry"
 356                 (match (list (read-string port)
 357                              (read-string port) (read-string port)
 358                              (read-string port))
 359                   (("(" "name" file "node")
 360                    (restore (string-append dir "/" file))
 361                    (match (read-string port)
 362                      (")" #t)
 363                      (x
 364                       (raise
 365                        (condition
 366                         (&message
 367                          (message "unexpected directory entry termination"))
 368                         (&nar-read-error (port port)
 369                                          (file file)
 370                                          (token x))))))
 371                    (loop (read-string port)))))
 372                (")" #t)                            ; done with DIR
 373                (x
 374                 (raise
 375                  (condition
 376                   (&message (message "unexpected directory inter-entry marker"))
 377                   (&nar-read-error (port port) (file file) (token x)))))))))
 378         (x
 379          (raise
 380           (condition
 381            (&message (message "unsupported nar entry type"))
 382            (&nar-read-error (port port) (file file) (token x)))))))))
 383
 384 ;;; serialization.scm ends here