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* ((select? (negate (cut member <> '("." ".."))))
 181
 182                 ;; 'scandir' defaults to 'string-locale<?' to sort files, but
 183                 ;; this happens to be case-insensitive (at least in 'en_US'
 184                 ;; locale on libc 2.18.)  Conversely, we want files to be
 185                 ;; sorted in a case-sensitive fashion.
 186                 (entries (scandir f select? string<?)))
 187            (for-each (lambda (e)
 188                        (let ((f (string-append f "/" e)))
 189                          (write-string "entry" p)
 190                          (write-string "(" p)
 191                          (write-string "name" p)
 192                          (write-string e p)
 193                          (write-string "node" p)
 194                          (dump f)
 195                          (write-string ")" p)))
 196                      entries)))
 197         ((symlink)
 198          (write-string "type" p)
 199          (write-string "symlink" p)
 200          (write-string "target" p)
 201          (write-string (readlink f) p))
 202         (else
 203          (raise (condition (&message (message "unsupported file type"))
 204                            (&nar-error (file f) (port port))))))
 205       (write-string ")" p))))
 206
 207 (define (restore-file port file)
 208   "Read a file (possibly a directory structure) in Nar format from PORT.
 209 Restore it as FILE."
 210   (let ((signature (read-string port)))
 211     (unless (equal? signature %archive-version-1)
 212       (raise
 213        (condition (&message (message "invalid nar signature"))
 214                   (&nar-read-error (port port)
 215                                    (token signature)
 216                                    (file #f))))))
 217
 218   (let restore ((file file))
 219     (define (read-eof-marker)
 220       (match (read-string port)
 221         (")" #t)
 222         (x (raise
 223             (condition
 224              (&message (message "invalid nar end-of-file marker"))
 225              (&nar-read-error (port port) (file file) (token x)))))))
 226
 227     (match (list (read-string port) (read-string port) (read-string port))
 228       (("(" "type" "regular")
 229        (call-with-output-file file (cut read-contents port <>))
 230        (read-eof-marker))
 231       (("(" "type" "symlink")
 232        (match (list (read-string port) (read-string port))
 233          (("target" target)
 234           (symlink target file)
 235           (read-eof-marker))
 236          (x (raise
 237              (condition
 238               (&message (message "invalid symlink tokens"))
 239               (&nar-read-error (port port) (file file) (token x)))))))
 240       (("(" "type" "directory")
 241        (let ((dir file))
 242          (mkdir dir)
 243          (let loop ((prefix (read-string port)))
 244            (match prefix
 245              ("entry"
 246               (match (list (read-string port)
 247                            (read-string port) (read-string port)
 248                            (read-string port))
 249                 (("(" "name" file "node")
 250                  (restore (string-append dir "/" file))
 251                  (match (read-string port)
 252                    (")" #t)
 253                    (x
 254                     (raise
 255                      (condition
 256                       (&message
 257                        (message "unexpected directory entry termination"))
 258                       (&nar-read-error (port port)
 259                                        (file file)
 260                                        (token x))))))
 261                  (loop (read-string port)))))
 262              (")" #t)                             ; done with DIR
 263              (x
 264               (raise
 265                (condition
 266                 (&message (message "unexpected directory inter-entry marker"))
 267                 (&nar-read-error (port port) (file file) (token x)))))))))
 268       (x
 269        (raise
 270         (condition
 271          (&message (message "unsupported nar entry type"))
 272          (&nar-read-error (port port) (file file) (token x))))))))
 273
 274 \f
 275 ;;;
 276 ;;; Restoring a file set into the store.
 277 ;;;
 278
 279 ;; The code below accesses the store directly and is meant to be run from
 280 ;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
 281 ;; (1) the locks on the files to be restored as already held, and (2) the
 282 ;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
 283 ;;
 284 ;; So we're really duplicating that functionality of the daemon (well, until
 285 ;; most of the daemon is in Scheme :-)).  But note that we do use a couple of
 286 ;; RPCs for functionality not available otherwise, like 'valid-path?'.
 287
 288 (define (lock-store-file file)
 289   "Acquire exclusive access to FILE, a store file."
 290   (call-with-output-file (string-append file ".lock")
 291     (cut fcntl-flock <> 'write-lock)))
 292
 293 (define (unlock-store-file file)
 294   "Release access to FILE."
 295   (call-with-input-file (string-append file ".lock")
 296     (cut fcntl-flock <> 'unlock)))
 297
 298 (define* (finalize-store-file source target
 299                               #:key (references '()) deriver (lock? #t))
 300   "Rename SOURCE to TARGET and register TARGET as a valid store item, with
 301 REFERENCES and DERIVER.  When LOCK? is true, acquire exclusive locks on TARGET
 302 before attempting to register it; otherwise, assume TARGET's locks are already
 303 held."
 304
 305   ;; XXX: Currently we have to call out to the daemon to check whether TARGET
 306   ;; is valid.
 307   (with-store store
 308     (unless (valid-path? store target)
 309       (when lock?
 310         (lock-store-file target))
 311
 312       (unless (valid-path? store target)
 313         ;; If FILE already exists, delete it (it's invalid anyway.)
 314         (when (file-exists? target)
 315           (delete-file-recursively target))
 316
 317         ;; Install the new TARGET.
 318         (rename-file source target)
 319
 320         ;; Register TARGET.  As a side effect, it resets the timestamps of all
 321         ;; its files, recursively.  However, it doesn't attempt to deduplicate
 322         ;; its files like 'importPaths' does (FIXME).
 323         (register-path target
 324                        #:references references
 325                        #:deriver deriver))
 326
 327       (when lock?
 328         (unlock-store-file target)))))
 329
 330 (define (temporary-store-directory)
 331   "Return the file name of a temporary directory created in the store that is
 332 protected from garbage collection."
 333   (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
 334          (port     (mkstemp! template)))
 335     (close-port port)
 336     (with-store store
 337       (add-temp-root store template))
 338
 339     ;; There's a small window during which the GC could delete the file.  Try
 340     ;; again if that happens.
 341     (if (file-exists? template)
 342         (begin
 343           ;; It's up to the caller to create that file or directory.
 344           (delete-file template)
 345           template)
 346         (temporary-store-directory))))
 347
 348 (define* (restore-file-set port
 349                            #:key (verify-signature? #t) (lock? #t)
 350                            (log-port (current-error-port)))
 351   "Restore the file set read from PORT to the store.  The format of the data
 352 on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted
 353 archives with interspersed meta-data joining them together, possibly with a
 354 digital signature at the end.  Log progress to LOG-PORT.  Return the list of
 355 files restored.
 356
 357 When LOCK? is #f, assume locks for the files to be restored are already held.
 358 This is the case when the daemon calls a build hook.
 359
 360 Note that this procedure accesses the store directly, so it's only meant to be
 361 used by the daemon's build hooks since they cannot call back to the daemon
 362 while the locks are held."
 363   (define %export-magic
 364     ;; Number used to identify genuine file set archives.
 365     #x4558494e)
 366
 367   (define port*
 368     ;; Keep that one around, for error conditions.
 369     port)
 370
 371   (define (assert-valid-signature signature hash file)
 372     ;; Bail out if SIGNATURE, an sexp, doesn't match HASH, a bytevector
 373     ;; containing the expected hash for FILE.
 374     (let* ((signature (catch 'gcry-error
 375                         (lambda ()
 376                           (string->canonical-sexp signature))
 377                         (lambda (err . _)
 378                           (raise (condition
 379                                   (&message
 380                                    (message "signature is not a valid \
 381 s-expression"))
 382                                   (&nar-signature-error
 383                                    (file file)
 384                                    (signature signature) (port port)))))))
 385            (subject   (signature-subject signature))
 386            (data      (signature-signed-data signature)))
 387       (if (and data subject)
 388           (if (authorized-key? subject)
 389               (if (equal? (hash-data->bytevector data) hash)
 390                   (unless (valid-signature? signature)
 391                     (raise (condition
 392                             (&message (message "invalid signature"))
 393                             (&nar-signature-error
 394                              (file file) (signature signature) (port port)))))
 395                   (raise (condition (&message (message "invalid hash"))
 396                                     (&nar-invalid-hash-error
 397                                      (port port) (file file)
 398                                      (signature signature)
 399                                      (expected (hash-data->bytevector data))
 400                                      (actual hash)))))
 401               (raise (condition (&message (message "unauthorized public key"))
 402                                 (&nar-signature-error
 403                                  (signature signature) (file file) (port port)))))
 404           (raise (condition
 405                   (&message (message "corrupt signature data"))
 406                   (&nar-signature-error
 407                    (signature signature) (file file) (port port)))))))
 408
 409   (let loop ((n     (read-long-long port))
 410              (files '()))
 411     (case n
 412       ((0)
 413        (reverse files))
 414       ((1)
 415        (let-values (((port get-hash)
 416                      (open-sha256-input-port port)))
 417          (let ((temp (temporary-store-directory)))
 418            (restore-file port temp)
 419            (let ((magic (read-int port)))
 420              (unless (= magic %export-magic)
 421                (raise (condition
 422                        (&message (message "corrupt file set archive"))
 423                        (&nar-read-error
 424                         (port port*) (file #f) (token #f))))))
 425
 426            (let ((file     (read-store-path port))
 427                  (refs     (read-store-path-list port))
 428                  (deriver  (read-string port))
 429                  (hash     (get-hash))
 430                  (has-sig? (= 1 (read-int port))))
 431              (format log-port
 432                      (_ "importing file or directory '~a'...~%")
 433                      file)
 434
 435              (let ((sig (and has-sig? (read-string port))))
 436                (when verify-signature?
 437                  (if sig
 438                      (begin
 439                        (assert-valid-signature sig hash file)
 440                        (format log-port
 441                                (_ "found valid signature for '~a'~%")
 442                                file)
 443                        (finalize-store-file temp file
 444                                             #:references refs
 445                                             #:deriver deriver
 446                                             #:lock? lock?)
 447                        (loop (read-long-long port)
 448                              (cons file files)))
 449                      (raise (condition
 450                              (&message (message "imported file lacks \
 451 a signature"))
 452                              (&nar-signature-error
 453                               (port port*) (file file) (signature #f)))))))))))
 454       (else
 455        ;; Neither 0 nor 1.
 456        (raise (condition
 457                (&message (message "invalid inter-file archive mark"))
 458                (&nar-read-error
 459                 (port port) (file #f) (token #f))))))))
 460
 461 ;;; nar.scm ends here