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
 123         (when lock?
 124           (delete-file (string-append target ".lock"))
 125           ;; Write the deletion token to inform anyone who acquires the lock
 126           ;; on this particular file next that they aren't the first to
 127           ;; acquire it, so they should retry.
 128           (display "d" lock)
 129           (force-output lock)
 130           (unlock-file lock))))))
 131
 132 (define (temporary-store-file)
 133   "Return the file name of a temporary file created in the store."
 134   (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
 135          (port     (mkstemp! template)))
 136     (close-port port)
 137     template))
 138
 139 (define-syntax-rule (with-temporary-store-file name body ...)
 140   "Evaluate BODY with NAME bound to the file name of a temporary store item
 141 protected from GC."
 142   (with-store store
 143     (let loop ((name (temporary-store-file)))
 144       ;; Add NAME to the current process' roots.  (Opening this connection to
 145       ;; the daemon allows us to reuse its code that deals with the
 146       ;; per-process roots file.)
 147       (add-temp-root store name)
 148
 149       ;; There's a window during which GC could delete NAME.  Try again when
 150       ;; that happens.
 151       (if (file-exists? name)
 152           (begin
 153             (delete-file name)
 154             body ...)
 155           (loop (temporary-store-file))))))
 156
 157 (define* (restore-one-item port
 158                            #:key acl (verify-signature? #t) (lock? #t)
 159                            (log-port (current-error-port)))
 160   "Restore one store item of a nar bundle read from PORT; return its file name
 161 on success."
 162
 163   (define (assert-valid-signature signature hash file)
 164     ;; Bail out if SIGNATURE, which must be a string as produced by
 165     ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
 166     ;; the expected hash for FILE.
 167     (let ((signature (catch 'gcry-error
 168                        (lambda ()
 169                          (string->canonical-sexp signature))
 170                        (lambda (key proc err)
 171                          (raise (condition
 172                                  (&message
 173                                   (message "signature is not a valid \
 174 s-expression"))
 175                                  (&nar-signature-error
 176                                   (file file)
 177                                   (signature signature) (port port))))))))
 178       (signature-case (signature hash (current-acl))
 179         (valid-signature #t)
 180         (invalid-signature
 181          (raise (condition
 182                  (&message (message "invalid signature"))
 183                  (&nar-signature-error
 184                   (file file) (signature signature) (port port)))))
 185         (hash-mismatch
 186          (raise (condition (&message (message "invalid hash"))
 187                            (&nar-invalid-hash-error
 188                             (port port) (file file)
 189                             (signature signature)
 190                             (expected (hash-data->bytevector
 191                                        (signature-signed-data signature)))
 192                             (actual hash)))))
 193         (unauthorized-key
 194          (raise (condition (&message (message "unauthorized public key"))
 195                            (&nar-signature-error
 196                             (signature signature) (file file) (port port)))))
 197         (corrupt-signature
 198          (raise (condition
 199                  (&message (message "corrupt signature data"))
 200                  (&nar-signature-error
 201                   (signature signature) (file file) (port port))))))))
 202
 203   (define %export-magic
 204     ;; Number used to identify genuine file set archives.
 205     #x4558494e)
 206
 207   (define port*
 208     ;; Keep that one around, for error conditions.
 209     port)
 210
 211   (let-values (((port get-hash)
 212                 (open-sha256-input-port port)))
 213     (with-temporary-store-file temp
 214       (restore-file port temp
 215                     #:dump-file dump-file/deduplicate)
 216
 217       (let ((magic (read-int port)))
 218         (unless (= magic %export-magic)
 219           (raise (condition
 220                   (&message (message "corrupt file set archive"))
 221                   (&nar-read-error
 222                    (port port*) (file #f) (token #f))))))
 223
 224       (let ((file     (read-store-path port))
 225             (refs     (read-store-path-list port))
 226             (deriver  (read-string port))
 227             (hash     (get-hash))
 228             (has-sig? (= 1 (read-int port))))
 229         (format log-port
 230                 (G_ "importing file or directory '~a'...~%")
 231                 file)
 232
 233         ;; The signature may contain characters that are meant to be
 234         ;; interpreted as bytes in a 'char *', so read them as a ISO-8859-1.
 235         (let ((sig (and has-sig? (read-latin1-string port))))
 236           (when verify-signature?
 237             (if sig
 238                 (begin
 239                   (assert-valid-signature sig hash file)
 240                   (format log-port
 241                           (G_ "found valid signature for '~a'~%")
 242                           file)
 243                   (finalize-store-file temp file
 244                                        #:references refs
 245                                        #:deriver deriver
 246                                        #:lock? lock?))
 247                 (raise (condition
 248                         (&message (message "imported file lacks \
 249 a signature"))
 250                         (&nar-signature-error
 251                          (port port*) (file file) (signature #f))))))
 252           file)))))
 253
 254 (define* (restore-file-set port
 255                            #:key (verify-signature? #t) (lock? #t)
 256                            (log-port (current-error-port)))
 257   "Restore the file set (\"nar bundle\") read from PORT to the store.  The
 258 format of the data on PORT must be as created by 'export-paths'---i.e., a
 259 series of Nar-formatted archives with interspersed meta-data joining them
 260 together, possibly with a digital signature at the end.  Log progress to
 261 LOG-PORT.  Return the list of files restored.
 262
 263 When LOCK? is #f, assume locks for the files to be restored are already held.
 264 This is the case when the daemon calls a build hook.
 265
 266 Note that this procedure accesses the store directly, so it's only meant to be
 267 used by the daemon's build hooks since they cannot call back to the daemon
 268 while the locks are held."
 269   (define acl
 270     (current-acl))
 271
 272   (let loop ((n     (read-long-long port))
 273              (files '()))
 274     (case n
 275       ((0)
 276        (reverse files))
 277       ((1)
 278        (let ((file
 279               (restore-one-item port
 280                                 #:acl acl #:verify-signature? verify-signature?
 281                                 #:lock? lock? #:log-port log-port)))
 282          (loop (read-long-long port)
 283                (cons file files))))
 284       (else
 285        ;; Neither 0 nor 1.
 286        (raise (condition
 287                (&message (message "invalid inter-file archive mark"))
 288                (&nar-read-error
 289                 (port port) (file #f) (token #f))))))))
 290
 291 ;;; Local Variables:
 292 ;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
 293 ;;; End:
 294
 295 ;;; nar.scm ends here