index
:
guix
koszko
koszko-scripts
about
about
summary
refs
log
tree
commit
diff
;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014-2015, 2017-2019, 2021-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (test-substitute) #:use-module (guix scripts substitute) #:use-module (guix narinfo) #:use-module (guix base64) #:use-module (gcrypt hash) #:use-module (guix serialization) #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module (guix config) #:use-module (guix base32) #:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix ui) #:select (guix-warning-port)) #:use-module ((guix utils) #:select (call-with-temporary-directory call-with-compressed-output-port)) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively dump-port)) #:use-module (guix tests http) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (web uri) #:use-module (ice-9 regex) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module ((srfi srfi-64) #:hide (test-error))) (define-syntax-rule (test-quit name error-rx exp) "Emit a test that passes when EXP throws to 'quit' with value 1, and when it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX." (test-equal name '(1 #t) (let ((error-output (open-output-string))) (parameterize ((current-error-port error-output) (guix-warning-port error-output)) (catch 'quit (lambda () exp #f) (lambda (key value) (list value (let ((message (get-output-string error-output))) (->bool (string-match error-rx message)))))))))) (define (request-substitution item destination) "Run 'guix substitute --substitute' to fetch ITEM to DESTINATION." (false-if-exception (delete-file destination)) (with-input-from-string (string-append "substitute " item " " destination "\n") (lambda () (guix-substitute "--substitute")))) (define %public-key ;; This key is known to be in the ACL by default. (call-with-input-file (string-append %config-directory "/signing-key.pub") (compose string->canonical-sexp get-string-all))) (define %private-key (call-with-input-file (string-append %config-directory "/signing-key.sec") (compose string->canonical-sexp get-string-all))) (define* (signature-body bv #:key (public-key %public-key)) "Return the signature of BV as the base64-encoded body of a narinfo's 'Signature' field." (base64-encode (string->utf8 (canonical-sexp->string (signature-sexp (bytevector->hash-data (sha256 bv) #:key-type 'rsa) %private-key public-key))))) (define %wrong-public-key (string->canonical-sexp "(public-key (rsa (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#) (e #010001#) ) )")) (define* (signature-field bv-or-str #:key (version "1") (public-key %public-key)) "Return the 'Signature' field value of bytevector/string BV-OR-STR, using PUBLIC-KEY as the signature's principal, and using VERSION as the signature version identifier.." (string-append version ";example.gnu.org;" (signature-body (if (string? bv-or-str) (string->utf8 bv-or-str) bv-or-str) #:public-k
