guix/serialization.scm

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