guix/nar.scm

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