guix/nar.scm

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