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