diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/dune-build-system.scm | 4 | ||||
| -rw-r--r-- | guix/config.scm.in | 6 | ||||
| -rw-r--r-- | guix/gexp.scm | 15 | ||||
| -rw-r--r-- | guix/git.scm | 136 | ||||
| -rw-r--r-- | guix/import/opam.scm | 46 | ||||
| -rw-r--r-- | guix/monads.scm | 15 | ||||
| -rw-r--r-- | guix/profiles.scm | 59 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 26 | ||||
| -rw-r--r-- | guix/self.scm | 18 | ||||
| -rw-r--r-- | guix/status.scm | 87 | ||||
| -rw-r--r-- | guix/store.scm | 5 | ||||
| -rw-r--r-- | guix/ui.scm | 8 |
14 files changed, 325 insertions, 107 deletions
diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index fcc2d6567d..00b0c7c406 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2019 Gabriel Hondet <gabrielhondet@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,7 +50,8 @@ "Install the given package." (let ((out (assoc-ref outputs "out")) (program (if jbuild? "jbuilder" "dune"))) - (invoke program install-target "--prefix" out)) + (invoke program install-target "--prefix" out "--libdir" + (string-append out "/lib/ocaml/site-lib"))) #t) (define %standard-phases diff --git a/guix/config.scm.in b/guix/config.scm.in index 1a761b912e..d2ec9921c6 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> ;;; ;;; This file is part of GNU Guix. @@ -73,11 +73,11 @@ (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") + (or (getenv "GUIX_STATE_DIRECTORY") (string-append %localstatedir "/guix"))) (define %store-database-directory - (or (getenv "NIX_DB_DIR") + (or (getenv "GUIX_DATABASE_DIRECTORY") (string-append %state-directory "/db"))) (define %config-directory diff --git a/guix/gexp.scm b/guix/gexp.scm index f7c064297b..5b5b064b59 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -920,7 +920,18 @@ and in the current monad setting (system type, etc.)" (simple-format #f "~a:~a" line column))) "<unknown location>"))) -(define-syntax-parameter current-imported-modules +(define-syntax-rule (define-syntax-parameter-once name proc) + ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME + ;; does not get redefined. This works around a race condition in a + ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>. + (eval-when (load eval expand compile) + (define name + (if (module-locally-bound? (current-module) 'name) + (module-ref (current-module) 'name) + (make-syntax-transformer 'name 'syntax-parameter + (list proc)))))) + +(define-syntax-parameter-once current-imported-modules ;; Current list of imported modules. (identifier-syntax '())) @@ -931,7 +942,7 @@ environment." (identifier-syntax modules))) body ...)) -(define-syntax-parameter current-imported-extensions +(define-syntax-parameter-once current-imported-extensions ;; Current list of extensions. (identifier-syntax '())) diff --git a/guix/git.scm b/guix/git.scm index 0666f0c0a9..0e3ce37e26 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +35,8 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (%repository-cache-directory + honor-system-x509-certificates! + update-cached-checkout latest-repository-commit @@ -43,25 +45,70 @@ git-checkout-url git-checkout-branch)) +;; XXX: Use this hack instead of #:autoload to avoid compilation errors. +;; See <http://bugs.gnu.org/12202>. +(module-autoload! (current-module) + '(git submodule) '(repository-submodules)) + (define %repository-cache-directory (make-parameter (string-append (cache-directory #:ensure? #f) "/checkouts"))) +(define (honor-system-x509-certificates!) + "Use the system's X.509 certificates for Git checkouts over HTTPS. Honor +the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." + ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of + ;; files (instead of all the certificates) among which "ca-bundle.crt". On + ;; other distros /etc/ssl/certs usually contains the whole set of + ;; certificates along with "ca-certificates.crt". Try to choose the right + ;; one. + (let ((file (letrec-syntax ((choose + (syntax-rules () + ((_ file rest ...) + (let ((f file)) + (if (and f (file-exists? f)) + f + (choose rest ...)))) + ((_) + #f)))) + (choose (getenv "SSL_CERT_FILE") + "/etc/ssl/certs/ca-certificates.crt" + "/etc/ssl/certs/ca-bundle.crt"))) + (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) + (and (or file + (and=> (stat directory #f) + (lambda (st) + (> (stat:nlink st) 2)))) + (begin + (set-tls-certificate-locations! directory file) + #t)))) + +(define %certificates-initialized? + ;; Whether 'honor-system-x509-certificates!' has already been called. + #f) + (define-syntax-rule (with-libgit2 thunk ...) (begin ;; XXX: The right thing to do would be to call (libgit2-shutdown) here, ;; but pointer finalizers used in guile-git may be called after shutdown, ;; resulting in a segfault. Hence, let's skip shutdown call for now. (libgit2-init!) + (unless %certificates-initialized? + (honor-system-x509-certificates!) + (set! %certificates-initialized? #t)) thunk ...)) (define* (url-cache-directory url #:optional (cache-directory - (%repository-cache-directory))) + (%repository-cache-directory)) + #:key recursive?) "Return the directory associated to URL in %repository-cache-directory." (string-append cache-directory "/" - (bytevector->base32-string (sha256 (string->utf8 url))))) + (bytevector->base32-string + (sha256 (string->utf8 (if recursive? + (string-append "R:" url) + url)))))) (define (clone* url directory) "Clone git repository at URL into DIRECTORY. Upon failure, @@ -119,18 +166,62 @@ OID (roughly the commit hash) corresponding to REF." (reset repository obj RESET_HARD) (object-id obj)) +(define (call-with-repository directory proc) + (let ((repository #f)) + (dynamic-wind + (lambda () + (set! repository (repository-open directory))) + (lambda () + (proc repository)) + (lambda () + (repository-close! repository))))) + +(define-syntax-rule (with-repository directory repository exp ...) + "Open the repository at DIRECTORY and bind REPOSITORY to it within the +dynamic extent of EXP." + (call-with-repository directory + (lambda (repository) exp ...))) + +(define* (update-submodules repository + #:key (log-port (current-error-port))) + "Update the submodules of REPOSITORY, a Git repository object." + ;; Guile-Git < 0.2.0 did not have (git submodule). + (if (false-if-exception (resolve-interface '(git submodule))) + (for-each (lambda (name) + (let ((submodule (submodule-lookup repository name))) + (format log-port (G_ "updating submodule '~a'...~%") + name) + (submodule-update submodule) + + ;; Recurse in SUBMODULE. + (let ((directory (string-append + (repository-working-directory repository) + "/" (submodule-path submodule)))) + (with-repository directory repository + (update-submodules repository + #:log-port log-port))))) + (repository-submodules repository)) + (format (current-error-port) + (G_ "Support for submodules is missing; \ +please upgrade Guile-Git.~%")))) + (define* (update-cached-checkout url #:key (ref '(branch . "master")) + recursive? + (log-port (%make-void-port "w")) (cache-directory (url-cache-directory - url (%repository-cache-directory)))) + url (%repository-cache-directory) + #:recursive? recursive?))) "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two values: the cache directory name, and the SHA1 commit (a string) corresponding to REF. REF is pair whose key is [branch | commit | tag] and value the associated -data, respectively [<branch name> | <sha1> | <tag name>]." +data, respectively [<branch name> | <sha1> | <tag name>]. + +When RECURSIVE? is true, check out submodules as well, if any." (define canonical-ref ;; We used to require callers to specify "origin/" for each branch, which ;; made little sense since the cache should be transparent to them. So @@ -150,6 +241,8 @@ data, respectively [<branch name> | <sha1> | <tag name>]." ;; Only fetch remote if it has not been cloned just before. (when cache-exists? (remote-fetch (remote-lookup repository "origin"))) + (when recursive? + (update-submodules repository #:log-port log-port)) (let ((oid (switch-to-ref repository canonical-ref))) ;; Reclaim file descriptors and memory mappings associated with @@ -162,6 +255,7 @@ data, respectively [<branch name> | <sha1> | <tag name>]." (define* (latest-repository-commit store url #:key + recursive? (log-port (%make-void-port "w")) (cache-directory (%repository-cache-directory)) @@ -172,21 +266,33 @@ reference to be checkout, once the repository is fetched, is specified by REF. REF is pair whose key is [branch | commit | tag] and value the associated data, respectively [<branch name> | <sha1> | <tag name>]. +When RECURSIVE? is true, check out submodules as well, if any. + Git repositories are kept in the cache directory specified by %repository-cache-directory parameter. Log progress and checkout info to LOG-PORT." (define (dot-git? file stat) (and (string=? (basename file) ".git") - (eq? 'directory (stat:type stat)))) + (or (eq? 'directory (stat:type stat)) + + ;; Submodule checkouts end up with a '.git' regular file that + ;; contains metadata about where their actual '.git' directory + ;; lives. + (and recursive? + (eq? 'regular (stat:type stat)))))) (format log-port "updating checkout of '~a'...~%" url) (let*-values (((checkout commit) (update-cached-checkout url + #:recursive? recursive? #:ref ref #:cache-directory - (url-cache-directory url cache-directory))) + (url-cache-directory url cache-directory + #:recursive? + recursive?) + #:log-port log-port)) ((name) (url+commit->name url commit))) (format log-port "retrieved commit ~a~%" commit) @@ -205,9 +311,10 @@ Log progress and checkout info to LOG-PORT." git-checkout? (url git-checkout-url) (branch git-checkout-branch (default "master")) - (commit git-checkout-commit (default #f))) + (commit git-checkout-commit (default #f)) + (recursive? git-checkout-recursive? (default #f))) -(define* (latest-repository-commit* url #:key ref log-port) +(define* (latest-repository-commit* url #:key ref recursive? log-port) ;; Monadic variant of 'latest-repository-commit'. (lambda (store) ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so @@ -216,7 +323,9 @@ Log progress and checkout info to LOG-PORT." (catch 'git-error (lambda () (values (latest-repository-commit store url - #:ref ref #:log-port log-port) + #:ref ref + #:recursive? recursive? + #:log-port log-port) store)) (lambda (key error . _) (raise (condition @@ -238,9 +347,14 @@ Log progress and checkout info to LOG-PORT." ;; "Compile" CHECKOUT by updating the local checkout and adding it to the ;; store. (match checkout - (($ <git-checkout> url branch commit) + (($ <git-checkout> url branch commit recursive?) (latest-repository-commit* url #:ref (if commit `(commit . ,commit) `(branch . ,branch)) + #:recursive? recursive? #:log-port (current-error-port))))) + +;; Local Variables: +;; eval: (put 'with-repository 'scheme-indent-function 2) +;; End: diff --git a/guix/import/opam.scm b/guix/import/opam.scm index c254db5f2c..7b2e832e92 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -1,4 +1,3 @@ -;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; ;;; This file is part of GNU Guix. @@ -90,8 +89,8 @@ (define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string)) (define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form)) (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form)) -(define-peg-pattern condition-eq all (and condition-content (* SP) (ignore "=") (* SP) condition-content)) -(define-peg-pattern condition-neq all (and condition-content (* SP) (ignore (and "!" "=")) (* SP) condition-content)) +(define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content)) +(define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content)) (define-peg-pattern condition-content body (or condition-string condition-var)) (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!")))) (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE)) @@ -117,7 +116,11 @@ path to the repository." (lambda (dir) (string-join (cdr (string-split dir #\.)) ".")) versions))) - (latest-version versions)) + ;; Workaround for janestreet re-versionning + (let ((v-versions (filter (lambda (version) (string-prefix? "v" version)) versions))) + (if (null? v-versions) + (latest-version versions) + (string-append "v" (latest-version (map (lambda (version) (substring version 1)) v-versions)))))) (begin (format #t (G_ "Package not found in opam repository: ~a~%") package) #f)))) @@ -127,12 +130,17 @@ path to the repository." (lambda _ (peg:tree (match-pattern records (get-string-all (current-input-port))))))) +(define (substitute-char str what with) + (string-join (string-split str what) with)) + (define (ocaml-name->guix-name name) - (cond - ((equal? name "ocamlfind") "ocaml-findlib") - ((string-prefix? "ocaml" name) name) - ((string-prefix? "conf-" name) (substring name 5)) - (else (string-append "ocaml-" name)))) + (substitute-char + (cond + ((equal? name "ocamlfind") "ocaml-findlib") + ((string-prefix? "ocaml" name) name) + ((string-prefix? "conf-" name) (substring name 5)) + (else (string-append "ocaml-" name))) + #\_ "-")) (define (metadata-ref file lookup) (fold (lambda (record acc) @@ -234,7 +242,9 @@ path to the repository." (values `(package (name ,(ocaml-name->guix-name name)) - (version ,version) + (version ,(if (string-prefix? "v" version) + (substring version 1) + version)) (source (origin (method url-fetch) @@ -247,6 +257,10 @@ path to the repository." ,@(if (null? native-inputs) '() `((native-inputs ,(list 'quasiquote native-inputs)))) + ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) + '() + `((properties + ,(list 'quasiquote `((upstream-name . ,name)))))) (home-page ,(metadata-ref opam-content "homepage")) (synopsis ,(metadata-ref opam-content "synopsis")) (description ,(metadata-ref opam-content "description")) @@ -259,6 +273,11 @@ path to the repository." (opam->guix-package name)) #:guix-name ocaml-name->guix-name)) +(define (guix-name->opam-name name) + (if (string-prefix? "ocaml-" name) + (substring name 6) + name)) + (define (guix-package->opam-name package) "Given an OCaml PACKAGE built from OPAM, return the name of the package in OPAM." @@ -266,10 +285,9 @@ package in OPAM." (package-properties package) 'upstream-name)) (name (package-name package))) - (cond - (upstream-name upstream-name) - ((string-prefix? "ocaml-" name) (substring name 6)) - (else name)))) + (if upstream-name + upstream-name + (guix-name->opam-name name)))) (define (opam-package? package) "Return true if PACKAGE is an OCaml package from OPAM" diff --git a/guix/monads.scm b/guix/monads.scm index 6ae616aca9..6924471345 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -274,12 +274,23 @@ more optimizations." (_ #'generic-name)))))))))) -(define-syntax-parameter >>= +(define-syntax-rule (define-syntax-parameter-once name proc) + ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME + ;; does not get redefined. This works around a race condition in a + ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>. + (eval-when (load eval expand compile) + (define name + (if (module-locally-bound? (current-module) 'name) + (module-ref (current-module) 'name) + (make-syntax-transformer 'name 'syntax-parameter + (list proc)))))) + +(define-syntax-parameter-once >>= ;; The name 'bind' is already taken, so we choose this (obscure) symbol. (lambda (s) (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) -(define-syntax-parameter return +(define-syntax-parameter-once return (lambda (s) (syntax-violation 'return "return used outside of 'with-monad'" s))) diff --git a/guix/profiles.scm b/guix/profiles.scm index 598e0acf62..6564526aee 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -63,6 +63,10 @@ &missing-generation-error missing-generation-error? missing-generation-error-generation + &unmatched-pattern-error + unmatched-pattern-error? + unmatched-pattern-error-pattern + unmatched-pattern-error-manifest manifest make-manifest manifest? @@ -156,6 +160,11 @@ (entry profile-collision-error-entry) ;<manifest-entry> (conflict profile-collision-error-conflict)) ;<manifest-entry> +(define-condition-type &unmatched-pattern-error &error + unmatched-pattern-error? + (pattern unmatched-pattern-error-pattern) ;<manifest-pattern> + (manifest unmatched-pattern-error-manifest)) ;<manifest> + (define-condition-type &missing-generation-error &profile-error missing-generation-error? (generation missing-generation-error-generation)) @@ -559,16 +568,21 @@ no match.." (->bool (manifest-lookup manifest pattern))) (define (manifest-matching-entries manifest patterns) - "Return all the entries of MANIFEST that match one of the PATTERNS." - (define predicates - (map entry-predicate patterns)) - - (define (matches? entry) - (any (lambda (pred) - (pred entry)) - predicates)) - - (filter matches? (manifest-entries manifest))) + "Return all the entries of MANIFEST that match one of the PATTERNS. Raise +an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one +of PATTERNS." + (fold-right (lambda (pattern matches) + (match (filter (entry-predicate pattern) + (manifest-entries manifest)) + (() + (raise (condition + (&unmatched-pattern-error + (pattern pattern) + (manifest manifest))))) + (lst + (append lst matches)))) + '() + patterns)) (define (manifest-search-paths manifest) "Return the list of search path specifications that apply to MANIFEST, @@ -1300,12 +1314,22 @@ the entries in MANIFEST." (srfi srfi-19)) (define (compute-entries) - (append-map (lambda (directory) - (let ((man (string-append directory "/share/man"))) - (if (directory-exists? man) - (mandb-entries man) - '()))) - '#$(manifest-inputs manifest))) + ;; This is the most expensive part (I/O and CPU, due to + ;; decompression), so report progress as we traverse INPUTS. + (let* ((inputs '#$(manifest-inputs manifest)) + (total (length inputs))) + (append-map (lambda (directory count) + (format #t "\r[~3d/~3d] building list of \ +man-db entries..." + count total) + (force-output) + (let ((man (string-append directory + "/share/man"))) + (if (directory-exists? man) + (mandb-entries man) + '()))) + inputs + (iota total 1)))) (define man-directory (string-append #$output "/share/man")) @@ -1320,6 +1344,7 @@ the entries in MANIFEST." "/index.db") entries)) (duration (time-difference (current-time) start))) + (newline) (format #t "~a entries processed in ~,1f s~%" (length entries) (+ (time-second duration) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 5a158799ae..fb7e04904d 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -308,7 +308,8 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using (package (inherit old) (version (string-append "git." branch)) - (source (git-checkout (url url) (branch branch))))) + (source (git-checkout (url url) (branch branch) + (recursive? #t))))) (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a633d2ee6d..8a71467b52 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -739,9 +739,9 @@ processed, #f otherwise." (available (fold-available-packages (lambda* (name version result #:key outputs location - supported? superseded? + supported? deprecated? #:allow-other-keys) - (if (and supported? (not superseded?)) + (if (and supported? (not deprecated?)) (if regexp (if (regexp-exec regexp name) (cons `(,name ,version diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 683ab3f059..3320200c07 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -216,30 +216,8 @@ true, display what would be built without actually building it." (define (honor-x509-certificates store) "Use the right X.509 certificates for Git checkouts over HTTPS." - ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of - ;; files (instead of all the certificates) among which "ca-bundle.crt". On - ;; other distros /etc/ssl/certs usually contains the whole set of - ;; certificates along with "ca-certificates.crt". Try to choose the right - ;; one. - (let ((file (letrec-syntax ((choose - (syntax-rules () - ((_ file rest ...) - (let ((f file)) - (if (and f (file-exists? f)) - f - (choose rest ...)))) - ((_) - #f)))) - (choose (getenv "SSL_CERT_FILE") - "/etc/ssl/certs/ca-certificates.crt" - "/etc/ssl/certs/ca-bundle.crt"))) - (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) - (if (or file - (and=> (stat directory #f) - (lambda (st) - (> (stat:nlink st) 2)))) - (set-tls-certificate-locations! directory file) - (honor-lets-encrypt-certificates! store)))) + (unless (honor-system-x509-certificates!) + (honor-lets-encrypt-certificates! store))) (define (report-git-error error) "Report the given Guile-Git error." diff --git a/guix/self.scm b/guix/self.scm index f028bdbfdd..a45470a0a6 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -460,17 +460,27 @@ load path." the modules (under share/guile/site and lib/guile), and DEPENDENCIES, a list of packages depended on. COMMAND is the 'guix' program to use; INFO is the Info manual." + (define (wrap daemon) + (program-file "guix-daemon" + #~(begin + (setenv "GUIX" #$command) + (apply execl #$(file-append daemon "/bin/guix-daemon") + "guix-daemon" (cdr (command-line)))))) + (computed-file name (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) + (define daemon + #$(and daemon (wrap daemon))) + (mkdir-p (string-append #$output "/bin")) (symlink #$command (string-append #$output "/bin/guix")) - (when #$daemon - (symlink (string-append #$daemon "/bin/guix-daemon") + (when daemon + (symlink daemon (string-append #$output "/bin/guix-daemon"))) (let ((share (string-append #$output "/share")) @@ -786,11 +796,11 @@ Info manual." (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in ;; `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") + (or (getenv "GUIX_STATE_DIRECTORY") (string-append %localstatedir "/guix"))) (define %store-database-directory - (or (getenv "NIX_DB_DIR") + (or (getenv "GUIX_DATABASE_DIRECTORY") (string-append %state-directory "/db"))) (define %config-directory diff --git a/guix/status.scm b/guix/status.scm index e3375816c5..cd5027ef17 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -30,6 +30,7 @@ #:use-module (guix memoization) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 regex) @@ -54,6 +55,9 @@ build build-derivation build-system + build-log-file + build-phase + build-completion download? download @@ -100,18 +104,21 @@ (default '()))) ;; On-going or completed build. -(define-record-type <build> - (%build derivation id system log-file completion) +(define-immutable-record-type <build> + (%build derivation id system log-file phase completion) build? (derivation build-derivation) ;string (.drv file name) (id build-id) ;#f | integer (system build-system) ;string (log-file build-log-file) ;#f | string - (completion build-completion)) ;#f | integer (percentage) + (phase build-phase ;#f | symbol + set-build-phase) + (completion build-completion ;#f | integer (percentage) + set-build-completion)) -(define* (build derivation system #:key id log-file completion) +(define* (build derivation system #:key id log-file phase completion) "Return a new build." - (%build derivation id system log-file completion)) + (%build derivation id system log-file phase completion)) ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. @@ -142,6 +149,10 @@ (lambda (download) (string=? item (download-item download)))) +(define %phase-start-rx + ;; Match the "starting phase" message emitted by 'gnu-build-system'. + (make-regexp "^starting phase [`']([^']+)'")) + (define %percentage-line-rx ;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp ;; matches them. @@ -156,13 +167,6 @@ (define (update-build status id line) "Update STATUS based on LINE, a build output line for ID that might contain a completion indication." - (define (set-completion b %) - (build (build-derivation b) - (build-system b) - #:id (build-id b) - #:log-file (build-log-file b) - #:completion %)) - (define (find-build) (find (lambda (build) (and (build-id build) @@ -173,7 +177,7 @@ a completion indication." (let ((build (find-build))) (build-status (inherit status) - (building (cons (set-completion build %) + (building (cons (set-build-completion build %) (delq build (build-status-building status))))))) (cond ((string-any #\nul line) @@ -190,6 +194,19 @@ a completion indication." (let ((done (string->number (match:substring match 1))) (total (string->number (match:substring match 3)))) (update (* 100. (/ done total)))))) + ((regexp-exec %phase-start-rx line) + => + (lambda (match) + (let ((phase (match:substring match 1)) + (build (find-build))) + (if build + (build-status + (inherit status) + (building + (cons (set-build-phase (set-build-completion build #f) + (string->symbol phase)) + (delq build (build-status-building status))))) + status)))) (else status))) @@ -328,14 +345,21 @@ build-log\" traces." (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) - (lambda (port) - "Display a spinner on PORT." + (lambda (phase port) + "Display a spinner on PORT. If PHASE is true, display it as a hint of +the current build phase." (when (isatty?* port) (match steps ((first . rest) (set! steps rest) (display "\r\x1b[K" port) (display first port) + (when phase + (display " " port) + ;; TRANSLATORS: The word "phase" here denotes a "build phase"; + ;; "~a" is a placeholder for the untranslated name of the current + ;; build phase--e.g., 'configure' or 'build'. + (format port (G_ "'~a' phase") phase)) (force-output port))))))) (define (color-output? port) @@ -441,12 +465,18 @@ addition to build events." (cut colorize-string <> 'RED 'BOLD) identity)) - (define (report-build-progress %) + (define (report-build-progress phase %) (let ((% (min (max % 0) 100))) ;sanitize (erase-current-line port) - (format port "~3d% " (inexact->exact (round %))) - (display (progress-bar % (- (current-terminal-columns) 5)) - port) + (let* ((prefix (format #f "~3d% ~@['~a' ~]" + (inexact->exact (round %)) + (case phase + ((build) #f) ;not useful to display it + (else phase)))) + (length (string-length prefix))) + (display prefix port) + (display (progress-bar % (- (current-terminal-columns) length)) + port)) (force-output port))) (define print-log-line @@ -460,13 +490,20 @@ addition to build events." (match (build-status-building status) ((build) ;single job (match (build-completion build) - ((? number? %) (report-build-progress %)) - (_ (spin! port)))) + ((? number? %) + (report-build-progress (build-phase build) %)) + (_ + (spin! (build-phase build) port)))) (_ - (spin! port)))))) + (spin! #f port)))))) + + (define erase-current-line* + (if (and (not print-log?) (isatty?* port)) + (lambda () + (erase-current-line port) + (force-output port)) + (const #t))) - (unless print-log? - (display "\r" port)) ;erase the spinner (match event (('build-started drv . _) (let ((properties (derivation-properties @@ -491,6 +528,7 @@ addition to build events." (format port (info (G_ "building ~a...")) drv)))) (newline port)) (('build-succeeded drv . _) + (erase-current-line*) ;erase spinner or progress bar (when (or print-log? (not (extended-build-trace-supported?))) (format port (success (G_ "successfully built ~a")) drv) (newline port)) @@ -503,6 +541,7 @@ addition to build events." (length ongoing)) (map build-derivation ongoing))))) (('build-failed drv . _) + (erase-current-line*) ;erase spinner or progress bar (format port (failure (G_ "build of ~a failed")) drv) (newline port) (match (derivation-log-file drv) diff --git a/guix/store.scm b/guix/store.scm index d079147529..0a0a7c7c52 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1856,8 +1856,9 @@ syntactically valid store path." "Return the build log file for DRV, a derivation file name, or #f if it could not be found." (let* ((base (basename drv)) - (log (string-append (dirname %state-directory) ; XXX - "/log/guix/drvs/" + (log (string-append (or (getenv "GUIX_LOG_DIRECTORY") + (string-append %localstatedir "/log/guix")) + "/drvs/" (string-take base 2) "/" (string-drop base 2))) (log.gz (string-append log ".gz")) diff --git a/guix/ui.scm b/guix/ui.scm index 9eab4ba3f7..f0465519b6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -643,6 +643,14 @@ or remove one of them from the profile.") (leave (G_ "generation ~a of profile '~a' does not exist~%") (missing-generation-error-generation c) (profile-error-profile c))) + ((unmatched-pattern-error? c) + (let ((pattern (unmatched-pattern-error-pattern c))) + (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%") + (manifest-pattern-name pattern) + (manifest-pattern-version pattern) + (match (manifest-pattern-output pattern) + ("out" #f) + (output output))))) ((profile-collision-error? c) (let ((entry (profile-collision-error-entry c)) (conflict (profile-collision-error-conflict c))) |