guix/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 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 serialization)
  22   #:use-module (guix build syscalls)
  23   #:use-module ((guix build utils)
  24                 #:select (delete-file-recursively with-directory-excursion))
  25
  26   ;; XXX: Eventually we should use (guix store database) exclusively, and not
  27   ;; (guix store) since this is "daemon-side" code.
  28   #:use-module (guix store)
  29   #:use-module (guix store database)
  30   #:use-module ((guix store deduplication) #:select (dump-file/deduplicate))
  31   #:use-module ((guix build store-copy) #:select (store-info))
  32
  33   #:use-module (guix i18n)
  34   #:use-module (gcrypt hash)
  35   #:use-module (guix pki)
  36   #:use-module (gcrypt pk-crypto)
  37   #:use-module (srfi srfi-1)
  38   #:use-module (srfi srfi-11)
  39   #:use-module (srfi srfi-26)
  40   #:use-module (srfi srfi-34)
  41   #:use-module (srfi srfi-35)
  42   #:export (nar-invalid-hash-error?
  43             nar-invalid-hash-error-expected
  44             nar-invalid-hash-error-actual
  45
  46             nar-signature-error?
  47             nar-signature-error-signature
  48
  49             restore-file-set))
  50
  51 ;;; Comment:
  52 ;;;
  53 ;;; Read and write Nix archives, aka. ‘nar’.
  54 ;;;
  55 ;;; Code:
  56
  57 (define-condition-type &nar-signature-error &nar-error
  58   nar-signature-error?
  59   (signature nar-signature-error-signature))      ; faulty signature or #f
  60
  61 (define-condition-type &nar-invalid-hash-error &nar-signature-error
  62   nar-invalid-hash-error?
  63   (expected  nar-invalid-hash-error-expected)     ; expected hash (a bytevector)
  64   (actual    nar-invalid-hash-error-actual))      ; actual hash
  65
  66
  67 \f
  68 ;;;
  69 ;;; Restoring a file set into the store.
  70 ;;;
  71
  72 ;; The code below accesses the store directly and is meant to be run from
  73 ;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
  74 ;; (1) the locks on the files to be restored as already held, and (2) the
  75 ;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
  76 ;;
  77 ;; So we're really duplicating that functionality of the daemon (well, until
  78 ;; most of the daemon is in Scheme :-)).  But note that we do use a couple of
  79 ;; RPCs for functionality not available otherwise, like 'valid-path?'.
  80
  81 (define* (finalize-store-file source target
  82                               #:key (references '()) deriver (lock? #t))
  83   "Rename SOURCE to TARGET and register TARGET as a valid store item, with
  84 REFERENCES and DERIVER.  When LOCK? is true, acquire exclusive locks on TARGET
  85 before attempting to register it; otherwise, assume TARGET's locks are already
  86 held."
  87   ;; TODO: make this reusable
  88   (define (acquire-lock file)
  89     (let ((port (lock-file file)))
  90       ;; There is an inherent race condition between opening the lock file and
  91       ;; attempting to acquire the lock on it, and because we like deleting
  92       ;; these lock files when we release them, only the first successful
  93       ;; acquisition on a given lock file matters.  To make it easier to tell
  94       ;; when an acquisition is and isn't the first, the first to acquire it
  95       ;; writes a deletion token (arbitrary character) prior to releasing the
  96       ;; lock.
  97       (if (zero? (stat:size (stat port)))
  98           port
  99           ;; if FILE is non-empty, that's because it contains the deletion
 100           ;; token, so we aren't the first to acquire it.  So try again!
 101           (begin
 102             (close port)
 103             (acquire-lock file)))))
 104
 105   (with-database %default-database-file db
 106     (unless (path-id db target)
 107       (let ((lock (and lock?
 108                        (acquire-lock (string-append target ".lock")))))
 109
 110         (unless (path-id db target)
 111           ;; If FILE already exists, delete it (it's invalid anyway.)
 112           (when (file-exists? target)
 113             (delete-file-recursively target))
 114
 115           ;; Install the new TARGET.
 116           (rename-file source target)
 117
 118           ;; Register TARGET.  The 'restore-file' call took care of
 119           ;; deduplication, timestamps, and permissions.
 120           (register-items db
 121                           (list (store-info target deriver references))
 122                           #:deduplicate? #f))
 123
 124         (when lock?
 125           (delete-file (string-append target ".lock"))
 126           ;; Write the deletion token to inform anyone who acquires the lock
 127           ;; on this particular file next that they aren't the first to
 128           ;; acquire it, so they should retry.
 129           (display "d" lock)
 130           (force-output lock)
 131           (unlock-file lock))))))
 132
 133 (define (temporary-store-file)
 134   "Return the file name of a temporary file created in the store."
 135   (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
 136          (port     (mkstemp! template)))
 137     (close-port port)
 138     template))
 139
 140 (define-syntax-rule (with-temporary-store-file name body ...)
 141   "Evaluate BODY with NAME bound to the file name of a temporary store item
 142 protected from GC."
 143   (with-store store
 144     (let loop ((name (temporary-store-file)))
 145       ;; Add NAME to the current process' roots.  (Opening this connection to
 146       ;; the daemon allows us to reuse its code that deals with the
 147       ;; per-process roots file.)
 148       (add-temp-root store name)
 149
 150       ;; There's a window during which GC could delete NAME.  Try again when
 151       ;; that happens.
 152       (if (file-exists? name)
 153           (begin
 154             (delete-file name)
 155             body ...)
 156           (loop (temporary-store-file))))))
 157
 158 (define* (restore-one-item port
 159                            #:key acl (verify-signature? #t) (lock? #t)
 160                            (log-port (current-error-port)))
 161   "Restore one store item of a nar bundle read from PORT; return its file name
 162 on success."
 163
 164   (define (assert-valid-signature signature hash file)
 165     ;; Bail out if SIGNATURE, which must be a string as produced by
 166     ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
 167     ;; the expected hash for FILE.
 168     (let ((signature (catch 'gcry-error
 169                        (lambda ()
 170                          (string->canonical-sexp signature))
 171                        (lambda (key proc err)
 172                          (raise (condition
 173                                  (&message
 174                                   (message "signature is not a valid \
 175 s-expression"))
 176                                  (&nar-signature-error
 177                                   (file file)
 178                                   (signature signature) (port port))))))))
 179       (signature-case (signature hash (current-acl))
 180         (valid-signature #t)
 181         (invalid-signature
 182          (raise (condition
 183                  (&message (message "invalid signature"))
 184                  (&nar-signature-error
 185                   (file file) (signature signature) (port port)))))
 186         (hash-mismatch
 187          (raise (condition (&message (message "invalid hash"))
 188                            (&nar-invalid-hash-error
 189                             (port port) (file file)
 190                             (signature signature)
 191                             (expected (hash-data->bytevector
 192                                        (signature-signed-data signature)))
 193                             (actual hash)))))
 194         (unauthorized-key
 195          (raise (condition (&message (message "unauthorized public key"))
 196                            (&nar-signature-error
 197                             (signature signature) (file file) (port port)))))
 198         (corrupt-signature
 199          (raise (condition
 200                  (&message (message "corrupt signature data"))
 201                  (&nar-signature-error
 202                   (signature signature) (file file) (port port))))))))
 203
 204   (define %export-magic
 205     ;; Number used to identify genuine file set archives.
 206     #x4558494e)
 207
 208   (define port*
 209     ;; Keep that one around, for error conditions.
 210     port)
 211
 212   (let-values (((port get-hash)
 213                 (open-sha256-input-port port)))
 214     (with-temporary-store-file temp
 215       (restore-file port temp
 216                     #:dump-file dump-file/deduplicate)
 217
 218       (let ((magic (read-int port)))
 219         (unless (= magic %export-magic)
 220           (raise (condition
 221                   (&message (message "corrupt file set archive"))
 222                   (&nar-read-error
 223                    (port port*) (file #f) (token #f))))))
 224
 225       (let ((file     (read-store-path port))
 226             (refs     (read-store-path-list port))
 227             (deriver  (read-string port))
 228             (hash     (get-hash))
 229             (has-sig? (= 1 (read-int port))))
 230         (format log-port
 231                 (G_ "importing file or directory '~a'...~%")
 232                 file)
 233
 234         ;; The signature may contain characters that are meant to be
 235         ;; interpreted as bytes in a 'char *', so read them as a ISO-8859-1.
 236         (let ((sig (and has-sig? (read-latin1-string port))))
 237           (when verify-signature?
 238             (if sig
 239                 (begin
 240                   (assert-valid-signature sig hash file)
 241                   (format log-port
 242                           (G_ "found valid signature for '~a'~%")
 243                           file)
 244                   (finalize-store-file temp file
 245                                        #:references refs
 246                                        #:deriver deriver
 247                                        #:lock? lock?))
 248                 (raise (condition
 249                         (&message (message "imported file lacks \
 250 a signature"))
 251                         (&nar-signature-error
 252                          (port port*) (file file) (signature #f))))))
 253           file)))))
 254
 255 (define* (restore-file-set port
 256                            #:key (verify-signature? #t) (lock? #t)
 257                            (log-port (current-error-port)))
 258   "Restore the file set (\"nar bundle\") read from PORT to the store.  The
 259 format of the data on PORT must be as created by 'export-paths'---i.e., a
 260 series of Nar-formatted archives with interspersed meta-data joining them
 261 together, possibly with a digital signature at the end.  Log progress to
 262 LOG-PORT.  Return the list of files restored.
 263
 264 When LOCK? is #f, assume locks for the files to be restored are already held.
 265 This is the case when the daemon calls a build hook.
 266
 267 Note that this procedure accesses the store directly, so it's only meant to be
 268 used by the daemon's build hooks since they cannot call back to the daemon
 269 while the locks are held."
 270   (define acl
 271     (current-acl))
 272
 273   (let loop ((n     (read-long-long port))
 274              (files '()))
 275     (case n
 276       ((0)
 277        (reverse files))
 278       ((1)
 279        (let ((file
 280               (restore-one-item port
 281                                 #:acl acl #:verify-signature? verify-signature?
 282                                 #:lock? lock? #:log-port log-port)))
 283          (loop (read-long-long port)
 284                (cons file files))))
 285       (else
 286        ;; Neither 0 nor 1.
 287        (raise (condition
 288                (&message (message "invalid inter-file archive mark"))
 289                (&nar-read-error
 290                 (port port) (file #f) (token #f))))))))
 291
 292 ;;; Local Variables:
 293 ;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
 294 ;;; End:
 295
 296 ;;; nar.scm ends here