guix/serialization.scm

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