| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> |
| 3 | ;;; |
| 4 | ;;; This file is part of GNU Guix. |
| 5 | ;;; |
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 7 | ;;; under the terms of the GNU General Public License as published by |
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 9 | ;;; your option) any later version. |
| 10 | ;;; |
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 14 | ;;; GNU General Public License for more details. |
| 15 | ;;; |
| 16 | ;;; You should have received a copy of the GNU General Public License |
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 18 | |
| 19 | (define-module (test-channels) |
| 20 | #:use-module (guix channels) |
| 21 | #:use-module (guix profiles) |
| 22 | #:use-module ((guix build syscalls) #:select (mkdtemp!)) |
| 23 | #:use-module (guix tests) |
| 24 | #:use-module (guix store) |
| 25 | #:use-module ((guix grafts) #:select (%graft?)) |
| 26 | #:use-module (guix derivations) |
| 27 | #:use-module (guix sets) |
| 28 | #:use-module (guix gexp) |
| 29 | #:use-module ((guix diagnostics) |
| 30 | #:select (error-location? |
| 31 | error-location location-line |
| 32 | formatted-message? |
| 33 | formatted-message-string |
| 34 | formatted-message-arguments)) |
| 35 | #:use-module ((guix build utils) #:select (which)) |
| 36 | #:use-module (git) |
| 37 | #:use-module (guix git) |
| 38 | #:use-module (guix git-authenticate) |
| 39 | #:use-module (guix openpgp) |
| 40 | #:use-module (guix tests git) |
| 41 | #:use-module (guix tests gnupg) |
| 42 | #:use-module (srfi srfi-1) |
| 43 | #:use-module (srfi srfi-26) |
| 44 | #:use-module (srfi srfi-34) |
| 45 | #:use-module (srfi srfi-35) |
| 46 | #:use-module (srfi srfi-64) |
| 47 | #:use-module (rnrs bytevectors) |
| 48 | #:use-module (rnrs io ports) |
| 49 | #:use-module (ice-9 control) |
| 50 | #:use-module (ice-9 match)) |
| 51 | |
| 52 | (define (gpg+git-available?) |
| 53 | (and (which (git-command)) |
| 54 | (which (gpg-command)) (which (gpgconf-command)))) |
| 55 | |
| 56 | (define commit-id-string |
| 57 | (compose oid->string commit-id)) |
| 58 | |
| 59 | \f |
| 60 | (test-begin "channels") |
| 61 | |
| 62 | (define* (make-instance #:key |
| 63 | (name 'fake) |
| 64 | (commit "cafebabe") |
| 65 | (spec #f)) |
| 66 | (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX")) |
| 67 | (when spec |
| 68 | (call-with-output-file (string-append instance-dir "/.guix-channel") |
| 69 | (lambda (port) (write spec port)))) |
| 70 | (checkout->channel-instance instance-dir |
| 71 | #:commit commit |
| 72 | #:name name)) |
| 73 | |
| 74 | (define instance--boring (make-instance)) |
| 75 | (define instance--unsupported-version |
| 76 | (make-instance #:spec |
| 77 | '(channel (version 42) (dependencies whatever)))) |
| 78 | (define instance--no-deps |
| 79 | (make-instance #:spec |
| 80 | '(channel (version 0)))) |
| 81 | (define instance--sub-directory |
| 82 | (make-instance #:spec |
| 83 | '(channel (version 0) (directory "modules")))) |
| 84 | (define instance--simple |
| 85 | (make-instance #:spec |
| 86 | '(channel |
| 87 | (version 0) |
| 88 | (dependencies |
| 89 | (channel |
| 90 | (name test-channel) |
| 91 | (url "https://example.com/test-channel")))))) |
| 92 | (define instance--with-dupes |
| 93 | (make-instance #:spec |
| 94 | '(channel |
| 95 | (version 0) |
| 96 | (dependencies |
| 97 | (channel |
| 98 | (name test-channel) |
| 99 | (url "https://example.com/test-channel")) |
| 100 | (channel |
| 101 | (name test-channel) |
| 102 | (url "https://example.com/test-channel") |
| 103 | (commit "abc1234")) |
| 104 | (channel |
| 105 | (name test-channel) |
| 106 | (url "https://example.com/test-channel-elsewhere")))))) |
| 107 | |
| 108 | (define channel-instance-metadata |
| 109 | (@@ (guix channels) channel-instance-metadata)) |
| 110 | (define channel-metadata-directory |
| 111 | (@@ (guix channels) channel-metadata-directory)) |
| 112 | (define channel-metadata-dependencies |
| 113 | (@@ (guix channels) channel-metadata-dependencies)) |
| 114 | |
| 115 | \f |
| 116 | (test-equal "channel-instance-metadata returns default if .guix-channel does not exist" |
| 117 | '("/" ()) |
| 118 | (let ((metadata (channel-instance-metadata instance--boring))) |
| 119 | (list (channel-metadata-directory metadata) |
| 120 | (channel-metadata-dependencies metadata)))) |
| 121 | |
| 122 | (test-equal "channel-instance-metadata and default dependencies" |
| 123 | '() |
| 124 | (channel-metadata-dependencies (channel-instance-metadata instance--no-deps))) |
| 125 | |
| 126 | (test-equal "channel-instance-metadata and directory" |
| 127 | "/modules" |
| 128 | (channel-metadata-directory |
| 129 | (channel-instance-metadata instance--sub-directory))) |
| 130 | |
| 131 | (test-equal "channel-instance-metadata rejects unsupported version" |
| 132 | 1 ;line number in the generated '.guix-channel' |
| 133 | (guard (c ((and (message-condition? c) (error-location? c)) |
| 134 | (location-line (error-location c)))) |
| 135 | (channel-instance-metadata instance--unsupported-version))) |
| 136 | |
| 137 | (test-assert "channel-instance-metadata returns <channel-metadata>" |
| 138 | (every (@@ (guix channels) channel-metadata?) |
| 139 | (map channel-instance-metadata |
| 140 | (list instance--no-deps |
| 141 | instance--simple |
| 142 | instance--with-dupes)))) |
| 143 | |
| 144 | (test-assert "channel-instance-metadata dependencies are channels" |
| 145 | (let ((deps ((@@ (guix channels) channel-metadata-dependencies) |
| 146 | (channel-instance-metadata instance--simple)))) |
| 147 | (match deps |
| 148 | (((? channel? dep)) #t) |
| 149 | (_ #f)))) |
| 150 | |
| 151 | (test-assert "latest-channel-instances includes channel dependencies" |
| 152 | (let* ((channel (channel |
| 153 | (name 'test) |
| 154 | (url "test"))) |
| 155 | (test-dir (channel-instance-checkout instance--simple))) |
| 156 | (mock ((guix git) update-cached-checkout |
| 157 | (lambda* (url #:key ref starting-commit) |
| 158 | (match url |
| 159 | ("test" (values test-dir "caf3cabba9e" #f)) |
| 160 | (_ (values (channel-instance-checkout instance--no-deps) |
| 161 | "abcde1234" #f))))) |
| 162 | (with-store store |
| 163 | (let ((instances (latest-channel-instances store (list channel)))) |
| 164 | (and (eq? 2 (length instances)) |
| 165 | (lset= eq? |
| 166 | '(test test-channel) |
| 167 | (map (compose channel-name channel-instance-channel) |
| 168 | instances)))))))) |
| 169 | |
| 170 | (test-assert "latest-channel-instances excludes duplicate channel dependencies" |
| 171 | (let* ((channel (channel |
| 172 | (name 'test) |
| 173 | (url "test"))) |
| 174 | (test-dir (channel-instance-checkout instance--with-dupes))) |
| 175 | (mock ((guix git) update-cached-checkout |
| 176 | (lambda* (url #:key ref starting-commit) |
| 177 | (match url |
| 178 | ("test" (values test-dir "caf3cabba9e" #f)) |
| 179 | (_ (values (channel-instance-checkout instance--no-deps) |
| 180 | "abcde1234" #f))))) |
| 181 | (with-store store |
| 182 | (let ((instances (latest-channel-instances store (list channel)))) |
| 183 | (and (= 2 (length instances)) |
| 184 | (lset= eq? |
| 185 | '(test test-channel) |
| 186 | (map (compose channel-name channel-instance-channel) |
| 187 | instances)) |
| 188 | ;; only the most specific channel dependency should remain, |
| 189 | ;; i.e. the one with a specified commit. |
| 190 | (find (lambda (instance) |
| 191 | (and (eq? (channel-name |
| 192 | (channel-instance-channel instance)) |
| 193 | 'test-channel) |
| 194 | (string=? (channel-commit |
| 195 | (channel-instance-channel instance)) |
| 196 | "abc1234"))) |
| 197 | instances))))))) |
| 198 | |
| 199 | (unless (which (git-command)) (test-skip 1)) |
| 200 | (test-equal "latest-channel-instances #:validate-pull" |
| 201 | 'descendant |
| 202 | |
| 203 | ;; Make sure the #:validate-pull procedure receives the right values. |
| 204 | (let/ec return |
| 205 | (with-temporary-git-repository directory |
| 206 | '((add "a.txt" "A") |
| 207 | (commit "first commit") |
| 208 | (add "b.scm" "#t") |
| 209 | (commit "second commit")) |
| 210 | (with-repository directory repository |
| 211 | (let* ((commit1 (find-commit repository "first")) |
| 212 | (commit2 (find-commit repository "second")) |
| 213 | (spec (channel (url (string-append "file://" directory)) |
| 214 | (name 'foo))) |
| 215 | (new (channel (inherit spec) |
| 216 | (commit (oid->string (commit-id commit2))))) |
| 217 | (old (channel (inherit spec) |
| 218 | (commit (oid->string (commit-id commit1)))))) |
| 219 | (define (validate-pull channel current commit relation) |
| 220 | (return (and (eq? channel old) |
| 221 | (string=? (oid->string (commit-id commit2)) |
| 222 | current) |
| 223 | (string=? (oid->string (commit-id commit1)) |
| 224 | commit) |
| 225 | relation))) |
| 226 | |
| 227 | (with-store store |
| 228 | ;; Attempt a downgrade from NEW to OLD. |
| 229 | (latest-channel-instances store (list old) |
| 230 | #:current-channels (list new) |
| 231 | #:validate-pull validate-pull))))))) |
| 232 | |
| 233 | (test-assert "channel-instances->manifest" |
| 234 | ;; Compute the manifest for a graph of instances and make sure we get a |
| 235 | ;; derivation graph that mirrors the instance graph. This test also ensures |
| 236 | ;; we don't try to access Git repositores at all at this stage. |
| 237 | (let* ((spec (lambda deps |
| 238 | `(channel (version 0) |
| 239 | (dependencies |
| 240 | ,@(map (lambda (dep) |
| 241 | `(channel |
| 242 | (name ,dep) |
| 243 | (url "http://example.org"))) |
| 244 | deps))))) |
| 245 | (guix (make-instance #:name 'guix)) |
| 246 | (instance0 (make-instance #:name 'a)) |
| 247 | (instance1 (make-instance #:name 'b #:spec (spec 'a))) |
| 248 | (instance2 (make-instance #:name 'c #:spec (spec 'b))) |
| 249 | (instance3 (make-instance #:name 'd #:spec (spec 'c 'a)))) |
| 250 | (%graft? #f) ;don't try to build stuff |
| 251 | |
| 252 | ;; Create 'build-self.scm' so that GUIX is recognized as the 'guix' channel. |
| 253 | (let ((source (channel-instance-checkout guix))) |
| 254 | (mkdir (string-append source "/build-aux")) |
| 255 | (call-with-output-file (string-append source |
| 256 | "/build-aux/build-self.scm") |
| 257 | (lambda (port) |
| 258 | (write '(begin |
| 259 | (use-modules (guix) (gnu packages bootstrap)) |
| 260 | |
| 261 | (lambda _ |
| 262 | (package->derivation %bootstrap-guile))) |
| 263 | port)))) |
| 264 | |
| 265 | (with-store store |
| 266 | (let () |
| 267 | (define manifest |
| 268 | (run-with-store store |
| 269 | (channel-instances->manifest (list guix |
| 270 | instance0 instance1 |
| 271 | instance2 instance3)))) |
| 272 | |
| 273 | (define entries |
| 274 | (manifest-entries manifest)) |
| 275 | |
| 276 | (define (depends? drv in out) |
| 277 | ;; Return true if DRV depends (directly or indirectly) on all of IN |
| 278 | ;; and none of OUT. |
| 279 | (let ((set (list->set |
| 280 | (requisites store |
| 281 | (list (derivation-file-name drv))))) |
| 282 | (in (map derivation-file-name in)) |
| 283 | (out (map derivation-file-name out))) |
| 284 | (and (every (cut set-contains? set <>) in) |
| 285 | (not (any (cut set-contains? set <>) out))))) |
| 286 | |
| 287 | (define (lookup name) |
| 288 | (run-with-store store |
| 289 | (lower-object |
| 290 | (manifest-entry-item |
| 291 | (manifest-lookup manifest |
| 292 | (manifest-pattern (name name))))))) |
| 293 | |
| 294 | (let ((drv-guix (lookup "guix")) |
| 295 | (drv0 (lookup "a")) |
| 296 | (drv1 (lookup "b")) |
| 297 | (drv2 (lookup "c")) |
| 298 | (drv3 (lookup "d"))) |
| 299 | (and (depends? drv-guix '() (list drv0 drv1 drv2 drv3)) |
| 300 | (depends? drv0 |
| 301 | (list) (list drv1 drv2 drv3)) |
| 302 | (depends? drv1 |
| 303 | (list drv0) (list drv2 drv3)) |
| 304 | (depends? drv2 |
| 305 | (list drv1) (list drv3)) |
| 306 | (depends? drv3 |
| 307 | (list drv2 drv0) (list)))))))) |
| 308 | |
| 309 | (unless (which (git-command)) (test-skip 1)) |
| 310 | (test-equal "channel-news, no news" |
| 311 | '() |
| 312 | (with-temporary-git-repository directory |
| 313 | '((add "a.txt" "A") |
| 314 | (commit "the commit")) |
| 315 | (with-repository directory repository |
| 316 | (let ((channel (channel (url (string-append "file://" directory)) |
| 317 | (name 'foo))) |
| 318 | (latest (reference-name->oid repository "HEAD"))) |
| 319 | (channel-news-for-commit channel (oid->string latest)))))) |
| 320 | |
| 321 | (unless (which (git-command)) (test-skip 1)) |
| 322 | (test-assert "channel-news, one entry" |
| 323 | (with-temporary-git-repository directory |
| 324 | `((add ".guix-channel" |
| 325 | ,(object->string |
| 326 | '(channel (version 0) |
| 327 | (news-file "news.scm")))) |
| 328 | (commit "first commit") |
| 329 | (add "src/a.txt" "A") |
| 330 | (commit "second commit") |
| 331 | (tag "tag-for-first-news-entry") |
| 332 | (add "news.scm" |
| 333 | ,(lambda (repository) |
| 334 | (let ((previous |
| 335 | (reference-name->oid repository "HEAD"))) |
| 336 | (object->string |
| 337 | `(channel-news |
| 338 | (version 0) |
| 339 | (entry (commit ,(oid->string previous)) |
| 340 | (title (en "New file!") |
| 341 | (eo "Nova dosiero!")) |
| 342 | (body (en "Yeah, a.txt.")))))))) |
| 343 | (commit "third commit") |
| 344 | (add "src/b.txt" "B") |
| 345 | (commit "fourth commit") |
| 346 | (add "news.scm" |
| 347 | ,(lambda (repository) |
| 348 | (let ((second |
| 349 | (commit-id |
| 350 | (find-commit repository "second commit"))) |
| 351 | (previous |
| 352 | (reference-name->oid repository "HEAD"))) |
| 353 | (object->string |
| 354 | `(channel-news |
| 355 | (version 0) |
| 356 | (entry (commit ,(oid->string previous)) |
| 357 | (title (en "Another file!")) |
| 358 | (body (en "Yeah, b.txt."))) |
| 359 | (entry (tag "tag-for-first-news-entry") |
| 360 | (title (en "Old news.") |
| 361 | (eo "Malnovaĵoj.")) |
| 362 | (body (en "For a.txt")))))))) |
| 363 | (commit "fifth commit")) |
| 364 | (with-repository directory repository |
| 365 | (define (find-commit* message) |
| 366 | (oid->string (commit-id (find-commit repository message)))) |
| 367 | |
| 368 | (let ((channel (channel (url (string-append "file://" directory)) |
| 369 | (name 'foo))) |
| 370 | (commit1 (find-commit* "first commit")) |
| 371 | (commit2 (find-commit* "second commit")) |
| 372 | (commit3 (find-commit* "third commit")) |
| 373 | (commit4 (find-commit* "fourth commit")) |
| 374 | (commit5 (find-commit* "fifth commit"))) |
| 375 | ;; First try fetching all the news up to a given commit. |
| 376 | (and (null? (channel-news-for-commit channel commit2)) |
| 377 | (lset= string=? |
| 378 | (map channel-news-entry-commit |
| 379 | (channel-news-for-commit channel commit5)) |
| 380 | (list commit2 commit4)) |
| 381 | (lset= equal? |
| 382 | (map channel-news-entry-title |
| 383 | (channel-news-for-commit channel commit5)) |
| 384 | '((("en" . "Another file!")) |
| 385 | (("en" . "Old news.") ("eo" . "Malnovaĵoj.")))) |
| 386 | (lset= string=? |
| 387 | (map channel-news-entry-commit |
| 388 | (channel-news-for-commit channel commit3)) |
| 389 | (list commit2)) |
| 390 | |
| 391 | ;; Now fetch news entries that apply to a commit range. |
| 392 | (lset= string=? |
| 393 | (map channel-news-entry-commit |
| 394 | (channel-news-for-commit channel commit3 commit1)) |
| 395 | (list commit2)) |
| 396 | (lset= string=? |
| 397 | (map channel-news-entry-commit |
| 398 | (channel-news-for-commit channel commit5 commit3)) |
| 399 | (list commit4)) |
| 400 | (lset= string=? |
| 401 | (map channel-news-entry-commit |
| 402 | (channel-news-for-commit channel commit5 commit1)) |
| 403 | (list commit4 commit2)) |
| 404 | (lset= equal? |
| 405 | (map channel-news-entry-tag |
| 406 | (channel-news-for-commit channel commit5 commit1)) |
| 407 | '(#f "tag-for-first-news-entry"))))))) |
| 408 | |
| 409 | (unless (which (git-command)) (test-skip 1)) |
| 410 | (test-assert "latest-channel-instances, missing introduction for 'guix'" |
| 411 | (with-temporary-git-repository directory |
| 412 | '((add "a.txt" "A") |
| 413 | (commit "first commit") |
| 414 | (add "b.scm" "#t") |
| 415 | (commit "second commit")) |
| 416 | (with-repository directory repository |
| 417 | (let* ((commit1 (find-commit repository "first")) |
| 418 | (commit2 (find-commit repository "second")) |
| 419 | (channel (channel (url (string-append "file://" directory)) |
| 420 | (name 'guix)))) |
| 421 | |
| 422 | (guard (c ((formatted-message? c) |
| 423 | (->bool (string-contains (formatted-message-string c) |
| 424 | "introduction")))) |
| 425 | (with-store store |
| 426 | ;; Attempt a downgrade from NEW to OLD. |
| 427 | (latest-channel-instances store (list channel)) |
| 428 | #f)))))) |
| 429 | |
| 430 | (unless (gpg+git-available?) (test-skip 1)) |
| 431 | (test-equal "authenticate-channel, wrong first commit signer" |
| 432 | #t |
| 433 | (with-fresh-gnupg-setup (list %ed25519-public-key-file |
| 434 | %ed25519-secret-key-file |
| 435 | %ed25519bis-public-key-file |
| 436 | %ed25519bis-secret-key-file) |
| 437 | (with-temporary-git-repository directory |
| 438 | `((add ".guix-channel" |
| 439 | ,(object->string |
| 440 | '(channel (version 0) |
| 441 | (keyring-reference "master")))) |
| 442 | (add ".guix-authorizations" |
| 443 | ,(object->string |
| 444 | `(authorizations (version 0) |
| 445 | ((,(key-fingerprint |
| 446 | %ed25519-public-key-file) |
| 447 | (name "Charlie")))))) |
| 448 | (add "signer.key" ,(call-with-input-file %ed25519-public-key-file |
| 449 | get-string-all)) |
| 450 | (commit "first commit" |
| 451 | (signer ,(key-fingerprint %ed25519-public-key-file))) |
| 452 | (add "random" ,(random-text)) |
| 453 | (commit "second commit" |
| 454 | (signer ,(key-fingerprint %ed25519-public-key-file)))) |
| 455 | (with-repository directory repository |
| 456 | (let* ((commit1 (find-commit repository "first")) |
| 457 | (commit2 (find-commit repository "second")) |
| 458 | (intro (make-channel-introduction |
| 459 | (commit-id-string commit1) |
| 460 | (openpgp-public-key-fingerprint |
| 461 | (read-openpgp-packet |
| 462 | %ed25519bis-public-key-file)))) ;different key |
| 463 | (channel (channel (name 'example) |
| 464 | (url (string-append "file://" directory)) |
| 465 | (introduction intro)))) |
| 466 | (guard (c ((formatted-message? c) |
| 467 | (and (string-contains (formatted-message-string c) |
| 468 | "initial commit") |
| 469 | (equal? (formatted-message-arguments c) |
| 470 | (list |
| 471 | (oid->string (commit-id commit1)) |
| 472 | (key-fingerprint %ed25519-public-key-file) |
| 473 | (key-fingerprint |
| 474 | %ed25519bis-public-key-file)))))) |
| 475 | (authenticate-channel channel directory |
| 476 | (commit-id-string commit2) |
| 477 | #:keyring-reference-prefix "") |
| 478 | 'failed)))))) |
| 479 | |
| 480 | (unless (gpg+git-available?) (test-skip 1)) |
| 481 | (test-equal "authenticate-channel, .guix-authorizations" |
| 482 | #t |
| 483 | (with-fresh-gnupg-setup (list %ed25519-public-key-file |
| 484 | %ed25519-secret-key-file |
| 485 | %ed25519bis-public-key-file |
| 486 | %ed25519bis-secret-key-file) |
| 487 | (with-temporary-git-repository directory |
| 488 | `((add ".guix-channel" |
| 489 | ,(object->string |
| 490 | '(channel (version 0) |
| 491 | (keyring-reference "channel-keyring")))) |
| 492 | (add ".guix-authorizations" |
| 493 | ,(object->string |
| 494 | `(authorizations (version 0) |
| 495 | ((,(key-fingerprint |
| 496 | %ed25519-public-key-file) |
| 497 | (name "Charlie")))))) |
| 498 | (commit "zeroth commit") |
| 499 | (add "a.txt" "A") |
| 500 | (commit "first commit" |
| 501 | (signer ,(key-fingerprint %ed25519-public-key-file))) |
| 502 | (add "b.txt" "B") |
| 503 | (commit "second commit" |
| 504 | (signer ,(key-fingerprint %ed25519-public-key-file))) |
| 505 | (add "c.txt" "C") |
| 506 | (commit "third commit" |
| 507 | (signer ,(key-fingerprint %ed25519bis-public-key-file))) |
| 508 | (branch "channel-keyring") |
| 509 | (checkout "channel-keyring") |
| 510 | (add "signer.key" ,(call-with-input-file %ed25519-public-key-file |
| 511 | get-string-all)) |
| 512 | (add "other.key" ,(call-with-input-file %ed25519bis-public-key-file |
| 513 | get-string-all)) |
| 514 | (commit "keyring commit") |
| 515 | (checkout "master")) |
| 516 | (with-repository directory repository |
| 517 | (let* ((commit1 (find-commit repository "first")) |
| 518 | (commit2 (find-commit repository "second")) |
| 519 | (commit3 (find-commit repository "third")) |
| 520 | (intro (make-channel-introduction |
| 521 | (commit-id-string commit1) |
| 522 | (openpgp-public-key-fingerprint |
| 523 | (read-openpgp-packet |
| 524 | %ed25519-public-key-file)))) |
| 525 | (channel (channel (name 'example) |
| 526 | (url (string-append "file://" directory)) |
| 527 | (introduction intro)))) |
| 528 | ;; COMMIT1 and COMMIT2 are fine. |
| 529 | (and (authenticate-channel channel directory |
| 530 | (commit-id-string commit2) |
| 531 | #:keyring-reference-prefix "") |
| 532 | |
| 533 | ;; COMMIT3 is signed by an unauthorized key according to its |
| 534 | ;; parent's '.guix-authorizations' file. |
| 535 | (guard (c ((unauthorized-commit-error? c) |
| 536 | (and (oid=? (git-authentication-error-commit c) |
| 537 | (commit-id commit3)) |
| 538 | (bytevector=? |
| 539 | (openpgp-public-key-fingerprint |
| 540 | (unauthorized-commit-error-signing-key c)) |
| 541 | (openpgp-public-key-fingerprint |
| 542 | (read-openpgp-packet |
| 543 | %ed25519bis-public-key-file)))))) |
| 544 | (authenticate-channel channel directory |
| 545 | (commit-id-string commit3) |
| 546 | #:keyring-reference-prefix "") |
| 547 | 'failed))))))) |
| 548 | |
| 549 | (unless (gpg+git-available?) (test-skip 1)) |
| 550 | (test-equal "latest-channel-instances, authenticate dependency" |
| 551 | #t |
| 552 | ;; Make sure that a channel dependency that has an introduction is |
| 553 | ;; authenticated. This test checks that an authentication error is raised |
| 554 | ;; as it should when authenticating the dependency. |
| 555 | (with-fresh-gnupg-setup (list %ed25519-public-key-file |
| 556 | %ed25519-secret-key-file) |
| 557 | (with-temporary-git-repository dependency-directory |
| 558 | `((add ".guix-channel" |
| 559 | ,(object->string |
| 560 | '(channel (version 0) |
| 561 | (keyring-reference "master")))) |
| 562 | (add ".guix-authorizations" |
| 563 | ,(object->string |
| 564 | `(authorizations (version 0) ()))) |
| 565 | (add "signer.key" ,(call-with-input-file %ed25519-public-key-file |
| 566 | get-string-all)) |
| 567 | (commit "zeroth commit" |
| 568 | (signer ,(key-fingerprint %ed25519-public-key-file))) |
| 569 | (add "foo.txt" "evil") |
| 570 | (commit "unsigned commit")) |
| 571 | (with-repository dependency-directory dependency |
| 572 | (let* ((commit0 (find-commit dependency "zeroth")) |
| 573 | (commit1 (find-commit dependency "unsigned")) |
| 574 | (intro `(channel-introduction |
| 575 | (version 0) |
| 576 | (commit ,(commit-id-string commit0)) |
| 577 | (signer ,(openpgp-format-fingerprint |
| 578 | (openpgp-public-key-fingerprint |
| 579 | (read-openpgp-packet |
| 580 | %ed25519-public-key-file))))))) |
| 581 | (with-temporary-git-repository directory |
| 582 | `((add ".guix-channel" |
| 583 | ,(object->string |
| 584 | `(channel (version 0) |
| 585 | (dependencies |
| 586 | (channel |
| 587 | (name test-channel) |
| 588 | (url ,dependency-directory) |
| 589 | (introduction ,intro)))))) |
| 590 | (commit "single commit")) |
| 591 | (let ((channel (channel (name 'test) (url directory)))) |
| 592 | (guard (c ((unsigned-commit-error? c) |
| 593 | (oid=? (git-authentication-error-commit c) |
| 594 | (commit-id commit1)))) |
| 595 | (with-store store |
| 596 | (latest-channel-instances store (list channel)) |
| 597 | 'failed))))))))) |
| 598 | |
| 599 | (test-end "channels") |