guix/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix nar)
  21   #:use-module (guix utils)
  22   #:use-module (guix serialization)
  23   #:use-module ((guix build utils)
  24                 #:select (delete-file-recursively with-directory-excursion))
  25   #:use-module (guix store)
  26   #:use-module (guix ui)                          ; for '_'
  27   #:use-module (guix hash)
  28   #:use-module (guix pki)
  29   #:use-module (guix pk-crypto)
  30   #:use-module (rnrs bytevectors)
  31   #:use-module (rnrs io ports)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (srfi srfi-11)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (srfi srfi-34)
  36   #:use-module (srfi srfi-35)
  37   #:use-module (ice-9 ftw)
  38   #:use-module (ice-9 match)
  39   #:export (nar-error?
  40             nar-error-port
  41             nar-error-file
  42
  43             nar-read-error?
  44             nar-read-error-token
  45
  46             nar-invalid-hash-error?
  47             nar-invalid-hash-error-expected
  48             nar-invalid-hash-error-actual
  49
  50             nar-signature-error?
  51             nar-signature-error-signature
  52
  53             write-file
  54             restore-file
  55
  56             restore-file-set))
  57
  58 ;;; Comment:
  59 ;;;
  60 ;;; Read and write Nix archives, aka. ‘nar’.
  61 ;;;
  62 ;;; Code:
  63
  64 (define-condition-type &nar-error &error      ; XXX: inherit from &nix-error ?
  65   nar-error?
  66   (file  nar-error-file)                       ; file we were restoring, or #f
  67   (port  nar-error-port))                      ; port from which we read
  68
  69 (define-condition-type &nar-read-error &nar-error
  70   nar-read-error?
  71   (token nar-read-error-token))                 ; faulty token, or #f
  72
  73 (define-condition-type &nar-signature-error &nar-error
  74   nar-signature-error?
  75   (signature nar-signature-error-signature))      ; faulty signature or #f
  76
  77 (define-condition-type &nar-invalid-hash-error &nar-signature-error
  78   nar-invalid-hash-error?
  79   (expected  nar-invalid-hash-error-expected)     ; expected hash (a bytevector)
  80   (actual    nar-invalid-hash-error-actual))      ; actual hash
  81
  82 \f
  83 (define (dump in out size)
  84   "Copy SIZE bytes from IN to OUT."
  85   (define buf-size 65536)
  86   (define buf (make-bytevector buf-size))
  87
  88   (let loop ((left size))
  89     (if (<= left 0)
  90         0
  91         (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
  92           (if (eof-object? read)
  93               left
  94               (begin
  95                 (put-bytevector out buf 0 read)
  96                 (loop (- left read))))))))
  97
  98 (define (write-contents file p size)
  99   "Write SIZE bytes from FILE to output port P."
 100   (define (call-with-binary-input-file file proc)
 101     ;; Open FILE as a binary file.  This avoids scan-for-encoding, and thus
 102     ;; avoids any initial buffering.  Disable file name canonicalization to
 103     ;; avoid stat'ing like crazy.
 104     (with-fluids ((%file-port-name-canonicalization #f))
 105       (let ((port (open-file file "rb")))
 106         (dynamic-wind
 107           (const #t)
 108           (cut proc port)
 109           (lambda ()
 110             (close-port port))))))
 111
 112   (write-string "contents" p)
 113   (write-long-long size p)
 114   (call-with-binary-input-file file
 115     ;; Use `sendfile' when available (Guile 2.0.8+).
 116     (if (and (compile-time-value (defined? 'sendfile))
 117              (file-port? p))
 118         (cut sendfile p <> size 0)
 119         (cut dump <> p size)))
 120   (write-padding size p))
 121
 122 (define (read-contents in out)
 123   "Read the contents of a file from the Nar at IN, write it to OUT, and return
 124 the size in bytes."
 125   (define executable?
 126     (match (read-string in)
 127       ("contents"
 128        #f)
 129       ("executable"
 130        (match (list (read-string in) (read-string in))
 131          (("" "contents") #t)
 132          (x (raise
 133              (condition (&message
 134                          (message "unexpected executable file marker"))
 135                         (&nar-read-error (port in)
 136                                          (file #f)
 137                                          (token x))))))
 138        #t)
 139       (x
 140        (raise
 141         (condition (&message (message "unsupported nar file type"))
 142                    (&nar-read-error (port in) (file #f) (token x)))))))
 143
 144   (let ((size (read-long-long in)))
 145     ;; Note: `sendfile' cannot be used here because of port buffering on IN.
 146     (dump in out size)
 147
 148     (when executable?
 149       (chmod out #o755))
 150     (let ((m (modulo size 8)))
 151       (unless (zero? m)
 152         (get-bytevector-n in (- 8 m))))
 153     size))
 154
 155 (define %archive-version-1
 156   ;; Magic cookie for Nix archives.
 157   "nix-archive-1")
 158
 159 (define (write-file file port)
 160   "Write the contents of FILE to PORT in Nar format, recursing into
 161 sub-directories of FILE as needed."
 162   (define p port)
 163
 164   (write-string %archive-version-1 p)
 165
 166   (let dump ((f file))
 167     (let ((s (lstat f)))
 168       (write-string "(" p)
 169       (case (stat:type s)
 170         ((regular)
 171          (write-string "type" p)
 172          (write-string "regular" p)
 173          (if (not (zero? (logand (stat:mode s) #o100)))
 174              (begin
 175                (write-string "executable" p)
 176                (write-string "" p)))
 177          (write-contents f p (stat:size s)))
 178         ((directory)
 179          (write-string "type" p)
 180          (write-string "directory" p)
 181          (let ((entries
 182                 ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories
 183                 ;; unconditionally, including "." and "..", regardless of the
 184                 ;; 'select?' predicate passed to it, so we have to filter
 185                 ;; those out externally.
 186                 (filter (negate (cut member <> '("." "..")))
 187                         ;; 'scandir' defaults to 'string-locale<?' to sort
 188                         ;; files, but this happens to be case-insensitive (at
 189                         ;; least in 'en_US' locale on libc 2.18.)  Conversely,
 190                         ;; we want files to be sorted in a case-sensitive
 191                         ;; fashion.
 192                         (scandir f (const #t) string<?))))
 193            (for-each (lambda (e)
 194                        (let ((f (string-append f "/" e)))
 195                          (write-string "entry" p)
 196                          (write-string "(" p)
 197                          (write-string "name" p)
 198                          (write-string e p)
 199                          (write-string "node" p)
 200                          (dump f)
 201                          (write-string ")" p)))
 202                      entries)))
 203         ((symlink)
 204          (write-string "type" p)
 205          (write-string "symlink" p)
 206          (write-string "target" p)
 207          (write-string (readlink f) p))
 208         (else
 209          (raise (condition (&message (message "unsupported file type"))
 210                            (&nar-error (file f) (port port))))))
 211       (write-string ")" p))))
 212
 213 (define (restore-file port file)
 214   "Read a file (possibly a directory structure) in Nar format from PORT.
 215 Restore it as FILE."
 216   (let ((signature (read-string port)))
 217     (unless (equal? signature %archive-version-1)
 218       (raise
 219        (condition (&message (message "invalid nar signature"))
 220                   (&nar-read-error (port port)
 221                                    (token signature)
 222                                    (file #f))))))
 223
 224   (let restore ((file file))
 225     (define (read-eof-marker)
 226       (match (read-string port)
 227         (")" #t)
 228         (x (raise
 229             (condition
 230              (&message (message "invalid nar end-of-file marker"))
 231              (&nar-read-error (port port) (file file) (token x)))))))
 232
 233     (match (list (read-string port) (read-string port) (read-string port))
 234       (("(" "type" "regular")
 235        (call-with-output-file file (cut read-contents port <>))
 236        (read-eof-marker))
 237       (("(" "type" "symlink")
 238        (match (list (read-string port) (read-string port))
 239          (("target" target)
 240           (symlink target file)
 241           (read-eof-marker))
 242          (x (raise
 243              (condition
 244               (&message (message "invalid symlink tokens"))
 245               (&nar-read-error (port port) (file file) (token x)))))))
 246       (("(" "type" "directory")
 247        (let ((dir file))
 248          (mkdir dir)
 249          (let loop ((prefix (read-string port)))
 250            (match prefix
 251              ("entry"
 252               (match (list (read-string port)
 253                            (read-string port) (read-string port)
 254                            (read-string port))
 255                 (("(" "name" file "node")
 256                  (restore (string-append dir "/" file))
 257                  (match (read-string port)
 258                    (")" #t)
 259                    (x
 260                     (raise
 261                      (condition
 262                       (&message
 263                        (message "unexpected directory entry termination"))
 264                       (&nar-read-error (port port)
 265                                        (file file)
 266                                        (token x))))))
 267                  (loop (read-string port)))))
 268              (")" #t)                             ; done with DIR
 269              (x
 270               (raise
 271                (condition
 272                 (&message (message "unexpected directory inter-entry marker"))
 273                 (&nar-read-error (port port) (file file) (token x)))))))))
 274       (x
 275        (raise
 276         (condition
 277          (&message (message "unsupported nar entry type"))
 278          (&nar-read-error (port port) (file file) (token x))))))))
 279
 280 \f
 281 ;;;
 282 ;;; Restoring a file set into the store.
 283 ;;;
 284
 285 ;; The code below accesses the store directly and is meant to be run from
 286 ;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
 287 ;; (1) the locks on the files to be restored as already held, and (2) the
 288 ;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
 289 ;;
 290 ;; So we're really duplicating that functionality of the daemon (well, until
 291 ;; most of the daemon is in Scheme :-)).  But note that we do use a couple of
 292 ;; RPCs for functionality not available otherwise, like 'valid-path?'.
 293
 294 (define (lock-store-file file)
 295   "Acquire exclusive access to FILE, a store file."
 296   (call-with-output-file (string-append file ".lock")
 297     (cut fcntl-flock <> 'write-lock)))
 298
 299 (define (unlock-store-file file)
 300   "Release access to FILE."
 301   (call-with-input-file (string-append file ".lock")
 302     (cut fcntl-flock <> 'unlock)))
 303
 304 (define* (finalize-store-file source target
 305                               #:key (references '()) deriver (lock? #t))
 306   "Rename SOURCE to TARGET and register TARGET as a valid store item, with
 307 REFERENCES and DERIVER.  When LOCK? is true, acquire exclusive locks on TARGET
 308 before attempting to register it; otherwise, assume TARGET's locks are already
 309 held."
 310
 311   ;; XXX: Currently we have to call out to the daemon to check whether TARGET
 312   ;; is valid.
 313   (with-store store
 314     (unless (valid-path? store target)
 315       (when lock?
 316         (lock-store-file target))
 317
 318       (unless (valid-path? store target)
 319         ;; If FILE already exists, delete it (it's invalid anyway.)
 320         (when (file-exists? target)
 321           (delete-file-recursively target))
 322
 323         ;; Install the new TARGET.
 324         (rename-file source target)
 325
 326         ;; Register TARGET.  As a side effect, it resets the timestamps of all
 327         ;; its files, recursively, and runs a deduplication pass.
 328         (register-path target
 329                        #:references references
 330                        #:deriver deriver))
 331
 332       (when lock?
 333         (unlock-store-file target)))))
 334
 335 (define (temporary-store-file)
 336   "Return the file name of a temporary file created in the store."
 337   (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
 338          (port     (mkstemp! template)))
 339     (close-port port)
 340     template))
 341
 342 (define-syntax-rule (with-temporary-store-file name body ...)
 343   "Evaluate BODY with NAME bound to the file name of a temporary store item
 344 protected from GC."
 345   (let loop ((name (temporary-store-file)))
 346     (with-store store
 347       ;; Add NAME to the current process' roots.  (Opening this connection to
 348       ;; the daemon allows us to reuse its code that deals with the
 349       ;; per-process roots file.)
 350       (add-temp-root store name)
 351
 352       ;; There's a window during which GC could delete NAME.  Try again when
 353       ;; that happens.
 354       (if (file-exists? name)
 355           (begin
 356             (delete-file name)
 357             body ...)
 358           (loop (temporary-store-file))))))
 359
 360 (define* (restore-one-item port
 361                            #:key acl (verify-signature? #t) (lock? #t)
 362                            (log-port (current-error-port)))
 363   "Restore one store item from PORT; return its file name on success."
 364
 365   (define (assert-valid-signature signature hash file)
 366     ;; Bail out if SIGNATURE, which must be a string as produced by
 367     ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
 368     ;; the expected hash for FILE.
 369     (let ((signature (catch 'gcry-error
 370                        (lambda ()
 371                          (string->canonical-sexp signature))
 372                        (lambda (key proc err)
 373                          (raise (condition
 374                                  (&message
 375                                   (message "signature is not a valid \
 376 s-expression"))
 377                                  (&nar-signature-error
 378                                   (file file)
 379                                   (signature signature) (port port))))))))
 380       (signature-case (signature hash (current-acl))
 381         (valid-signature #t)
 382         (invalid-signature
 383          (raise (condition
 384                  (&message (message "invalid signature"))
 385                  (&nar-signature-error
 386                   (file file) (signature signature) (port port)))))
 387         (hash-mismatch
 388          (raise (condition (&message (message "invalid hash"))
 389                            (&nar-invalid-hash-error
 390                             (port port) (file file)
 391                             (signature signature)
 392                             (expected (hash-data->bytevector
 393                                        (signature-signed-data signature)))
 394                             (actual hash)))))
 395         (unauthorized-key
 396          (raise (condition (&message (message "unauthorized public key"))
 397                            (&nar-signature-error
 398                             (signature signature) (file file) (port port)))))
 399         (corrupt-signature
 400          (raise (condition
 401                  (&message (message "corrupt signature data"))
 402                  (&nar-signature-error
 403                   (signature signature) (file file) (port port))))))))
 404
 405   (define %export-magic
 406     ;; Number used to identify genuine file set archives.
 407     #x4558494e)
 408
 409   (define port*
 410     ;; Keep that one around, for error conditions.
 411     port)
 412
 413   (let-values (((port get-hash)
 414                 (open-sha256-input-port port)))
 415     (with-temporary-store-file temp
 416       (restore-file port temp)
 417
 418       (let ((magic (read-int port)))
 419         (unless (= magic %export-magic)
 420           (raise (condition
 421                   (&message (message "corrupt file set archive"))
 422                   (&nar-read-error
 423                    (port port*) (file #f) (token #f))))))
 424
 425       (let ((file     (read-store-path port))
 426             (refs     (read-store-path-list port))
 427             (deriver  (read-string port))
 428             (hash     (get-hash))
 429             (has-sig? (= 1 (read-int port))))
 430         (format log-port
 431                 (_ "importing file or directory '~a'...~%")
 432                 file)
 433
 434         (let ((sig (and has-sig? (read-string port))))
 435           (when verify-signature?
 436             (if sig
 437                 (begin
 438                   (assert-valid-signature sig hash file)
 439                   (format log-port
 440                           (_ "found valid signature for '~a'~%")
 441                           file)
 442                   (finalize-store-file temp file
 443                                        #:references refs
 444                                        #:deriver deriver
 445                                        #:lock? lock?))
 446                 (raise (condition
 447                         (&message (message "imported file lacks \
 448 a signature"))
 449                         (&nar-signature-error
 450                          (port port*) (file file) (signature #f))))))
 451           file)))))
 452
 453 (define* (restore-file-set port
 454                            #:key (verify-signature? #t) (lock? #t)
 455                            (log-port (current-error-port)))
 456   "Restore the file set read from PORT to the store.  The format of the data
 457 on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted
 458 archives with interspersed meta-data joining them together, possibly with a
 459 digital signature at the end.  Log progress to LOG-PORT.  Return the list of
 460 files restored.
 461
 462 When LOCK? is #f, assume locks for the files to be restored are already held.
 463 This is the case when the daemon calls a build hook.
 464
 465 Note that this procedure accesses the store directly, so it's only meant to be
 466 used by the daemon's build hooks since they cannot call back to the daemon
 467 while the locks are held."
 468   (define acl
 469     (current-acl))
 470
 471   (let loop ((n     (read-long-long port))
 472              (files '()))
 473     (case n
 474       ((0)
 475        (reverse files))
 476       ((1)
 477        (let ((file
 478               (restore-one-item port
 479                                 #:acl acl #:verify-signature? verify-signature?
 480                                 #:lock? lock? #:log-port log-port)))
 481          (loop (read-long-long port)
 482                (cons file files))))
 483       (else
 484        ;; Neither 0 nor 1.
 485        (raise (condition
 486                (&message (message "invalid inter-file archive mark"))
 487                (&nar-read-error
 488                 (port port) (file #f) (token #f))))))))
 489
 490 ;;; Local Variables:
 491 ;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
 492 ;;; End:
 493
 494 ;;; nar.scm ends here