;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
- #:autoload (gnu packages) (specification->package %package-module-path)
+ #:use-module (gnu packages)
#:autoload (guix download) (download-to-store)
- #:autoload (guix git-download) (git-reference?)
- #:autoload (guix git) (git-checkout?)
+ #:autoload (guix git-download) (git-reference? git-reference-url)
+ #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module ((guix progress) #:select (current-terminal-columns))
#:use-module ((guix build syscalls) #:select (terminal-columns))
(define %default-log-urls
;; Default base URLs for build logs.
- '("http://ci.guix.info/log"))
+ '("http://ci.guix.gnu.org/log"))
;; XXX: The following procedure cannot be in (guix store) because of the
;; dependency on (guix derivations).
(let* ((root (if (string-prefix? "/" root)
root
(string-append (canonicalize-path (dirname root))
- "/" root))))
+ "/" (basename root)))))
(catch 'system-error
(lambda ()
(match paths
(define (replace old url branch)
(package
(inherit old)
- (version (string-append "git." branch))
+ (version (string-append "git." (string-map (match-lambda
+ (#\/ #\-)
+ (chr chr))
+ branch)))
(source (git-checkout (url url) (branch branch)
(recursive? #t)))))
(define (replace old url commit)
(package
(inherit old)
- (version (string-append "git."
- (if (< (string-length commit) 7)
- commit
- (string-take commit 7))))
+ (version (if (and (> (string-length commit) 1)
+ (string-prefix? "v" commit)
+ (char-set-contains? char-set:digit
+ (string-ref commit 1)))
+ (string-drop commit 1) ;looks like a tag like "v1.0"
+ (string-append "git."
+ (if (< (string-length commit) 7)
+ commit
+ (string-take commit 7)))))
(source (git-checkout (url url) (commit commit)
(recursive? #t)))))
(package
(inherit old)
(source (git-checkout (url url)
- (recursive? #t)))))))))
+ (recursive? #t)))))))
+ (_
+ (leave (G_ "~a: invalid Git URL replacement specification~%")
+ spec))))
replacement-specs))
(define rewrite
(display (G_ "
--no-grafts do not graft packages"))
(display (G_ "
- --no-build-hook do not attempt to offload builds via the build hook"))
+ --no-offload do not attempt to offload builds"))
(display (G_ "
--max-silent-time=SECONDS
mark the build as failed after SECONDS of silence"))
(define (set-build-options-from-command-line store opts)
"Given OPTS, an alist as returned by 'args-fold' given
'%standard-build-options', set the corresponding build options on STORE."
- ;; TODO: Add more options.
+
+ ;; '--keep-failed' has no effect when talking to a remote daemon. Catch the
+ ;; case where GUIX_DAEMON_SOCKET=guix://….
+ (when (and (assoc-ref opts 'keep-failed?)
+ (let* ((socket (store-connection-socket store))
+ (peer (catch 'system-error
+ (lambda ()
+ (and (file-port? socket)
+ (getpeername socket)))
+ (const #f))))
+ (and peer (not (= AF_UNIX (sockaddr:fam peer))))))
+ (warning (G_ "'--keep-failed' ignored since you are \
+talking to a remote daemon\n")))
+
(set-build-options store
#:keep-failed? (assoc-ref opts 'keep-failed?)
#:keep-going? (assoc-ref opts 'keep-going?)
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? (assoc-ref opts 'substitutes?)
#:substitute-urls (assoc-ref opts 'substitute-urls)
- #:use-build-hook? (assoc-ref opts 'build-hook?)
+ #:offload? (and (assoc-ref opts 'offload?)
+ (not (assoc-ref opts 'keep-failed?)))
#:max-silent-time (assoc-ref opts 'max-silent-time)
#:timeout (assoc-ref opts 'timeout)
#:print-build-trace (assoc-ref opts 'print-build-trace?)
(alist-cons 'graft? #f
(alist-delete 'graft? result eq?))
rest)))
- (option '("no-build-hook") #f #f
+ (option '("no-offload" "no-build-hook") #f #f
(lambda (opt name arg result . rest)
+ (when (string=? name "no-build-hook")
+ (warning (G_ "'--no-build-hook' is deprecated; \
+use '--no-offload' instead~%")))
+
(apply values
- (alist-cons 'build-hook? #f
- (alist-delete 'build-hook? result))
+ (alist-cons 'offload? #f
+ (alist-delete 'offload? result))
rest)))
(option '("max-silent-time") #t #f
(lambda (opt name arg result . rest)
(define %default-options
;; Alist of default option values.
- `((system . ,(%current-system))
- (build-mode . ,(build-mode normal))
+ `((build-mode . ,(build-mode normal))
(graft? . #t)
(substitutes? . #t)
- (build-hook? . #t)
+ (offload? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
rest)))
(option '(#\s "system") #t #f
(lambda (opt name arg result)
- (alist-cons 'system arg
- (alist-delete 'system result eq?))))
+ (alist-cons 'system arg result)))
(option '("target") #t #f
(lambda (opt name arg result)
(alist-cons 'target arg
(append-map (match-lambda
(('argument . (? string? spec))
(cond ((derivation-path? spec)
- (list (read-derivation-from-file spec)))
+ (catch 'system-error
+ (lambda ()
+ (list (read-derivation-from-file spec)))
+ (lambda args
+ ;; Non-existent .drv files can be substituted down
+ ;; the road, so don't error out.
+ (if (= ENOENT (system-error-errno args))
+ '()
+ (apply throw args)))))
((store-path? spec)
;; Nothing to do; maybe for --log-file.
'())
(cut package-cross-derivation <> <> triplet <>))))
(define src (assoc-ref opts 'source))
- (define system (assoc-ref opts 'system))
(define graft? (assoc-ref opts 'graft?))
+ (define systems
+ (match (filter-map (match-lambda
+ (('system . system) system)
+ (_ #f))
+ opts)
+ (() (list (%current-system)))
+ (systems systems)))
+
+ (define things-to-build
+ (map (cut transform store <>)
+ (options->things-to-build opts)))
+
+ (define (compute-derivation obj system)
+ ;; Compute the derivation of OBJ for SYSTEM.
+ (match obj
+ ((? package? p)
+ (let ((p (or (and graft? (package-replacement p)) p)))
+ (match src
+ (#f
+ (list (package->derivation store p system)))
+ (#t
+ (match (package-source p)
+ (#f
+ (warning (package-location p)
+ (G_ "package '~a' has no source~%")
+ (package-name p))
+ '())
+ (s
+ (list (package-source-derivation store s)))))
+ (proc
+ (map (cut package-source-derivation store <>)
+ (proc p))))))
+ ((? derivation? drv)
+ (list drv))
+ ((? procedure? proc)
+ (list (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (proc))
+ #:system system)))
+ ((? file-like? obj)
+ (list (run-with-store store
+ (lower-object obj system
+ #:target (assoc-ref opts 'target))
+ #:system system)))
+ ((? gexp? gexp)
+ (list (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (gexp->derivation "gexp" gexp
+ #:system system))
+ #:system system)))))
;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
;; of user packages. Since 'guix build' is the primary tool for people
;; testing new packages, report such errors gracefully.
(with-unbound-variable-handling
(parameterize ((%graft? graft?))
- (append-map (match-lambda
- ((? package? p)
- (let ((p (or (and graft? (package-replacement p)) p)))
- (match src
- (#f
- (list (package->derivation store p system)))
- (#t
- (match (package-source p)
- (#f
- (format (current-error-port)
- (G_ "~a: warning: \
-package '~a' has no source~%")
- (location->string (package-location p))
- (package-name p))
- '())
- (s
- (list (package-source-derivation store s)))))
- (proc
- (map (cut package-source-derivation store <>)
- (proc p))))))
- ((? derivation? drv)
- (list drv))
- ((? procedure? proc)
- (list (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (proc))
- #:system system)))
- ((? file-like? obj)
- (list (run-with-store store
- (lower-object obj system
- #:target (assoc-ref opts 'target))
- #:system system)))
- ((? gexp? gexp)
- (list (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (gexp->derivation "gexp" gexp
- #:system system))
- #:system system))))
- (map (cut transform store <>)
- (options->things-to-build opts))))))
+ (append-map (lambda (system)
+ (append-map (cut compute-derivation <> system)
+ things-to-build))
+ systems))))
(define (show-build-log store file urls)
"Show the build log for FILE, falling back to remote logs from URLS if
'())))
(items (filter-map (match-lambda
(('argument . (? store-path? file))
- file)
+ ;; If FILE is a .drv that's not in
+ ;; store, keep it so that it can be
+ ;; substituted.
+ (and (or (not (derivation-path? file))
+ (not (file-exists? file)))
+ file))
(_ #f))
opts))
(roots (filter-map (match-lambda
#:mode mode))
(cond ((assoc-ref opts 'log-file?)
+ ;; Pass 'show-build-log' the output file names, not the
+ ;; derivation file names, because there can be several
+ ;; derivations leading to the same output.
(for-each (cut show-build-log store <> urls)
(delete-duplicates
- (append (map derivation-file-name drv)
+ (append (map derivation->output-path drv)
items))))
((assoc-ref opts 'derivations-only?)
(format #t "~{~a~%~}" (map derivation-file-name drv))
(map (compose list derivation-file-name) drv)
roots))
((not (assoc-ref opts 'dry-run?))
- (and (build-derivations store drv mode)
+ (and (build-derivations store (append drv items)
+ mode)
(for-each show-derivation-outputs drv)
(for-each (cut register-root store <> <>)
(map (lambda (drv)
HCoop / jackhill / guix / guix.git / blobdiff