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 (srfi srfi-1)
  31   #:use-module (srfi srfi-11)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-34)
  34   #:use-module (srfi srfi-35)
  35   #:export (nar-invalid-hash-error?
  36             nar-invalid-hash-error-expected
  37             nar-invalid-hash-error-actual
  38
  39             nar-signature-error?
  40             nar-signature-error-signature
  41
  42             restore-file-set))
  43
  44 ;;; Comment:
  45 ;;;
  46 ;;; Read and write Nix archives, aka. ‘nar’.
  47 ;;;
  48 ;;; Code:
  49
  50 (define-condition-type &nar-signature-error &nar-error
  51   nar-signature-error?
  52   (signature nar-signature-error-signature))      ; faulty signature or #f
  53
  54 (define-condition-type &nar-invalid-hash-error &nar-signature-error
  55   nar-invalid-hash-error?
  56   (expected  nar-invalid-hash-error-expected)     ; expected hash (a bytevector)
  57   (actual    nar-invalid-hash-error-actual))      ; actual hash
  58
  59
  60 \f
  61 ;;;
  62 ;;; Restoring a file set into the store.
  63 ;;;
  64
  65 ;; The code below accesses the store directly and is meant to be run from
  66 ;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
  67 ;; (1) the locks on the files to be restored as already held, and (2) the
  68 ;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
  69 ;;
  70 ;; So we're really duplicating that functionality of the daemon (well, until
  71 ;; most of the daemon is in Scheme :-)).  But note that we do use a couple of
  72 ;; RPCs for functionality not available otherwise, like 'valid-path?'.
  73
  74 (define (lock-store-file file)
  75   "Acquire exclusive access to FILE, a store file."
  76   (call-with-output-file (string-append file ".lock")
  77     (cut fcntl-flock <> 'write-lock)))
  78
  79 (define (unlock-store-file file)
  80   "Release access to FILE."
  81   (call-with-input-file (string-append file ".lock")
  82     (cut fcntl-flock <> 'unlock)))
  83
  84 (define* (finalize-store-file source target
  85                               #:key (references '()) deriver (lock? #t))
  86   "Rename SOURCE to TARGET and register TARGET as a valid store item, with
  87 REFERENCES and DERIVER.  When LOCK? is true, acquire exclusive locks on TARGET
  88 before attempting to register it; otherwise, assume TARGET's locks are already
  89 held."
  90
  91   ;; XXX: Currently we have to call out to the daemon to check whether TARGET
  92   ;; is valid.
  93   (with-store store
  94     (unless (valid-path? store target)
  95       (when lock?
  96         (lock-store-file target))
  97
  98       (unless (valid-path? store target)
  99         ;; If FILE already exists, delete it (it's invalid anyway.)
 100         (when (file-exists? target)
 101           (delete-file-recursively target))
 102
 103         ;; Install the new TARGET.
 104         (rename-file source target)
 105
 106         ;; Register TARGET.  As a side effect, it resets the timestamps of all
 107         ;; its files, recursively, and runs a deduplication pass.
 108         (register-path target
 109                        #:references references
 110                        #:deriver deriver))
 111
 112       (when lock?
 113         (unlock-store-file target)))))
 114
 115 (define (temporary-store-file)
 116   "Return the file name of a temporary file created in the store."
 117   (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
 118          (port     (mkstemp! template)))
 119     (close-port port)
 120     template))
 121
 122 (define-syntax-rule (with-temporary-store-file name body ...)
 123   "Evaluate BODY with NAME bound to the file name of a temporary store item
 124 protected from GC."
 125   (let loop ((name (temporary-store-file)))
 126     (with-store store
 127       ;; Add NAME to the current process' roots.  (Opening this connection to
 128       ;; the daemon allows us to reuse its code that deals with the
 129       ;; per-process roots file.)
 130       (add-temp-root store name)
 131
 132       ;; There's a window during which GC could delete NAME.  Try again when
 133       ;; that happens.
 134       (if (file-exists? name)
 135           (begin
 136             (delete-file name)
 137             body ...)
 138           (loop (temporary-store-file))))))
 139
 140 (define* (restore-one-item port
 141                            #:key acl (verify-signature? #t) (lock? #t)
 142                            (log-port (current-error-port)))
 143   "Restore one store item from PORT; return its file name on success."
 144
 145   (define (assert-valid-signature signature hash file)
 146     ;; Bail out if SIGNATURE, which must be a string as produced by
 147     ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
 148     ;; the expected hash for FILE.
 149     (let ((signature (catch 'gcry-error
 150                        (lambda ()
 151                          (string->canonical-sexp signature))
 152                        (lambda (key proc err)
 153                          (raise (condition
 154                                  (&message
 155                                   (message "signature is not a valid \
 156 s-expression"))
 157                                  (&nar-signature-error
 158                                   (file file)
 159                                   (signature signature) (port port))))))))
 160       (signature-case (signature hash (current-acl))
 161         (valid-signature #t)
 162         (invalid-signature
 163          (raise (condition
 164                  (&message (message "invalid signature"))
 165                  (&nar-signature-error
 166                   (file file) (signature signature) (port port)))))
 167         (hash-mismatch
 168          (raise (condition (&message (message "invalid hash"))
 169                            (&nar-invalid-hash-error
 170                             (port port) (file file)
 171                             (signature signature)
 172                             (expected (hash-data->bytevector
 173                                        (signature-signed-data signature)))
 174                             (actual hash)))))
 175         (unauthorized-key
 176          (raise (condition (&message (message "unauthorized public key"))
 177                            (&nar-signature-error
 178                             (signature signature) (file file) (port port)))))
 179         (corrupt-signature
 180          (raise (condition
 181                  (&message (message "corrupt signature data"))
 182                  (&nar-signature-error
 183                   (signature signature) (file file) (port port))))))))
 184
 185   (define %export-magic
 186     ;; Number used to identify genuine file set archives.
 187     #x4558494e)
 188
 189   (define port*
 190     ;; Keep that one around, for error conditions.
 191     port)
 192
 193   (let-values (((port get-hash)
 194                 (open-sha256-input-port port)))
 195     (with-temporary-store-file temp
 196       (restore-file port temp)
 197
 198       (let ((magic (read-int port)))
 199         (unless (= magic %export-magic)
 200           (raise (condition
 201                   (&message (message "corrupt file set archive"))
 202                   (&nar-read-error
 203                    (port port*) (file #f) (token #f))))))
 204
 205       (let ((file     (read-store-path port))
 206             (refs     (read-store-path-list port))
 207             (deriver  (read-string port))
 208             (hash     (get-hash))
 209             (has-sig? (= 1 (read-int port))))
 210         (format log-port
 211                 (_ "importing file or directory '~a'...~%")
 212                 file)
 213
 214         (let ((sig (and has-sig? (read-string port))))
 215           (when verify-signature?
 216             (if sig
 217                 (begin
 218                   (assert-valid-signature sig hash file)
 219                   (format log-port
 220                           (_ "found valid signature for '~a'~%")
 221                           file)
 222                   (finalize-store-file temp file
 223                                        #:references refs
 224                                        #:deriver deriver
 225                                        #:lock? lock?))
 226                 (raise (condition
 227                         (&message (message "imported file lacks \
 228 a signature"))
 229                         (&nar-signature-error
 230                          (port port*) (file file) (signature #f))))))
 231           file)))))
 232
 233 (define* (restore-file-set port
 234                            #:key (verify-signature? #t) (lock? #t)
 235                            (log-port (current-error-port)))
 236   "Restore the file set read from PORT to the store.  The format of the data
 237 on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted
 238 archives with interspersed meta-data joining them together, possibly with a
 239 digital signature at the end.  Log progress to LOG-PORT.  Return the list of
 240 files restored.
 241
 242 When LOCK? is #f, assume locks for the files to be restored are already held.
 243 This is the case when the daemon calls a build hook.
 244
 245 Note that this procedure accesses the store directly, so it's only meant to be
 246 used by the daemon's build hooks since they cannot call back to the daemon
 247 while the locks are held."
 248   (define acl
 249     (current-acl))
 250
 251   (let loop ((n     (read-long-long port))
 252              (files '()))
 253     (case n
 254       ((0)
 255        (reverse files))
 256       ((1)
 257        (let ((file
 258               (restore-one-item port
 259                                 #:acl acl #:verify-signature? verify-signature?
 260                                 #:lock? lock? #:log-port log-port)))
 261          (loop (read-long-long port)
 262                (cons file files))))
 263       (else
 264        ;; Neither 0 nor 1.
 265        (raise (condition
 266                (&message (message "invalid inter-file archive mark"))
 267                (&nar-read-error
 268                 (port port) (file #f) (token #f))))))))
 269
 270 ;;; Local Variables:
 271 ;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
 272 ;;; End:
 273
 274 ;;; nar.scm ends here