guix/nar.scm

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