summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build/lisp-utils.scm63
-rw-r--r--guix/channels.scm16
-rw-r--r--guix/git-download.scm36
-rw-r--r--guix/git.scm3
-rw-r--r--guix/gnupg.scm58
-rw-r--r--guix/scripts/describe.scm6
-rw-r--r--guix/scripts/graph.scm12
-rw-r--r--guix/scripts/pull.scm35
-rw-r--r--guix/scripts/refresh.scm13
-rw-r--r--guix/store.scm3
10 files changed, 160 insertions, 85 deletions
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 21cb620d59..6470cfec97 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -81,6 +81,20 @@
"Replace invalid characters in STR with a hyphen."
(string-join (string-tokenize str valid-char-set) "-"))
+(define (normalize-dependency dependency)
+ "Normalize the name of DEPENDENCY. Handles dependency definitions of the
+dependency-def form described by
+<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>."
+ (match dependency
+ ((':version name rest ...)
+ `(:version ,(normalize-string name) ,@rest))
+ ((':feature feature-specification dependency-specification)
+ `(:feature
+ ,feature-specification
+ ,(normalize-dependency dependency-specification)))
+ ((? string? name) (normalize-string name))
+ (require-specification require-specification)))
+
(define (inputs->asd-file-map inputs)
"Produce a hash table of the form (system . asd-file), where system is the
name of an ASD system, and asd-file is the full path to its definition."
@@ -105,9 +119,9 @@ name of an ASD system, and asd-file is the full path to its definition."
(define (lisp-eval-program program)
"Evaluate PROGRAM with a given LISP implementation."
- (unless (zero? (apply system*
- (lisp-invocation program)))
- (error "lisp-eval-program failed!" (%lisp) program)))
+ (define invocation (lisp-invocation program))
+ (format #t "Invoking ~a: ~{~s ~}~%" (%lisp-type) invocation)
+ (apply invoke invocation))
(define (spread-statements program argument-name)
"Return a list with the statements from PROGRAM spread between
@@ -138,8 +152,7 @@ with PROGRAM."
first."
(lisp-eval-program
`((require :asdf)
- (let ((*package* (find-package :asdf)))
- (load ,asd-file))
+ (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
(asdf:operate 'asdf:compile-bundle-op ,system))))
(define (system-dependencies system asd-file)
@@ -148,8 +161,7 @@ asdf:system-depends-on. First load the system's ASD-FILE."
(define deps-file ".deps.sexp")
(define program
`((require :asdf)
- (let ((*package* (find-package :asdf)))
- (load ,asd-file))
+ (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
(with-open-file
(stream ,deps-file :direction :output)
(format stream
@@ -189,19 +201,18 @@ asdf:system-depends-on. First load the system's ASD-FILE."
Also load TEST-ASD-FILE if necessary."
(lisp-eval-program
`((require :asdf)
- (let ((*package* (find-package :asdf)))
- (load ,asd-file)
- ,@(if test-asd-file
- `((load ,test-asd-file))
- ;; Try some likely files.
- (map (lambda (file)
- `(when (uiop:file-exists-p ,file)
- (load ,file)))
- (list
- (string-append system "-tests.asd")
- (string-append system "-test.asd")
- "tests.asd"
- "test.asd"))))
+ (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
+ ,@(if test-asd-file
+ `((asdf:load-asd (truename ,test-asd-file)))
+ ;; Try some likely files.
+ (map (lambda (file)
+ `(when (uiop:file-exists-p ,file)
+ (asdf:load-asd (truename ,file))))
+ (list
+ (string-append system "-tests.asd")
+ (string-append system "-test.asd")
+ "tests.asd"
+ "test.asd")))
(asdf:test-system ,system))))
(define (string->lisp-keyword . strings)
@@ -273,16 +284,24 @@ system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
(system-dependencies system system-asd-file)))
(if (eq? 'NIL deps)
'()
- (map normalize-string deps))))
+ (map normalize-dependency deps))))
(define lisp-input-map
(inputs->asd-file-map inputs))
+ (define dependency-name
+ (match-lambda
+ ((':version name _ ...) name)
+ ((':feature _ dependency-specification)
+ (dependency-name dependency-specification))
+ ((? string? name) name)
+ (_ #f)))
+
(define registry
(filter-map hash-get-handle
(make-list (length dependencies)
lisp-input-map)
- dependencies))
+ (map dependency-name dependencies)))
(call-with-output-file asd-file
(lambda (port)
diff --git a/guix/channels.scm b/guix/channels.scm
index cf833db8b9..2e7bffae9f 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -207,10 +207,16 @@ INSTANCES."
(guix-channel? (channel-instance-channel instance)))
instances))
- ;; Guile-Gcrypt is a dependency of CORE-INSTANCE.
- (define guile-gcrypt
- (module-ref (resolve-interface '(gnu packages gnupg))
- 'guile-gcrypt))
+ (define dependencies
+ ;; Dependencies of CORE-INSTANCE.
+ ;; FIXME: It would be best not to hard-wire this information here and
+ ;; instead query it to CORE-INSTANCE.
+ (list (module-ref (resolve-interface '(gnu packages gnupg))
+ 'guile-gcrypt)
+ (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-git)
+ (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-bytestructures)))
(mlet %store-monad ((core (build-channel-instance core-instance)))
(mapm %store-monad
@@ -218,7 +224,7 @@ INSTANCES."
(if (eq? instance core-instance)
(return core)
(build-channel-instance instance
- (list core guile-gcrypt))))
+ (cons core dependencies))))
instances)))
(define (whole-package-for-legacy name modules)
diff --git a/guix/git-download.scm b/guix/git-download.scm
index e6e0ec2ac5..24cf11be5e 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -179,24 +179,28 @@ are relative to DIRECTORY, which is not necessarily the root of the checkout."
(define (git-predicate directory)
"Return a predicate that returns true if a file is part of the Git checkout
-living at DIRECTORY. Upon Git failure, return #f instead of a predicate.
+living at DIRECTORY. If DIRECTORY does not lie within a Git checkout, and
+upon Git errors, return #f instead of a predicate.
The returned predicate takes two arguments FILE and STAT where FILE is an
absolute file name and STAT is the result of 'lstat'."
- (let* ((files (git-file-list directory))
- (inodes (fold (lambda (file result)
- (let ((stat
- (lstat (string-append directory "/"
- file))))
- (vhash-consv (stat:ino stat) (stat:dev stat)
- result)))
- vlist-null
- files)))
- (lambda (file stat)
- ;; Comparing file names is always tricky business so we rely on inode
- ;; numbers instead.
- (match (vhash-assv (stat:ino stat) inodes)
- ((_ . dev) (= dev (stat:dev stat)))
- (#f #f)))))
+ (catch 'git-error
+ (lambda ()
+ (let* ((files (git-file-list directory))
+ (inodes (fold (lambda (file result)
+ (let ((stat
+ (lstat (string-append directory "/"
+ file))))
+ (vhash-consv (stat:ino stat) (stat:dev stat)
+ result)))
+ vlist-null
+ files)))
+ (lambda (file stat)
+ ;; Comparing file names is always tricky business so we rely on inode
+ ;; numbers instead.
+ (match (vhash-assv (stat:ino stat) inodes)
+ ((_ . dev) (= dev (stat:dev stat)))
+ (#f #f)))))
+ (const #f)))
;;; git-download.scm ends here
diff --git a/guix/git.scm b/guix/git.scm
index 3d0eb93d9b..d007916662 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -36,7 +36,8 @@
latest-repository-commit))
(define %repository-cache-directory
- (make-parameter "/var/cache/guix/checkouts"))
+ (make-parameter (string-append (cache-directory #:ensure? #f)
+ "/checkouts")))
(define-syntax-rule (with-libgit2 thunk ...)
(begin
diff --git a/guix/gnupg.scm b/guix/gnupg.scm
index ac0ed5ab2d..b30ce461b4 100644
--- a/guix/gnupg.scm
+++ b/guix/gnupg.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
@@ -24,9 +24,12 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 i18n)
#:use-module (srfi srfi-1)
- #:use-module (guix ui)
+ #:use-module (guix i18n)
+ #:use-module ((guix utils) #:select (config-directory))
+ #:use-module ((guix build utils) #:select (mkdir-p))
#:export (%gpg-command
%openpgp-key-server
+ current-keyring
gnupg-verify
gnupg-verify*
gnupg-status-good-signature?
@@ -42,13 +45,25 @@
;; The GnuPG 2.x command-line program name.
(make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))
+(define %gpgv-command
+ ;; The 'gpgv' program.
+ (make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv")))
+
+(define current-keyring
+ ;; The default keyring of "trusted keys".
+ (make-parameter (string-append (config-directory #:ensure? #f)
+ "/gpg/trustedkeys.kbx")))
+
(define %openpgp-key-server
;; The default key server. Note that keys.gnupg.net appears to be
;; unreliable.
(make-parameter "pgp.mit.edu"))
-(define (gnupg-verify sig file)
- "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed."
+(define* (gnupg-verify sig file
+ #:optional (keyring (current-keyring)))
+ "Verify signature SIG for FILE against the keys in KEYRING. All the keys in
+KEYRING as assumed to be \"trusted\", whether or not they expired or were
+revoked. Return a status s-exp if GnuPG failed."
(define (status-line->sexp line)
;; See file `doc/DETAILS' in GnuPG.
@@ -117,8 +132,8 @@
(loop (read-line input)
(cons (status-line->sexp line) result)))))
- (let* ((pipe (open-pipe* OPEN_READ (%gpg-command) "--status-fd=1"
- "--verify" sig file))
+ (let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
+ "--keyring" keyring sig file))
(status (parse-status pipe)))
;; Ignore PIPE's exit status since STATUS above should contain all the
;; info we need.
@@ -145,12 +160,21 @@ missing key."
(_ #f)))
status))
-(define (gnupg-receive-keys key-id server)
- (system* (%gpg-command) "--keyserver" server "--recv-keys" key-id))
+(define* (gnupg-receive-keys key-id server
+ #:optional (keyring (current-keyring)))
+ (unless (file-exists? keyring)
+ (mkdir-p (dirname keyring))
+ (call-with-output-file keyring (const #t))) ;create an empty keybox
+
+ (system* (%gpg-command) "--keyserver" server
+ "--no-default-keyring" "--keyring" keyring
+ "--recv-keys" key-id))
(define* (gnupg-verify* sig file
- #:key (key-download 'interactive)
- (server (%openpgp-key-server)))
+ #:key
+ (key-download 'interactive)
+ (server (%openpgp-key-server))
+ (keyring (current-keyring)))
"Like `gnupg-verify', but try downloading the public key if it's missing.
Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a
download policy for missing OpenPGP keys; allowed values: 'always', 'never',
@@ -161,15 +185,17 @@ and 'interactive' (default)."
(define (download-and-try-again)
;; Download the missing key and try again.
(begin
- (gnupg-receive-keys missing server)
- (gnupg-status-good-signature? (gnupg-verify sig file))))
+ (gnupg-receive-keys missing server keyring)
+ (gnupg-status-good-signature? (gnupg-verify sig file
+ keyring))))
(define (receive?)
(let ((answer
- (begin (format #t (G_ "~a~a~%")
- "Would you like to download this key "
- "and add it to your keyring?")
- (read-line))))
+ (begin
+ (format #t (G_ "Would you like to add this key \
+to keyring '~a'?~%")
+ keyring)
+ (read-line))))
(string-match (locale-yes-regexp) answer)))
(and missing
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index fdff07d0e3..c1a20fe26c 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -134,8 +134,10 @@ in the format specified by FMT."
;; Show most recently installed packages last.
(reverse
(manifest-entries
- (profile-manifest (generation-file-name profile
- number)))))))))
+ (profile-manifest
+ (if (zero? number)
+ profile
+ (generation-file-name profile number))))))))))
(display-package-search-path fmt))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 346ca4ea88..145a574dba 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -439,6 +439,10 @@ package modules, while attempting to retain user package modules."
(option '(#\e "expression") #t #f
(lambda (opt name arg result)
(alist-cons 'expression arg result)))
+ (option '(#\s "system") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'system arg
+ (alist-delete 'system result eq?))))
(option '(#\h "help") #f #f
(lambda args
(show-help)
@@ -462,6 +466,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
--list-types list the available graph types"))
(display (G_ "
-e, --expression=EXPR consider the package EXPR evaluates to"))
+ (display (G_ "
+ -s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\""))
(newline)
(display (G_ "
-h, --help display this help and exit"))
@@ -472,7 +478,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(define %default-options
`((node-type . ,%package-node-type)
- (backend . ,%graphviz-backend)))
+ (backend . ,%graphviz-backend)
+ (system . ,(%current-system))))
;;;
@@ -508,7 +515,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(export-graph (concatenate nodes)
(current-output-port)
#:node-type type
- #:backend backend)))))))
+ #:backend backend))
+ #:system (assq-ref opts 'system))))))
#t)
;;; graph.scm ends here
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 976e054a84..10e1a99e54 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -176,17 +176,18 @@ Download and deploy the latest version of Guix.\n"))
(certs (string-append (derivation->output-path drv)
"/etc/ssl/certs")))
(build-derivations store (list drv))
-
- ;; In the past Guile-Git would not provide this procedure.
- (if (module-defined? (resolve-interface '(git))
- 'set-tls-certificate-locations!)
- (set-tls-certificate-locations! certs)
- (begin
- ;; In this case we end up using whichever certificates OpenSSL
- ;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs.
- (warning (G_ "cannot enforce use of the Let's Encrypt \
-certificates~%"))
- (warning (G_ "please upgrade Guile-Git~%"))))))
+ (set-tls-certificate-locations! certs)))
+
+(define (honor-x509-certificates store)
+ "Use the right X.509 certificates for Git checkouts over HTTPS."
+ (let ((file (getenv "SSL_CERT_FILE"))
+ (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
+ (if (or (and file (file-exists? file))
+ (and=> (stat directory #f)
+ (lambda (st)
+ (> (stat:nlink st) 2))))
+ (set-tls-certificate-locations! directory file)
+ (honor-lets-encrypt-certificates! store))))
(define (report-git-error error)
"Report the given Guile-Git error."
@@ -233,7 +234,9 @@ way and displaying details about the channel's source code."
;; Show most recently installed packages last.
(reverse
(manifest-entries
- (profile-manifest (generation-file-name profile number))))))
+ (profile-manifest (if (zero? number)
+ profile
+ (generation-file-name profile number)))))))
(define (indented-string str indent)
"Return STR with each newline preceded by IDENT spaces."
@@ -431,13 +434,7 @@ Use '~/.config/guix/channels.scm' instead."))
(parameterize ((%graft? (assoc-ref opts 'graft?))
(%repository-cache-directory cache))
(set-build-options-from-command-line store opts)
-
- ;; When certificates are already installed, use them.
- ;; Otherwise, use the Let's Encrypt certificates, which we
- ;; know Savannah uses.
- (let ((certs (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
- (unless (file-exists? certs)
- (honor-lets-encrypt-certificates! store)))
+ (honor-x509-certificates store)
(let ((instances (latest-channel-instances store channels)))
(format (current-error-port)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index bcc23bd39c..58fc64db1f 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
@@ -89,6 +89,9 @@
(lambda (opt name arg result)
(alist-cons 'list-dependent? #t result)))
+ (option '("keyring") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'keyring arg result)))
(option '("key-server") #t #f
(lambda (opt name arg result)
(alist-cons 'key-server arg result)))
@@ -139,6 +142,8 @@ specified with `--select'.\n"))
be rebuilt as a result of upgrading PACKAGE..."))
(newline)
(display (G_ "
+ --keyring=FILE use FILE as the keyring of upstream OpenPGP keys"))
+ (display (G_ "
--key-server=HOST use HOST as the OpenPGP key server"))
(display (G_ "
--gpg=COMMAND use COMMAND as the GnuPG 2.x command"))
@@ -437,7 +442,11 @@ update would trigger a complete rebuild."
(%openpgp-key-server)))
(%gpg-command
(or (assoc-ref opts 'gpg-command)
- (%gpg-command))))
+ (%gpg-command)))
+ (current-keyring
+ (or (assoc-ref opts 'keyring)
+ (string-append (config-directory)
+ "/upstream/trustedkeys.kbx"))))
(for-each
(cut update-package store <> updaters
#:key-download key-download
diff --git a/guix/store.scm b/guix/store.scm
index af7f6980cf..f88cdefe87 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -770,6 +770,7 @@ bytevector) as its internal buffer, and a thunk to flush this output port."
(define (flush)
(put-bytevector port buffer 0 total)
+ (force-output port)
(set! total 0))
(define (write bv offset count)
@@ -927,6 +928,7 @@ path."
(write-int (if recursive? 1 0) port)
(write-string hash-algo port)
(write-file file-name port #:select? select?)
+ (write-buffered-output server)
(let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server))))
(read-store-path port)))))
@@ -1042,6 +1044,7 @@ an arbitrary directory layout in the store without creating a derivation."
#:file-port file-port
#:symlink-target symlink-target
#:directory-entries directory-entries)
+ (write-buffered-output server)
(let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server))))
(let ((result (read-store-path port)))
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-11 06:51:36 +0000