| 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 | |
| 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* (finalize-store-file source target |
| 80 | #:key (references '()) deriver (lock? #t)) |
| 81 | "Rename SOURCE to TARGET and register TARGET as a valid store item, with |
| 82 | REFERENCES and DERIVER. When LOCK? is true, acquire exclusive locks on TARGET |
| 83 | before attempting to register it; otherwise, assume TARGET's locks are already |
| 84 | held." |
| 85 | (with-database %default-database-file db |
| 86 | (unless (path-id db target) |
| 87 | (let ((lock (and lock? |
| 88 | (lock-file (string-append target ".lock"))))) |
| 89 | |
| 90 | (unless (path-id db target) |
| 91 | ;; If FILE already exists, delete it (it's invalid anyway.) |
| 92 | (when (file-exists? target) |
| 93 | (delete-file-recursively target)) |
| 94 | |
| 95 | ;; Install the new TARGET. |
| 96 | (rename-file source target) |
| 97 | |
| 98 | ;; Register TARGET. As a side effect, it resets the timestamps of all |
| 99 | ;; its files, recursively, and runs a deduplication pass. |
| 100 | (register-path target |
| 101 | #:references references |
| 102 | #:deriver deriver)) |
| 103 | |
| 104 | (when lock? |
| 105 | (unlock-file lock)))))) |
| 106 | |
| 107 | (define (temporary-store-file) |
| 108 | "Return the file name of a temporary file created in the store." |
| 109 | (let* ((template (string-append (%store-prefix) "/guix-XXXXXX")) |
| 110 | (port (mkstemp! template))) |
| 111 | (close-port port) |
| 112 | template)) |
| 113 | |
| 114 | (define-syntax-rule (with-temporary-store-file name body ...) |
| 115 | "Evaluate BODY with NAME bound to the file name of a temporary store item |
| 116 | protected from GC." |
| 117 | (let loop ((name (temporary-store-file))) |
| 118 | (with-store store |
| 119 | ;; Add NAME to the current process' roots. (Opening this connection to |
| 120 | ;; the daemon allows us to reuse its code that deals with the |
| 121 | ;; per-process roots file.) |
| 122 | (add-temp-root store name) |
| 123 | |
| 124 | ;; There's a window during which GC could delete NAME. Try again when |
| 125 | ;; that happens. |
| 126 | (if (file-exists? name) |
| 127 | (begin |
| 128 | (delete-file name) |
| 129 | body ...) |
| 130 | (loop (temporary-store-file)))))) |
| 131 | |
| 132 | (define* (restore-one-item port |
| 133 | #:key acl (verify-signature? #t) (lock? #t) |
| 134 | (log-port (current-error-port))) |
| 135 | "Restore one store item from PORT; return its file name on success." |
| 136 | |
| 137 | (define (assert-valid-signature signature hash file) |
| 138 | ;; Bail out if SIGNATURE, which must be a string as produced by |
| 139 | ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing |
| 140 | ;; the expected hash for FILE. |
| 141 | (let ((signature (catch 'gcry-error |
| 142 | (lambda () |
| 143 | (string->canonical-sexp signature)) |
| 144 | (lambda (key proc err) |
| 145 | (raise (condition |
| 146 | (&message |
| 147 | (message "signature is not a valid \ |
| 148 | s-expression")) |
| 149 | (&nar-signature-error |
| 150 | (file file) |
| 151 | (signature signature) (port port)))))))) |
| 152 | (signature-case (signature hash (current-acl)) |
| 153 | (valid-signature #t) |
| 154 | (invalid-signature |
| 155 | (raise (condition |
| 156 | (&message (message "invalid signature")) |
| 157 | (&nar-signature-error |
| 158 | (file file) (signature signature) (port port))))) |
| 159 | (hash-mismatch |
| 160 | (raise (condition (&message (message "invalid hash")) |
| 161 | (&nar-invalid-hash-error |
| 162 | (port port) (file file) |
| 163 | (signature signature) |
| 164 | (expected (hash-data->bytevector |
| 165 | (signature-signed-data signature))) |
| 166 | (actual hash))))) |
| 167 | (unauthorized-key |
| 168 | (raise (condition (&message (message "unauthorized public key")) |
| 169 | (&nar-signature-error |
| 170 | (signature signature) (file file) (port port))))) |
| 171 | (corrupt-signature |
| 172 | (raise (condition |
| 173 | (&message (message "corrupt signature data")) |
| 174 | (&nar-signature-error |
| 175 | (signature signature) (file file) (port port)))))))) |
| 176 | |
| 177 | (define %export-magic |
| 178 | ;; Number used to identify genuine file set archives. |
| 179 | #x4558494e) |
| 180 | |
| 181 | (define port* |
| 182 | ;; Keep that one around, for error conditions. |
| 183 | port) |
| 184 | |
| 185 | (let-values (((port get-hash) |
| 186 | (open-sha256-input-port port))) |
| 187 | (with-temporary-store-file temp |
| 188 | (restore-file port temp) |
| 189 | |
| 190 | (let ((magic (read-int port))) |
| 191 | (unless (= magic %export-magic) |
| 192 | (raise (condition |
| 193 | (&message (message "corrupt file set archive")) |
| 194 | (&nar-read-error |
| 195 | (port port*) (file #f) (token #f)))))) |
| 196 | |
| 197 | (let ((file (read-store-path port)) |
| 198 | (refs (read-store-path-list port)) |
| 199 | (deriver (read-string port)) |
| 200 | (hash (get-hash)) |
| 201 | (has-sig? (= 1 (read-int port)))) |
| 202 | (format log-port |
| 203 | (G_ "importing file or directory '~a'...~%") |
| 204 | file) |
| 205 | |
| 206 | ;; The signature may contain characters that are meant to be |
| 207 | ;; interpreted as bytes in a 'char *', so read them as a ISO-8859-1. |
| 208 | (let ((sig (and has-sig? (read-latin1-string port)))) |
| 209 | (when verify-signature? |
| 210 | (if sig |
| 211 | (begin |
| 212 | (assert-valid-signature sig hash file) |
| 213 | (format log-port |
| 214 | (G_ "found valid signature for '~a'~%") |
| 215 | file) |
| 216 | (finalize-store-file temp file |
| 217 | #:references refs |
| 218 | #:deriver deriver |
| 219 | #:lock? lock?)) |
| 220 | (raise (condition |
| 221 | (&message (message "imported file lacks \ |
| 222 | a signature")) |
| 223 | (&nar-signature-error |
| 224 | (port port*) (file file) (signature #f)))))) |
| 225 | file))))) |
| 226 | |
| 227 | (define* (restore-file-set port |
| 228 | #:key (verify-signature? #t) (lock? #t) |
| 229 | (log-port (current-error-port))) |
| 230 | "Restore the file set read from PORT to the store. The format of the data |
| 231 | on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted |
| 232 | archives with interspersed meta-data joining them together, possibly with a |
| 233 | digital signature at the end. Log progress to LOG-PORT. Return the list of |
| 234 | files restored. |
| 235 | |
| 236 | When LOCK? is #f, assume locks for the files to be restored are already held. |
| 237 | This is the case when the daemon calls a build hook. |
| 238 | |
| 239 | Note that this procedure accesses the store directly, so it's only meant to be |
| 240 | used by the daemon's build hooks since they cannot call back to the daemon |
| 241 | while the locks are held." |
| 242 | (define acl |
| 243 | (current-acl)) |
| 244 | |
| 245 | (let loop ((n (read-long-long port)) |
| 246 | (files '())) |
| 247 | (case n |
| 248 | ((0) |
| 249 | (reverse files)) |
| 250 | ((1) |
| 251 | (let ((file |
| 252 | (restore-one-item port |
| 253 | #:acl acl #:verify-signature? verify-signature? |
| 254 | #:lock? lock? #:log-port log-port))) |
| 255 | (loop (read-long-long port) |
| 256 | (cons file files)))) |
| 257 | (else |
| 258 | ;; Neither 0 nor 1. |
| 259 | (raise (condition |
| 260 | (&message (message "invalid inter-file archive mark")) |
| 261 | (&nar-read-error |
| 262 | (port port) (file #f) (token #f)))))))) |
| 263 | |
| 264 | ;;; Local Variables: |
| 265 | ;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1) |
| 266 | ;;; End: |
| 267 | |
| 268 | ;;; nar.scm ends here |