diff options
Diffstat (limited to 'guix')
37 files changed, 1493 insertions, 709 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index d20f66e1a9..d5f897932f 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,7 +74,7 @@ release corresponding to NAME and VERSION." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:inputs #:native-inputs)) + '(#:source #:target #:r #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 7b6e31107c..5a1363556a 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -196,6 +196,20 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." (unless (zero? total) (report-compilation #f total total))))) +(eval-when (eval load) + (when (and (string=? "2" (major-version)) + (or (string=? "0" (minor-version)) + (and (string=? (minor-version) "2") + (< (string->number (micro-version)) 4)))) + ;; Work around <https://bugs.gnu.org/31878> on Guile < 2.2.4. + ;; Serialize 'try-module-autoload' calls. + (set! (@ (guile) try-module-autoload) + (let ((mutex (make-mutex 'recursive)) + (real (@ (guile) try-module-autoload))) + (lambda* (module #:optional version) + (with-mutex mutex + (real module version))))))) + ;;; Local Variables: ;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2) ;;; eval: (put 'with-target 'scheme-indent-function 1) diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index fe2eb6f69a..2d9590d16f 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,10 +18,22 @@ (define-module (guix build store-copy) #:use-module (guix build utils) + #:use-module (guix sets) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 ftw) - #:export (read-reference-graph + #:use-module (ice-9 vlist) + #:export (store-info? + store-info + store-info-item + store-info-deriver + store-info-references + + read-reference-graph + closure-size populate-store)) @@ -34,19 +46,94 @@ ;;; ;;; Code: +;; Information about a store item as produced by #:references-graphs. +(define-record-type <store-info> + (store-info item deriver references) + store-info? + (item store-info-item) ;string + (deriver store-info-deriver) ;#f | string + (references store-info-references)) ;? + +;; TODO: Factorize with that in (guix store). +(define (topological-sort nodes edges) + "Return NODES in topological order according to EDGES. EDGES must be a +one-argument procedure that takes a node and returns the nodes it is connected +to." + (define (traverse) + ;; Do a simple depth-first traversal of all of PATHS. + (let loop ((nodes nodes) + (visited (setq)) + (result '())) + (match nodes + ((head tail ...) + (if (set-contains? visited head) + (loop tail visited result) + (call-with-values + (lambda () + (loop (edges head) + (set-insert head visited) + result)) + (lambda (visited result) + (loop tail visited (cons head result)))))) + (() + (values visited result))))) + + (call-with-values traverse + (lambda (_ result) + (reverse result)))) + (define (read-reference-graph port) - "Return a list of store paths from the reference graph at PORT. -The data at PORT is the format produced by #:references-graphs." - (let loop ((line (read-line port)) - (result '())) - (cond ((eof-object? line) - (delete-duplicates result)) - ((string-prefix? "/" line) - (loop (read-line port) - (cons line result))) - (else - (loop (read-line port) - result))))) + "Read the reference graph as produced by #:references-graphs from PORT and +return it as a list of <store-info> records in topological order--i.e., leaves +come first. IOW, store items in the resulting list can be registered in the +order in which they appear. + +The reference graph format consists of sequences of lines like this: + + FILE + DERIVER + NUMBER-OF-REFERENCES + REF1 + ... + REFN + +It is meant as an internal format." + (let loop ((result '()) + (table vlist-null) + (referrers vlist-null)) + (match (read-line port) + ((? eof-object?) + ;; 'guix-daemon' gives us something that's in "reverse topological + ;; order"--i.e., leaves (items with zero references) come last. Here + ;; we compute the topological order that we want: leaves come first. + (let ((unreferenced? (lambda (item) + (let ((referrers (vhash-fold* cons '() + (store-info-item item) + referrers))) + (or (null? referrers) + (equal? (list item) referrers)))))) + (topological-sort (filter unreferenced? result) + (lambda (item) + (map (lambda (item) + (match (vhash-assoc item table) + ((_ . node) node))) + (store-info-references item)))))) + (item + (let* ((deriver (match (read-line port) + ("" #f) + (line line))) + (count (string->number (read-line port))) + (refs (unfold-right (cut >= <> count) + (lambda (n) + (read-line port)) + 1+ + 0)) + (item (store-info item deriver refs))) + (loop (cons item result) + (vhash-cons (store-info-item item) item table) + (fold (cut vhash-cons <> item <>) + referrers + refs))))))) (define (file-size file) "Return the size of bytes of FILE, entering it if FILE is a directory." @@ -72,7 +159,8 @@ The data at PORT is the format produced by #:references-graphs." "Return an estimate of the size of the closure described by REFERENCE-GRAPHS, a list of reference-graph files." (define (graph-from-file file) - (call-with-input-file file read-reference-graph)) + (map store-info-item + (call-with-input-file file read-reference-graph))) (define items (delete-duplicates (append-map graph-from-file reference-graphs))) @@ -88,7 +176,8 @@ REFERENCE-GRAPHS, a list of reference-graph files." (define (things-to-copy) ;; Return the list of store files to copy to the image. (define (graph-from-file file) - (call-with-input-file file read-reference-graph)) + (map store-info-item + (call-with-input-file file read-reference-graph))) (delete-duplicates (append-map graph-from-file reference-graphs))) diff --git a/guix/build/waf-build-system.scm b/guix/build/waf-build-system.scm index f0364e867d..56048e7685 100644 --- a/guix/build/waf-build-system.scm +++ b/guix/build/waf-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,7 +38,8 @@ (begin (format #t "running \"python waf\" with command ~s and parameters ~s~%" command params) - (zero? (apply system* "python" "waf" command params))) + (apply invoke "python" "waf" command params) + #t) (error "no waf found"))) (define* (configure #:key target native-inputs inputs outputs diff --git a/guix/config.scm.in b/guix/config.scm.in index dfe5fe0dbf..1a761b912e 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> ;;; ;;; This file is part of GNU Guix. @@ -26,18 +26,15 @@ %storedir %localstatedir %sysconfdir - %sbindir %store-directory %state-directory %store-database-directory %config-directory - %guix-register-program %system %libgcrypt %libz - %nix-instantiate %gzip %bzip2 %xz)) @@ -70,9 +67,6 @@ (define %sysconfdir "@guix_sysconfdir@") -(define %sbindir - "@guix_sbindir@") - (define %store-directory (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) %storedir)) @@ -83,7 +77,7 @@ (string-append %localstatedir "/guix"))) (define %store-database-directory - (or (and=> (getenv "NIX_DB_DIR") canonicalize-path) + (or (getenv "NIX_DB_DIR") (string-append %state-directory "/db"))) (define %config-directory @@ -91,11 +85,6 @@ (or (getenv "GUIX_CONFIGURATION_DIRECTORY") (string-append %sysconfdir "/guix"))) -(define %guix-register-program - ;; The 'guix-register' program. - (or (getenv "GUIX_REGISTER") - (string-append %sbindir "/guix-register"))) - (define %system "@guix_system@") @@ -105,9 +94,6 @@ (define %libz "@LIBZ@") -(define %nix-instantiate - "@NIX_INSTANTIATE@") - (define %gzip "@GZIP@") diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 58c051e283..08bed8767c 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -88,9 +88,10 @@ "Return the base distribution module for a given module. E.g. the 'ok' module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would return \"Test-Simple\"" - (assoc-ref (json-fetch (string-append "https://fastapi.metacpan.org/v1/module/" - module - "?fields=distribution")) + (assoc-ref (json-fetch-alist (string-append + "https://fastapi.metacpan.org/v1/module/" + module + "?fields=distribution")) "distribution")) (define (package->upstream-name package) @@ -113,7 +114,7 @@ return \"Test-Simple\"" "Return an alist representation of the CPAN metadata for the perl module MODULE, or #f on failure. MODULE should be e.g. \"Test::Script\"" ;; This API always returns the latest release of the module. - (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name))) + (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name))) (define (cpan-home name) (string-append "http://search.cpan.org/dist/" name "/")) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 49e5d2d358..a5203fe78d 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -25,7 +25,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) - #:use-module (srfi srfi-41) #:use-module (ice-9 receive) #:use-module (web uri) #:use-module (guix memoization) @@ -43,7 +42,7 @@ #:use-module (gnu packages) #:export (cran->guix-package bioconductor->guix-package - recursive-import + cran-recursive-import %cran-updater %bioconductor-updater @@ -231,13 +230,7 @@ empty list when the FIELD cannot be found." "translations" "utils")) -(define (guix-name name) - "Return a Guix package name for a given R package name." - (string-append "r-" (string-map (match-lambda - (#\_ #\-) - (#\. #\-) - (chr (char-downcase chr))) - name))) +(define cran-guix-name (cut guix-name "r-" <>)) (define (needs-fortran? tarball) "Check if the TARBALL contains Fortran source files." @@ -318,7 +311,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (listify meta "Depends")))))) (values `(package - (name ,(guix-name name)) + (name ,(cran-guix-name name)) (version ,version) (source (origin (method url-fetch) @@ -327,12 +320,12 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (base32 ,(bytevector->nix-base32-string (file-sha256 tarball)))))) ,@(if (not (equal? (string-append "r-" name) - (guix-name name))) + (cran-guix-name name))) `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) '()) (build-system r-build-system) ,@(maybe-inputs sysdepends) - ,@(maybe-inputs (map guix-name propagate) 'propagated-inputs) + ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) ,@(maybe-inputs `(,@(if (needs-fortran? tarball) '("gfortran") '()) @@ -356,63 +349,10 @@ s-expression corresponding to that package, or #f on failure." (and=> (fetch-description repo package-name) (cut description->package repo <>))))) -(define* (recursive-import package-name #:optional (repo 'cran)) - "Generate a stream of package expressions for PACKAGE-NAME and all its -dependencies." - (receive (package . dependencies) - (cran->guix-package package-name repo) - (if (not package) - stream-null - - ;; Generate a lazy stream of package expressions for all unknown - ;; dependencies in the graph. - (let* ((make-state (lambda (queue done) - (cons queue done))) - (next (match-lambda - (((next . rest) . done) next))) - (imported (match-lambda - ((queue . done) done))) - (done? (match-lambda - ((queue . done) - (zero? (length queue))))) - (unknown? (lambda* (dependency #:optional (done '())) - (and (not (member dependency - done)) - (null? (find-packages-by-name - (guix-name dependency)))))) - (update (lambda (state new-queue) - (match state - (((head . tail) . done) - (make-state (lset-difference - equal? - (lset-union equal? new-queue tail) - done) - (cons head done))))))) - (stream-cons - package - (stream-unfold - ;; map: produce a stream element - (lambda (state) - (cran->guix-package (next state) repo)) - - ;; predicate - (negate done?) - - ;; generator: update the queue - (lambda (state) - (receive (package . dependencies) - (cran->guix-package (next state) repo) - (if package - (update state (filter (cut unknown? <> - (cons (next state) - (imported state))) - (car dependencies))) - ;; TODO: Try the other archives before giving up - (update state (imported state))))) - - ;; initial state - (make-state (filter unknown? (car dependencies)) - (list package-name)))))))) +(define* (cran-recursive-import package-name #:optional (repo 'gnu)) + (recursive-import package-name repo + #:repo->guix-package cran->guix-package + #:guix-name cran-guix-name)) ;;; diff --git a/guix/import/crate.scm b/guix/import/crate.scm index a7485bb4d0..3724a457a4 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -51,7 +51,7 @@ (define (crate-kind-predicate kind) (lambda (dep) (string=? (assoc-ref dep "kind") kind))) - (and-let* ((crate-json (json-fetch (string-append crate-url crate-name))) + (and-let* ((crate-json (json-fetch-alist (string-append crate-url crate-name))) (crate (assoc-ref crate-json "crate")) (name (assoc-ref crate "name")) (version (assoc-ref crate "max_version")) @@ -63,7 +63,7 @@ string->license) '())) ;missing license info (path (string-append "/" version "/dependencies")) - (deps-json (json-fetch (string-append crate-url name path))) + (deps-json (json-fetch-alist (string-append crate-url name path))) (deps (assoc-ref deps-json "dependencies")) (input-crates (filter (crate-kind-predicate "normal") deps)) (native-input-crates diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 43e9eb60c9..65e0be45ab 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,7 +38,8 @@ #:use-module (guix packages) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (elpa->guix-package - %elpa-updater)) + %elpa-updater + elpa-recursive-import)) (define (elpa-dependencies->names deps) "Convert DEPS, a list of symbol/version pairs à la ELPA, to a list of @@ -200,13 +202,15 @@ type '<elpa-package>'." (define source-url (elpa-package-source-url pkg)) + (define dependencies-names + (filter-dependencies (elpa-dependencies->names + (elpa-package-inputs pkg)))) + (define dependencies - (let* ((deps (elpa-package-inputs pkg)) - (names (filter-dependencies (elpa-dependencies->names deps)))) - (map (lambda (n) - (let ((new-n (elpa-name->package-name n))) - (list new-n (list 'unquote (string->symbol new-n))))) - names))) + (map (lambda (n) + (let ((new-n (elpa-name->package-name n))) + (list new-n (list 'unquote (string->symbol new-n))))) + dependencies-names)) (define (maybe-inputs input-type inputs) (match inputs @@ -218,23 +222,25 @@ type '<elpa-package>'." (let ((tarball (with-store store (download-to-store store source-url)))) - `(package - (name ,(elpa-name->package-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) - (sha256 - (base32 - ,(if tarball - (bytevector->nix-base32-string (file-sha256 tarball)) - "failed to download package"))))) - (build-system emacs-build-system) - ,@(maybe-inputs 'propagated-inputs dependencies) - (home-page ,(elpa-package-home-page pkg)) - (synopsis ,(elpa-package-synopsis pkg)) - (description ,(elpa-package-description pkg)) - (license ,license)))) + (values + `(package + (name ,(elpa-name->package-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(if tarball + (bytevector->nix-base32-string (file-sha256 tarball)) + "failed to download package"))))) + (build-system emacs-build-system) + ,@(maybe-inputs 'propagated-inputs dependencies) + (home-page ,(elpa-package-home-page pkg)) + (synopsis ,(elpa-package-synopsis pkg)) + (description ,(elpa-package-description pkg)) + (license ,license)) + dependencies-names))) (define* (elpa->guix-package name #:optional (repo 'gnu)) "Fetch the package NAME from REPO and produce a Guix package S-expression." @@ -289,4 +295,11 @@ type '<elpa-package>'." (pred package-from-gnu.org?) (latest latest-release))) +(define elpa-guix-name (cut guix-name "emacs-" <>)) + +(define* (elpa-recursive-import package-name #:optional (repo 'gnu)) + (recursive-import package-name repo + #:repo->guix-package elpa->guix-package + #:guix-name elpa-guix-name)) + ;;; elpa.scm ends here diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 6e914d6290..646163fb7b 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -38,7 +38,7 @@ (define (rubygems-fetch name) "Return an alist representation of the RubyGems metadata for the package NAME, or #f on failure." - (json-fetch + (json-fetch-alist (string-append "https://rubygems.org/api/v1/gems/" name ".json"))) (define (ruby-package-name name) diff --git a/guix/import/github.scm b/guix/import/github.scm index 4b7d53c704..ef226911b9 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -22,31 +22,16 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) - #:use-module (json) #:use-module (guix utils) #:use-module ((guix download) #:prefix download:) #:use-module (guix import utils) + #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix http-client) #:use-module (web uri) #:export (%github-updater)) -(define (json-fetch* url) - "Return a representation of the JSON resource URL (a list or hash table), or -#f if URL returns 403 or 404." - (guard (c ((and (http-get-error? c) - (let ((error (http-get-error-code c))) - (or (= 403 error) - (= 404 error)))) - #f)) ;; "expected" if there is an authentification error (403), - ;; or if package is unknown (404). - ;; Note: github.com returns 403 if we omit a 'User-Agent' header. - (let* ((port (http-fetch url)) - (result (json->scm port))) - (close-port port) - result))) - (define (find-extension url) "Return the extension of the archive e.g. '.tar.gz' given a URL, or false if none is recognized" @@ -144,7 +129,7 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" "https://api.github.com/repos/" (github-user-slash-repository url) "/releases")) - (json (json-fetch* + (json (json-fetch (if token (string-append api-url "?access_token=" token) api-url)))) diff --git a/guix/import/json.scm b/guix/import/json.scm index c76bc9313c..3f2ab1e3ea 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -22,15 +22,25 @@ #:use-module (guix http-client) #:use-module (guix import utils) #:use-module (srfi srfi-34) - #:export (json-fetch)) + #:export (json-fetch + json-fetch-alist)) (define (json-fetch url) - "Return an alist representation of the JSON resource URL, or #f on failure." + "Return a representation of the JSON resource URL (a list or hash table), or +#f if URL returns 403 or 404." (guard (c ((and (http-get-error? c) - (= 404 (http-get-error-code c))) - #f)) ;"expected" if package is unknown - (let* ((port (http-fetch url #:headers '((user-agent . "GNU Guile") - (Accept . "application/json")))) - (result (hash-table->alist (json->scm port)))) + (let ((error (http-get-error-code c))) + (or (= 403 error) + (= 404 error)))) + #f)) + ;; Note: many websites returns 403 if we omit a 'User-Agent' header. + (let* ((port (http-fetch url #:headers '((user-agent . "GNU Guile") + (Accept . "application/json")))) + (result (json->scm port))) (close-port port) result))) + +(define (json-fetch-alist url) + "Return an alist representation of the JSON resource URL, or #f if URL +returns 403 or 404." + (hash-table->alist (json-fetch url))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index bb0db1ba85..6beab6b010 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -51,8 +51,8 @@ (define (pypi-fetch name) "Return an alist representation of the PyPI metadata for the package NAME, or #f on failure." - (json-fetch (string-append "https://pypi.python.org/pypi/" - name "/json"))) + (json-fetch-alist (string-append "https://pypi.python.org/pypi/" + name "/json"))) ;; For packages found on PyPI that lack a source distribution. (define-condition-type &missing-source-error &error diff --git a/guix/import/snix.scm b/guix/import/snix.scm index 778768ff2d..56934e8cf9 100644 --- a/guix/import/snix.scm +++ b/guix/import/snix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -283,7 +283,7 @@ ATTRIBUTE is true, only that attribute is considered." platform = (import ~a/pkgs/top-level/platforms.nix).sheevaplug; }" nixpkgs))) (apply open-pipe* OPEN_READ - %nix-instantiate "--strict" "--eval-only" "--xml" + "nix-instantiate" "--strict" "--eval-only" "--xml" ;; Pass a dummy `crossSystem' argument so that `buildInputs' and ;; `nativeBuildInputs' are not coalesced. diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 5b25adc674..ec93fbced6 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -60,7 +60,7 @@ (let* ((url (if (string=? "" version) (string-append %stackage-url "/lts") (string-append %stackage-url "/lts-" version))) - (lts-info (json-fetch url))) + (lts-info (json-fetch-alist url))) (if lts-info (reverse lts-info) (leave-with-message "LTS release version not found: ~a" version)))))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index efc6169077..0dc8fd5857 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +40,8 @@ #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-41) #:export (factorize-uri hash-table->alist @@ -61,7 +64,11 @@ alist->package read-lines - chunk-lines)) + chunk-lines + + guix-name + + recursive-import)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -357,3 +364,71 @@ separated by PRED." (if (null? after) (reverse res) (loop (cdr after) res)))))) + +(define (guix-name prefix name) + "Return a Guix package name for a given package name." + (string-append prefix (string-map (match-lambda + (#\_ #\-) + (#\. #\-) + (chr (char-downcase chr))) + name))) + +(define* (recursive-import package-name repo + #:key repo->guix-package guix-name + #:allow-other-keys) + "Generate a stream of package expressions for PACKAGE-NAME and all its +dependencies." + (receive (package . dependencies) + (repo->guix-package package-name repo) + (if (not package) + stream-null + + ;; Generate a lazy stream of package expressions for all unknown + ;; dependencies in the graph. + (let* ((make-state (lambda (queue done) + (cons queue done))) + (next (match-lambda + (((next . rest) . done) next))) + (imported (match-lambda + ((queue . done) done))) + (done? (match-lambda + ((queue . done) + (zero? (length queue))))) + (unknown? (lambda* (dependency #:optional (done '())) + (and (not (member dependency + done)) + (null? (find-packages-by-name + (guix-name dependency)))))) + (update (lambda (state new-queue) + (match state + (((head . tail) . done) + (make-state (lset-difference + equal? + (lset-union equal? new-queue tail) + done) + (cons head done))))))) + (stream-cons + package + (stream-unfold + ;; map: produce a stream element + (lambda (state) + (repo->guix-package (next state) repo)) + + ;; predicate + (negate done?) + + ;; generator: update the queue + (lambda (state) + (receive (package . dependencies) + (repo->guix-package (next state) repo) + (if package + (update state (filter (cut unknown? <> + (cons (next state) + (imported state))) + (car dependencies))) + ;; TODO: Try the other archives before giving up + (update state (imported state))))) + + ;; initial state + (make-state (filter unknown? (car dependencies)) + (list package-name)))))))) diff --git a/guix/nar.scm b/guix/nar.scm index 9b4c608238..3556de1379 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -23,6 +23,7 @@ #:use-module ((guix build utils) #:select (delete-file-recursively with-directory-excursion)) #:use-module (guix store) + #:use-module (guix store database) #:use-module (guix ui) ; for '_' #:use-module (guix hash) #:use-module (guix pki) diff --git a/guix/packages.scm b/guix/packages.scm index a6f9936d63..c762fa7c39 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -35,6 +35,7 @@ #:use-module (guix sets) #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) @@ -106,6 +107,7 @@ package-cross-derivation package-output package-grafts + package-patched-vulnerabilities package/inherit transitive-input-references @@ -394,6 +396,32 @@ DELIMITER (a string), you can customize what will appear between the name and the version. By default, DELIMITER is \"@\"." (string-append (package-name package) delimiter (package-version package))) +(define (patch-file-name patch) + "Return the basename of PATCH's file name, or #f if the file name could not +be determined." + (match patch + ((? string?) + (basename patch)) + ((? origin?) + (and=> (origin-actual-file-name patch) basename)))) + +(define %vulnerability-regexp + ;; Regexp matching a CVE identifier in patch file names. + (make-regexp "CVE-[0-9]{4}-[0-9]+")) + +(define (package-patched-vulnerabilities package) + "Return the list of patched vulnerabilities of PACKAGE as a list of CVE +identifiers. The result is inferred from the file names of patches." + (define (patch-vulnerabilities patch) + (map (cut match:substring <> 0) + (list-matches %vulnerability-regexp patch))) + + (let ((patches (filter-map patch-file-name + (or (and=> (package-source package) + origin-patches) + '())))) + (append-map patch-vulnerabilities patches))) + (define (%standard-patch-inputs) (let* ((canonical (module-ref (resolve-interface '(gnu packages base)) 'canonical-package)) diff --git a/guix/profiles.scm b/guix/profiles.scm index 9bddf88162..ebd7da2a24 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -25,6 +25,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix profiles) + #:use-module ((guix config) #:select (%state-directory)) #:use-module ((guix utils) #:hide (package-name->name+version)) #:use-module ((guix build utils) #:select (package-name->name+version)) @@ -77,6 +78,7 @@ manifest-entry-dependencies manifest-entry-search-paths manifest-entry-parent + manifest-entry-properties manifest-pattern manifest-pattern? @@ -118,7 +120,13 @@ generation-file-name switch-to-generation roll-back - delete-generation)) + delete-generation + + %user-profile-directory + %profile-directory + %current-profile + canonicalize-profile + user-friendly-profile)) ;;; Commentary: ;;; @@ -174,7 +182,9 @@ (search-paths manifest-entry-search-paths ; search-path-specification* (default '())) (parent manifest-entry-parent ; promise (#f | <manifest-entry>) - (default (delay #f)))) + (default (delay #f))) + (properties manifest-entry-properties ; list of symbol/value pairs + (default '()))) (define-record-type* <manifest-pattern> manifest-pattern make-manifest-pattern @@ -313,18 +323,20 @@ denoting a specific output of a package." (define (entry->gexp entry) (match entry (($ <manifest-entry> name version output (? string? path) - (deps ...) (search-paths ...)) + (deps ...) (search-paths ...) _ (properties ...)) #~(#$name #$version #$output #$path (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp - search-paths)))) + search-paths)) + (properties . #$properties))) (($ <manifest-entry> name version output package - (deps ...) (search-paths ...)) + (deps ...) (search-paths ...) _ (properties ...)) #~(#$name #$version #$output (ungexp package (or output "out")) (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp - search-paths)))))) + search-paths)) + (properties . #$properties))))) (match manifest (($ <manifest> (entries ...)) @@ -387,7 +399,9 @@ procedure is here for backward-compatibility and will eventually vanish." (dependencies deps*) (search-paths (map sexp->search-path-specification search-paths)) - (parent parent)))) + (parent parent) + (properties (or (assoc-ref extra-stuff 'properties) + '()))))) entry)))) (match sexp @@ -1515,4 +1529,44 @@ because the NUMBER is zero.)" (else (delete-and-return))))) +(define %user-profile-directory + (and=> (getenv "HOME") + (cut string-append <> "/.guix-profile"))) + +(define %profile-directory + (string-append %state-directory "/profiles/" + (or (and=> (or (getenv "USER") + (getenv "LOGNAME")) + (cut string-append "per-user/" <>)) + "default"))) + +(define %current-profile + ;; Call it `guix-profile', not `profile', to allow Guix profiles to + ;; coexist with Nix profiles. + (string-append %profile-directory "/guix-profile")) + +(define (canonicalize-profile profile) + "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise +return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if +'-p' was omitted." ; see <http://bugs.gnu.org/17939> + + ;; Trim trailing slashes so that the basename comparison below works as + ;; intended. + (let ((profile (string-trim-right profile #\/))) + (if (and %user-profile-directory + (string=? (canonicalize-path (dirname profile)) + (dirname %user-profile-directory)) + (string=? (basename profile) (basename %user-profile-directory))) + %current-profile + profile))) + +(define (user-friendly-profile profile) + "Return either ~/.guix-profile if that's what PROFILE refers to, directly or +indirectly, or PROFILE." + (if (and %user-profile-directory + (false-if-exception + (string=? (readlink %user-profile-directory) profile))) + %user-profile-directory + profile)) + ;;; profiles.scm ends here diff --git a/guix/scripts.scm b/guix/scripts.scm index 4a7ae7baa3..4cbbbeb96f 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; @@ -170,7 +170,7 @@ Show what and how will/would be built." (define age (match (false-if-not-found (lstat (string-append (config-directory #:ensure? #f) - "/latest"))) + "/current"))) (#f #f) (stat (- (time-second (current-time time-utc)) (stat:mtime stat))))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index e4ed7227ff..6f37b767ff 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -199,10 +199,10 @@ Invoke the garbage collector.\n")) ;; Attempt to have at least SPACE bytes available in STORE. (let ((free (free-disk-space (%store-prefix)))) (if (> free space) - (info (G_ "already ~h bytes available on ~a, nothing to do~%") - free (%store-prefix)) + (info (G_ "already ~h MiBs available on ~a, nothing to do~%") + (/ free 1024. 1024.) (%store-prefix)) (let ((to-free (- space free))) - (info (G_ "freeing ~h bytes~%") to-free) + (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.)) (collect-garbage store to-free))))) (with-error-handling @@ -234,10 +234,10 @@ Invoke the garbage collector.\n")) (ensure-free-space store free-space)) (min-freed (let-values (((paths freed) (collect-garbage store min-freed))) - (info (G_ "freed ~h bytes~%") freed))) + (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.)))) (else (let-values (((paths freed) (collect-garbage store))) - (info (G_ "freed ~h bytes~%") freed)))))) + (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.))))))) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index d65c644c05..30ae6d4342 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -99,8 +99,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse (stream->list (recursive-import package-name - (or (assoc-ref opts 'repo) 'cran))))) + (reverse + (stream->list + (cran-recursive-import package-name + (or (assoc-ref opts 'repo) 'cran))))) ;; Single import (let ((sexp (cran->guix-package package-name (or (assoc-ref opts 'repo) 'cran)))) diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm index 34eb16485e..f1ed5016ba 100644 --- a/guix/scripts/import/elpa.scm +++ b/guix/scripts/import/elpa.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,10 +22,12 @@ #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix import elpa) + #:use-module (guix import utils) #:use-module (guix scripts import) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-elpa)) @@ -45,6 +48,8 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive generate package expressions for all Emacs packages that are not yet in Guix")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -62,6 +67,9 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (lambda (opt name arg result) (alist-cons 'repo (string->symbol arg) (alist-delete 'repo result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -87,10 +95,20 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) - (unless sexp - (leave (G_ "failed to download package '~a'~%") package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (elpa-recursive-import package-name + (or (assoc-ref opts 'repo) 'gnu))))) + (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) + (unless sexp + (leave (G_ "failed to download package '~a'~%") package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index cd802985dc..e477bf0ddc 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; 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 © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -809,15 +809,6 @@ descriptions maintained upstream." (emit-warning package (G_ "invalid license field") 'license)))) -(define (patch-file-name patch) - "Return the basename of PATCH's file name, or #f if the file name could not -be determined." - (match patch - ((? string?) - (basename patch)) - ((? origin?) - (and=> (origin-actual-file-name patch) basename)))) - (define (call-with-networking-fail-safe message error-value proc) "Call PROC catching any network-related errors. Upon a networking error, display a message including MESSAGE and return ERROR-VALUE." @@ -878,20 +869,14 @@ the NIST server non-fatal." (() #t) ((vulnerabilities ...) - (let* ((patches (filter-map patch-file-name - (or (and=> (package-source package) - origin-patches) - '()))) + (let* ((patched (package-patched-vulnerabilities package)) (known-safe (or (assq-ref (package-properties package) 'lint-hidden-cve) '())) (unpatched (remove (lambda (vuln) (let ((id (vulnerability-id vuln))) - (or - (find (cute string-contains - <> id) - patches) - (member id known-safe)))) + (or (member id patched) + (member id known-safe)))) vulnerabilities))) (unless (null? unpatched) (emit-warning package diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 56d6de6308..ee5857e16b 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -124,7 +124,15 @@ determined." (save-module-excursion (lambda () (set-current-module %user-module) - (primitive-load file)))) + (match (primitive-load file) + (((? build-machine? machines) ...) + machines) + (_ + ;; Instead of crashing, assume the empty list. + (warning (G_ "'~a' did not return a list of build machines; \ +ignoring it~%") + file) + '()))))) (lambda args (match args (('system-error . rest) @@ -494,6 +502,30 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (() (values #f #f)))))) +(define (call-with-timeout timeout drv thunk) + "Call THUNK and leave after TIMEOUT seconds. If TIMEOUT is #f, simply call +THUNK. Use DRV as an indication of what we were building when the timeout +expired." + (if (number? timeout) + (dynamic-wind + (lambda () + (sigaction SIGALRM + (lambda _ + ;; The exit code here will be 1, which guix-daemon will + ;; interpret as a transient failure. + (leave (G_ "timeout expired while offloading '~a'~%") + (derivation-file-name drv)))) + (alarm timeout)) + thunk + (lambda () + (alarm 0))) + (thunk))) + +(define-syntax-rule (with-timeout timeout drv exp ...) + "Evaluate EXP... and leave after TIMEOUT seconds if EXP hasn't completed. +If TIMEOUT is #f, simply evaluate EXP..." + (call-with-timeout timeout drv (lambda () exp ...))) + (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) @@ -520,13 +552,18 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (display "# accept\n") (let ((inputs (string-tokenize (read-line))) (outputs (string-tokenize (read-line)))) - (transfer-and-offload drv machine - #:inputs inputs - #:outputs outputs - #:max-silent-time max-silent-time - #:build-timeout build-timeout - #:print-build-trace? - print-build-trace?))) + ;; Even if BUILD-TIMEOUT is honored by MACHINE, there can + ;; be issues with the connection or deadlocks that could + ;; lead the 'guix offload' process to remain stuck forever. + ;; To avoid that, install a timeout here as well. + (with-timeout build-timeout drv + (transfer-and-offload drv machine + #:inputs inputs + #:outputs outputs + #:max-silent-time max-silent-time + #:build-timeout build-timeout + #:print-build-trace? + print-build-trace?)))) (lambda () (release-build-slot slot))) @@ -576,8 +613,8 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") name x)))) (lambda (key . args) - (leave (G_ "remove evaluation on '~a' failed:~{ ~s~}~%") - args)))) + (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%") + name args)))) (define %random-state (delay @@ -755,6 +792,7 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) ;;; eval: (put 'with-file-lock 'scheme-indent-function 1) ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1) +;;; eval: (put 'with-timeout 'scheme-indent-function 2) ;;; End: ;;; offload.scm ends here diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 76729d8e10..7f087a3a3c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -35,6 +35,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system gnu) #:use-module (guix scripts build) + #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (gnu packages compression) @@ -87,6 +88,19 @@ found." %compressors) (leave (G_ "~a: compressor not found~%") name))) +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) + +(define guile-sqlite3&co + ;; Guile-SQLite3 and its propagated inputs. + (cons guile-sqlite3 + (package-transitive-propagated-inputs guile-sqlite3))) + (define* (self-contained-tarball name profile #:key target deduplicate? @@ -101,113 +115,124 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define build - (with-imported-modules (source-module-closure - '((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install))) - #~(begin - (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (define libgcrypt + (module-ref (resolve-interface '(gnu packages gnupg)) + 'libgcrypt)) - (define %root "root") - - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownnership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) - - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) - - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. For testing, we use the bootstrap tar, which is - ;; older and doesn't support it. - (define tar-supports-sort? - (zero? (system* (string-append #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - ;; We need Guix here for 'guix-register'. - (setenv "PATH" - (string-append #$(if localstatedir? - (file-append guix "/sbin:") - "") - #$archiver "/bin")) - - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. - (populate-single-profile-directory %root - #:profile #$profile - #:closure "profile" - #:deduplicate? #f - #:register? #$localstatedir?) - - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (exit - (zero? (apply system* "tar" - "-I" - (string-join '#+(compressor-command compressor)) - "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) - - (string-append "." (%store-directory)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives))))))))) + (define schema + (and localstatedir? + (local-file (search-path %load-path + "guix/store/schema.sql")))) + + (define build + (with-imported-modules `(((guix config) + => ,(make-config.scm + #:libgcrypt libgcrypt)) + ,@(source-module-closure + `((guix build utils) + (guix build union) + (guix build store-copy) + (gnu build install)) + #:select? not-config?)) + (with-extensions guile-sqlite3&co + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define %root "root") + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append archiver "/bin")) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. + (populate-single-profile-directory %root + #:profile #$profile + #:closure "profile" + #:deduplicate? #f + #:register? #$localstatedir? + #:schema #$schema) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (exit + (zero? (apply system* "tar" + "-I" + (string-join '#+(compressor-command compressor)) + "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) + + (string-append "." (%store-directory)) + + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives)))))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -227,70 +252,83 @@ points for virtual file systems (like procfs), and optional symlinks. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." + (define libgcrypt + ;; XXX: Not strictly needed, but pulled by (guix store database). + (module-ref (resolve-interface '(gnu packages gnupg)) + 'libgcrypt)) + + (define build - (with-imported-modules '((guix build utils) - (guix build store-copy) - (gnu build install)) - #~(begin - (use-modules (guix build utils) - (gnu build install) - (guix build store-copy) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (with-imported-modules `(((guix config) + => ,(make-config.scm + #:libgcrypt libgcrypt)) + ,@(source-module-closure + '((guix build utils) + (guix build store-copy) + (gnu build install)) + #:select? not-config?)) + (with-extensions guile-sqlite3&co + #~(begin + (use-modules (guix build utils) + (gnu build install) + (guix build store-copy) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (setenv "PATH" (string-append #$archiver "/bin")) - (setenv "PATH" (string-append #$archiver "/bin")) - - ;; We need an empty file in order to have a valid file argument when - ;; we reparent the root file system. Read on for why that's - ;; necessary. - (with-output-to-file ".empty" (lambda () (display ""))) - - ;; Create the squashfs image in several steps. - ;; Add all store items. Unfortunately mksquashfs throws away all - ;; ancestor directories and only keeps the basename. We fix this - ;; in the following invocations of mksquashfs. - (apply invoke "mksquashfs" - `(,@(call-with-input-file "profile" - read-reference-graph) - ,#$output - - ;; Do not perform duplicate checking because we - ;; don't have any dupes. - "-no-duplicates" - "-comp" - ,#+(compressor-name compressor))) - - ;; Here we reparent the store items. For each sub-directory of - ;; the store prefix we need one invocation of "mksquashfs". - (for-each (lambda (dir) - (apply invoke "mksquashfs" - `(".empty" - ,#$output - "-root-becomes" ,dir))) - (reverse (string-tokenize (%store-directory) - (char-set-complement (char-set #\/))))) - - ;; Add symlinks and mount points. - (apply invoke "mksquashfs" - `(".empty" - ,#$output - ;; Create SYMLINKS via pseudo file definitions. - ,@(append-map - (match-lambda - ((source '-> target) - (list "-p" - (string-join - ;; name s mode uid gid symlink - (list source - "s" "777" "0" "0" - (string-append #$profile "/" target)))))) - '#$symlinks) - - ;; Create empty mount points. - "-p" "/proc d 555 0 0" - "-p" "/sys d 555 0 0" - "-p" "/dev d 555 0 0"))))) + ;; We need an empty file in order to have a valid file argument when + ;; we reparent the root file system. Read on for why that's + ;; necessary. + (with-output-to-file ".empty" (lambda () (display ""))) + + ;; Create the squashfs image in several steps. + ;; Add all store items. Unfortunately mksquashfs throws away all + ;; ancestor directories and only keeps the basename. We fix this + ;; in the following invocations of mksquashfs. + (apply invoke "mksquashfs" + `(,@(map store-info-item + (call-with-input-file "profile" + read-reference-graph)) + ,#$output + + ;; Do not perform duplicate checking because we + ;; don't have any dupes. + "-no-duplicates" + "-comp" + ,#+(compressor-name compressor))) + + ;; Here we reparent the store items. For each sub-directory of + ;; the store prefix we need one invocation of "mksquashfs". + (for-each (lambda (dir) + (apply invoke "mksquashfs" + `(".empty" + ,#$output + "-root-becomes" ,dir))) + (reverse (string-tokenize (%store-directory) + (char-set-complement (char-set #\/))))) + + ;; Add symlinks and mount points. + (apply invoke "mksquashfs" + `(".empty" + ,#$output + ;; Create SYMLINKS via pseudo file definitions. + ,@(append-map + (match-lambda + ((source '-> target) + (list "-p" + (string-join + ;; name s mode uid gid symlink + (list source + "s" "777" "0" "0" + (string-append #$profile "/" target)))))) + '#$symlinks) + + ;; Create empty mount points. + "-p" "/proc d 555 0 0" + "-p" "/sys d 555 0 0" + "-p" "/dev d 555 0 0")))))) (gexp->derivation (string-append name (compressor-extension compressor) @@ -310,14 +348,6 @@ image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it must a be a GNU triplet and it is used to derive the architecture metadata in the image." - ;; FIXME: Honor LOCALSTATEDIR?. - (define not-config? - (match-lambda - (('guix 'config) #f) - (('guix rest ...) #t) - (('gnu rest ...) #t) - (rest #f))) - (define defmod 'define-module) ;trick Geiser (define config @@ -342,9 +372,9 @@ the image." (define build ;; Guile-JSON is required by (guix docker). (with-extensions (list json) - (with-imported-modules `(,@(source-module-closure '((guix docker)) + (with-imported-modules `(,@(source-module-closure '((guix docker) + (guix build store-copy)) #:select? not-config?) - (guix build store-copy) ((guix config) => ,config)) #~(begin (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) @@ -352,8 +382,9 @@ the image." (setenv "PATH" (string-append #$archiver "/bin")) (build-docker-image #$output - (call-with-input-file "profile" - read-reference-graph) + (map store-info-item + (call-with-input-file "profile" + read-reference-graph)) #$profile #:system (or #$target (utsname:machine (uname))) #:symlinks '#$symlinks diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4f519e6f33..29829f52c8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -64,46 +64,6 @@ ;;; Profiles. ;;; -(define %user-profile-directory - (and=> (getenv "HOME") - (cut string-append <> "/.guix-profile"))) - -(define %profile-directory - (string-append %state-directory "/profiles/" - (or (and=> (or (getenv "USER") - (getenv "LOGNAME")) - (cut string-append "per-user/" <>)) - "default"))) - -(define %current-profile - ;; Call it `guix-profile', not `profile', to allow Guix profiles to - ;; coexist with Nix profiles. - (string-append %profile-directory "/guix-profile")) - -(define (canonicalize-profile profile) - "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise -return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if -'-p' was omitted." ; see <http://bugs.gnu.org/17939> - - ;; Trim trailing slashes so that the basename comparison below works as - ;; intended. - (let ((profile (string-trim-right profile #\/))) - (if (and %user-profile-directory - (string=? (canonicalize-path (dirname profile)) - (dirname %user-profile-directory)) - (string=? (basename profile) (basename %user-profile-directory))) - %current-profile - profile))) - -(define (user-friendly-profile profile) - "Return either ~/.guix-profile if that's what PROFILE refers to, directly or -indirectly, or PROFILE." - (if (and %user-profile-directory - (false-if-exception - (string=? (readlink %user-profile-directory) profile))) - %user-profile-directory - profile)) - (define (ensure-default-profile) "Ensure the default profile symlink and directory exist and are writable." diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 64c2196e03..7202e3cc16 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. @@ -25,10 +25,15 @@ #:use-module (guix config) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix profiles) #:use-module (guix gexp) #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix scripts build) + #:autoload (guix self) (whole-package) + #:autoload (gnu packages ssh) (guile-ssh) + #:autoload (gnu packages tls) (gnutls) + #:use-module ((guix scripts package) #:select (build-and-use-profile)) #:use-module ((guix build utils) #:select (with-directory-excursion delete-file-recursively)) #:use-module ((guix build download) @@ -40,6 +45,7 @@ #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-pull)) @@ -105,6 +111,9 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " --branch=BRANCH download the tip of the specified BRANCH")) (display (G_ " + -l, --list-generations[=PATTERN] + list generations matching PATTERN")) + (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) (show-build-options-help) @@ -120,6 +129,10 @@ Download and deploy the latest version of Guix.\n")) (cons* (option '("verbose") #f #f (lambda (opt name arg result) (alist-cons 'verbose? #t result))) + (option '(#\l "list-generations") #f #t + (lambda (opt name arg result) + (cons `(query list-generations ,(or arg "")) + result))) (option '("url") #t #f (lambda (opt name arg result) (alist-cons 'repository-url arg @@ -158,6 +171,12 @@ Download and deploy the latest version of Guix.\n")) ;; a makefile, and, similarly, is intended to always keep this name. "build-aux/build-self.scm") +(define %pull-version + ;; This is the version of the 'guix pull' protocol. It specifies what's + ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd + ;; place a set of compiled Guile modules in ~/.config/guix/latest. + 1) + (define* (build-from-source source #:key verbose? commit) "Return a derivation to build Guix from SOURCE, using the self-build script @@ -170,35 +189,62 @@ contained therein. Use COMMIT as the version string." (build (primitive-load script))) ;; BUILD must be a monadic procedure of at least one argument: the source ;; tree. - (build source #:verbose? verbose? #:version commit))) + ;; + ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In the + ;; future we'll fall back to a previous version of the protocol when that + ;; happens. + (build source #:verbose? verbose? #:version commit + #:pull-version %pull-version))) + +(define (whole-package-for-legacy name modules) + "Return a full-blown Guix package for MODULES, a derivation that builds Guix +modules in the old ~/.config/guix/latest style." + (whole-package name modules + + ;; In the "old style", %SELF-BUILD-FILE would simply return a + ;; derivation that builds modules. We have to infer what the + ;; dependencies of these modules were. + (list guile-json guile-git guile-bytestructures + guile-ssh gnutls))) + +(define* (derivation->manifest-entry drv + #:key url branch commit) + "Return a manifest entry for DRV, which represents Guix at COMMIT. Record +URL, BRANCH, and COMMIT as a property in the manifest entry." + (mbegin %store-monad + (what-to-build (list drv)) + (built-derivations (list drv)) + (let ((out (derivation->output-path drv))) + (return (manifest-entry + (name "guix") + (version (string-take commit 7)) + (item (if (file-exists? (string-append out "/bin/guix")) + drv + (whole-package-for-legacy (string-append name "-" + version) + drv))) + (properties + `((source (repository + (version 0) + (url ,url) + (branch ,branch) + (commit ,commit)))))))))) (define* (build-and-install source config-dir - #:key verbose? commit) + #:key verbose? url branch commit) "Build the tool from SOURCE, and install it in CONFIG-DIR." - (mlet* %store-monad ((source (build-from-source source - #:commit commit - #:verbose? verbose?)) - (source-dir -> (derivation->output-path source)) - (to-do? (what-to-build (list source))) - (built? (built-derivations (list source)))) - ;; Always update the 'latest' symlink, regardless of whether SOURCE was - ;; already built or not. - (if built? - (mlet* %store-monad - ((latest -> (string-append config-dir "/latest")) - (done (indirect-root-added latest))) - (if (and (file-exists? latest) - (string=? (readlink latest) source-dir)) - (begin - (display (G_ "Guix already up to date\n")) - (return #t)) - (begin - (switch-symlinks latest source-dir) - (format #t - (G_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) - (return #t)))) - (leave (G_ "failed to update Guix, check the build log~%"))))) + (define update-profile + (store-lift build-and-use-profile)) + + (mlet* %store-monad ((drv (build-from-source source + #:commit commit + #:verbose? verbose?)) + (entry (derivation->manifest-entry drv + #:url url + #:branch branch + #:commit commit))) + (update-profile (string-append config-dir "/current") + (manifest (list entry))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -236,6 +282,66 @@ certificates~%")) (report-git-error err)))) +;;; +;;; Queries. +;;; + +(define (display-profile-content profile number) + "Display the packages in PROFILE, generation NUMBER, in a human-readable +way and displaying details about the channel's source code." + (for-each (lambda (entry) + (format #t " ~a ~a~%" + (manifest-entry-name entry) + (manifest-entry-version entry)) + (match (assq 'source (manifest-entry-properties entry)) + (('source ('repository ('version 0) + ('url url) + ('branch branch) + ('commit commit) + _ ...)) + (format #t (G_ " repository URL: ~a~%") url) + (when branch + (format #t (G_ " branch: ~a~%") branch)) + (format #t (G_ " commit: ~a~%") commit)) + (_ #f))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries + (profile-manifest (generation-file-name profile number)))))) + +(define (process-query opts) + "Process any query specified by OPTS." + (define profile + (string-append (config-directory) "/current")) + + (match (assoc-ref opts 'query) + (('list-generations pattern) + (define (list-generation display-function number) + (unless (zero? number) + (display-generation profile number) + (display-function profile number) + (newline))) + + (leave-on-EPIPE + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (for-each (lambda (generation) + (list-generation display-profile-content generation)) + (profile-generations profile))) + ((matching-generations pattern profile) + => + (match-lambda + (() + (exit 1)) + ((numbers ...) + (for-each (lambda (generation) + (list-generation display-profile-content generation)) + numbers))))))))) + + (define (guix-pull . args) (define (use-le-certs? url) (string-prefix? "https://git.savannah.gnu.org/" url)) @@ -249,38 +355,48 @@ certificates~%")) (cache (string-append (cache-directory) "/pull"))) (ensure-guile-git!) - (unless (assoc-ref opts 'dry-run?) ;XXX: not very useful - (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line store opts) - - ;; For reproducibility, always refer to the LE certificates when we - ;; know we're talking to Savannah. - (when (use-le-certs? url) - (honor-lets-encrypt-certificates! store)) - - (format (current-error-port) - (G_ "Updating from Git repository at '~a'...~%") - url) - - (let-values (((checkout commit) - (latest-repository-commit store url - #:ref ref - #:cache-directory cache))) - - (format (current-error-port) - (G_ "Building from Git commit ~a...~%") - commit) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install checkout (config-directory) - #:commit commit - #:verbose? - (assoc-ref opts 'verbose?)))))))))))) + (cond ((assoc-ref opts 'query) + (process-query opts)) + ((assoc-ref opts 'dry-run?) + #t) ;XXX: not very useful + (else + (with-store store + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (set-build-options-from-command-line store opts) + + ;; For reproducibility, always refer to the LE certificates + ;; when we know we're talking to Savannah. + (when (use-le-certs? url) + (honor-lets-encrypt-certificates! store)) + + (format (current-error-port) + (G_ "Updating from Git repository at '~a'...~%") + url) + + (let-values (((checkout commit) + (latest-repository-commit store url + #:ref ref + #:cache-directory + cache))) + + (format (current-error-port) + (G_ "Building from Git commit ~a...~%") + commit) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + (build-and-install checkout (config-directory) + #:url url + #:branch (match ref + (('branch . branch) + branch) + (_ #f)) + #:commit commit + #:verbose? + (assoc-ref opts 'verbose?))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8e1119fb49..d0beacc8ea 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -613,10 +613,10 @@ if file doesn't exist, and the narinfo otherwise." (let ((done 0) (total (length paths))) (lambda () - (display #\cr (current-error-port)) + (display "\r\x1b[K" (current-error-port)) ;erase current line (force-output (current-error-port)) (format (current-error-port) - (G_ "updating list of substitutes from '~a'... ~5,1f%") + (G_ "updating substitutes from '~a'... ~5,1f%") url (* 100. (/ done total))) (set! done (+ 1 done))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 766cab1aad..14aedceac1 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +24,7 @@ #:use-module (guix config) #:use-module (guix ui) #:use-module (guix store) + #:autoload (guix store database) (register-path) #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) @@ -197,7 +199,7 @@ TARGET, and register them." bootcfg bootcfg-file) "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to directory TARGET. TARGET must be an absolute directory name since that's what -'guix-register' expects. +'register-path' expects. When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG." (define (maybe-copy to-copy) @@ -351,8 +353,8 @@ bring the system down." #:optional (profile %system-profile)) "Make a new generation of PROFILE pointing to the directory of OS, switch to it atomically, and then run OS's activation script." - (mlet* %store-monad ((drv (operating-system-derivation os)) - (script (operating-system-activation-script os))) + (mlet* %store-monad ((drv (operating-system-derivation os)) + (script (lower-object (operating-system-activation-script os)))) (let* ((system (derivation->output-path drv)) (number (+ 1 (generation-number profile))) (generation (generation-file-name profile number))) @@ -550,10 +552,26 @@ list of services." ;; TRANSLATORS: Please preserve the two-space indentation. (format #t (G_ " label: ~a~%") label) (format #t (G_ " bootloader: ~a~%") bootloader-name) - (format #t (G_ " root device: ~a~%") - (if (uuid? root-device) - (uuid->string root-device) - root-device)) + + ;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must + ;; be preserved. They denote conditionals, such that the result will + ;; look like: + ;; root device: UUID: 12345-678 + ;; or: + ;; root device: label: "my-root" + ;; or just: + ;; root device: /dev/sda3 + (format #t (G_ " root device: ~[UUID: ~a~;label: ~s~;~a~]~%") + (cond ((uuid? root-device) 0) + ((file-system-label? root-device) 1) + (else 2)) + (cond ((uuid? root-device) + (uuid->string root-device)) + ((file-system-label? root-device) + (file-system-label->string root-device)) + (else + root-device))) + (format #t (G_ " kernel: ~a~%") kernel)))) (define* (list-generations pattern #:optional (profile %system-profile)) @@ -740,7 +758,7 @@ checking this by themselves in their 'check' procedure." ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for ;; a discussion. (define latest - (string-append (config-directory) "/latest")) + (string-append (config-directory) "/current")) (unless (file-exists? latest) (warning (G_ "~a not found: 'guix pull' was never run~%") latest) diff --git a/guix/self.scm b/guix/self.scm index 3acfac6f80..89c5428039 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -26,14 +26,14 @@ #:use-module (guix discovery) #:use-module (guix packages) #:use-module (guix sets) - #:use-module (guix utils) #:use-module (guix modules) - #:use-module (guix build utils) + #:use-module ((guix build utils) #:select (find-files)) #:use-module ((guix build compile) #:select (%lightweight-optimizations)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:export (make-config.scm + whole-package ;for internal use in 'guix pull' compiled-guix guix-derivation reload-guix)) @@ -83,17 +83,17 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) + ("gnutls" (ref '(gnu packages tls) 'gnutls)) ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) ("zlib" (ref '(gnu packages compression) 'zlib)) ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) - ("guix" (ref '(gnu packages package-management) - 'guix-register)) ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) ;; XXX: No "guile2.0-sqlite3". + ("guile2.0-gnutls" (ref '(gnu packages tls) 'gnutls/guile-2.0)) (_ #f)))) ;no such package @@ -192,7 +192,245 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (file-name->module-name (string-drop file prefix))) (scheme-files (string-append directory "/" sub-directory))))) +(define* (sub-directory item sub-directory) + "Return SUB-DIRECTORY within ITEM, which may be a file name or a file-like +object." + (match item + ((? string?) + ;; This is the optimal case: we return a new "source". Thus, a + ;; derivation that depends on this sub-directory does not depend on ITEM + ;; itself. + (local-file (string-append item "/" sub-directory) + #:recursive? #t)) + ;; TODO: Add 'local-file?' case. + (_ + ;; In this case, anything that refers to the result also depends on ITEM, + ;; which isn't great. + (file-append item "/" sub-directory)))) + +(define* (locale-data source domain + #:optional (directory domain)) + "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to +DOMAIN, a gettext domain." + (define gettext + (module-ref (resolve-interface '(gnu packages gettext)) + 'gettext-minimal)) + + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-26) + (ice-9 match) (ice-9 ftw)) + + (define po-directory + #+(sub-directory source (string-append "po/" directory))) + + (define (compile language) + (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/" + #$domain ".mo"))) + (mkdir-p (dirname gmo)) + (invoke #+(file-append gettext "/bin/msgfmt") + "-c" "--statistics" "--verbose" + "-o" gmo + (string-append po-directory "/" language ".po")))) + + (define (linguas) + ;; Return the list of languages. Note: don't read 'LINGUAS' + ;; because it contains things like 'en@boldquot' that do not have + ;; a corresponding .po file. + (map (cut basename <> ".po") + (scandir po-directory + (cut string-suffix? ".po" <>)))) + + (for-each compile (linguas))))) + + (computed-file (string-append "guix-locale-" domain) + build)) + +(define (info-manual source) + "Return the Info manual built from SOURCE." + (define texinfo + (module-ref (resolve-interface '(gnu packages texinfo)) + 'texinfo)) + + (define graphviz + (module-ref (resolve-interface '(gnu packages graphviz)) + 'graphviz)) + + (define documentation + (sub-directory source "doc")) + + (define examples + (sub-directory source "gnu/system/examples")) + + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (mkdir #$output) + + ;; Create 'version.texi'. + ;; XXX: Can we use a more meaningful version string yet one that + ;; doesn't change at each commit? + (call-with-output-file "version.texi" + (lambda (port) + (let ((version "0.0-git)")) + (format port " +@set UPDATED 1 January 1970 +@set UPDATED-MONTH January 1970 +@set EDITION ~a +@set VERSION ~a\n" version version)))) + + ;; Copy configuration templates that the manual includes. + (for-each (lambda (template) + (copy-file template + (string-append + "os-config-" + (basename template ".tmpl") + ".texi"))) + (find-files #$examples "\\.tmpl$")) + + ;; Build graphs. + (mkdir-p (string-append #$output "/images")) + (for-each (lambda (dot-file) + (invoke #+(file-append graphviz "/bin/dot") + "-Tpng" "-Gratio=.9" "-Gnodesep=.005" + "-Granksep=.00005" "-Nfontsize=9" + "-Nheight=.1" "-Nwidth=.1" + "-o" (string-append #$output "/images/" + (basename dot-file ".dot") + ".png") + dot-file)) + (find-files (string-append #$documentation "/images") + "\\.dot$")) + + ;; Copy other PNGs. + (for-each (lambda (png-file) + (install-file png-file + (string-append #$output "/images"))) + (find-files (string-append #$documentation "/images") + "\\.png$")) + + ;; Finally build the manual. Copy it the Texinfo files to $PWD and + ;; add a symlink to the 'images' directory so that 'makeinfo' can + ;; see those images and produce image references in the Info output. + (copy-recursively #$documentation "." + #:log (%make-void-port "w")) + (delete-file-recursively "images") + (symlink (string-append #$output "/images") "images") + + (for-each (lambda (texi) + (unless (string=? "guix.texi" texi) + ;; Create 'version-LL.texi'. + (let* ((base (basename texi ".texi")) + (dot (string-index base #\.)) + (tag (string-drop base (+ 1 dot)))) + (symlink "version.texi" + (string-append "version-" tag ".texi")))) + + (invoke #+(file-append texinfo "/bin/makeinfo") + texi "-I" #$documentation + "-I" "." + "-o" (string-append #$output "/" + (basename texi ".texi") + ".info"))) + (cons "guix.texi" + (find-files "." "^guix\\.[a-z]{2}\\.texi$")))))) + + (computed-file "guix-manual" build)) + +(define* (guix-command modules #:optional compiled-modules + #:key source (dependencies '()) + (guile-version (effective-version))) + "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its +load path." + (program-file "guix-command" + #~(begin + (set! %load-path + (append '#$(map (lambda (package) + (file-append package + "/share/guile/site/" + guile-version)) + dependencies) + %load-path)) + + (set! %load-compiled-path + (append '#$(map (lambda (package) + (file-append package "/lib/guile/" + guile-version + "/site-ccache")) + dependencies) + %load-compiled-path)) + + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons (or #$compiled-modules #$modules) + %load-compiled-path)) + + (let ((guix-main (module-ref (resolve-interface '(guix ui)) + 'guix-main))) + #$(if source + #~(begin + (bindtextdomain "guix" + #$(locale-data source "guix")) + (bindtextdomain "guix-packages" + #$(locale-data source + "guix-packages" + "packages"))) + #t) + + ;; XXX: It would be more convenient to change it to: + ;; (exit (apply guix-main (command-line))) + (apply guix-main (command-line)))))) + +(define* (whole-package name modules dependencies + #:key + (guile-version (effective-version)) + compiled-modules + info daemon + (command (guix-command modules + #:dependencies dependencies + #:guile-version guile-version))) + "Return the whole Guix package NAME that uses MODULES, a derivation of all +the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the +'guix' program to use; INFO is the Info manual. When COMPILED-MODULES is +true, it is linked as 'lib/guile/X.Y/site-ccache'; otherwise, .go files are +assumed to be part of MODULES." + (computed-file name + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/bin")) + (symlink #$command + (string-append #$output "/bin/guix")) + + (when #$daemon + (symlink (string-append #$daemon "/bin/guix-daemon") + (string-append #$output "/bin/guix-daemon"))) + + (let ((modules (string-append #$output + "/share/guile/site/" + (effective-version))) + (info #$info)) + (mkdir-p (dirname modules)) + (symlink #$modules modules) + (when info + (symlink #$info + (string-append #$output + "/share/info")))) + + ;; Object files. + (when #$compiled-modules + (let ((modules (string-append #$output "/lib/guile/" + (effective-version) + "/site-ccache"))) + (mkdir-p (dirname modules)) + (symlink #$compiled-modules modules))))))) + (define* (compiled-guix source #:key (version %guix-version) + (pull-version 1) (name (string-append "guix-" version)) (guile-version (effective-version)) (guile-for-build (guile-for-build guile-version)) @@ -223,11 +461,16 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." "guile-sqlite3" "guile2.0-sqlite3")) + (define gnutls + (package-for-guile guile-version + "gnutls" "guile2.0-gnutls")) + (define dependencies (match (append-map (lambda (package) (cons (list "x" package) (package-transitive-propagated-inputs package))) - (list guile-git guile-json guile-ssh guile-sqlite3)) + (list gnutls guile-git guile-json + guile-ssh guile-sqlite3)) (((labels packages _ ...) ...) packages))) @@ -259,7 +502,9 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." ;; but we don't need to compile it; not compiling it allows ;; us to avoid an extra dependency on guile-gdbm-ffi. #:extra-files - `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm"))) + `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm")) + ("guix/store/schema.sql" + ,(local-file "../guix/store/schema.sql"))) #:guile-for-build guile-for-build)) @@ -340,7 +585,6 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." #:gzip gzip #:bzip2 bzip2 #:xz xz - #:guix guix #:package-name %guix-package-name #:package-version @@ -351,32 +595,65 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." %guix-home-page-url))) #:guile-for-build guile-for-build)) - (directory-union name - (append-map (lambda (node) - (list (node-source node) - (node-compiled node))) - - ;; Note: *CONFIG* comes first so that it - ;; overrides the (guix config) module that - ;; comes with *CORE-MODULES*. - (list *config* - *cli-modules* - *system-modules* - *package-modules* - *core-package-modules* - *extra-modules* - *core-modules*)) - - ;; Silently choose the first entry upon collision so that - ;; we choose *CONFIG*. - #:resolve-collision 'first - - ;; When we do (add-to-store "utils.scm"), "utils.scm" must - ;; be a regular file, not a symlink. Thus, arrange so that - ;; regular files appear as regular files in the final - ;; output. - #:copy? #t - #:quiet? #t)) + (define (built-modules node-subset) + (directory-union (string-append name "-modules") + (append-map node-subset + + ;; Note: *CONFIG* comes first so that it + ;; overrides the (guix config) module that + ;; comes with *CORE-MODULES*. + (list *config* + *cli-modules* + *system-modules* + *package-modules* + *core-package-modules* + *extra-modules* + *core-modules*)) + + ;; Silently choose the first entry upon collision so that + ;; we choose *CONFIG*. + #:resolve-collision 'first + + ;; When we do (add-to-store "utils.scm"), "utils.scm" must + ;; be a regular file, not a symlink. Thus, arrange so that + ;; regular files appear as regular files in the final + ;; output. + #:copy? #t + #:quiet? #t)) + + ;; Version 0 of 'guix pull' meant we'd just return Scheme modules. + ;; Version 1 is when we return the full package. + (cond ((= 1 pull-version) + ;; The whole package, with a standard file hierarchy. + (let* ((modules (built-modules (compose list node-source))) + (compiled (built-modules (compose list node-compiled))) + (command (guix-command modules compiled + #:source source + #:dependencies dependencies + #:guile-version guile-version))) + (whole-package name modules dependencies + #:compiled-modules compiled + #:command command + + ;; Include 'guix-daemon'. XXX: Here we inject an + ;; older snapshot of guix-daemon, but that's a good + ;; enough approximation for now. + #:daemon (module-ref (resolve-interface + '(gnu packages + package-management)) + 'guix-daemon) + + #:info (info-manual source) + #:guile-version guile-version))) + ((= 0 pull-version) + ;; Legacy 'guix pull': return the .scm and .go files as one + ;; directory. + (built-modules (lambda (node) + (list (node-source node) + (node-compiled node))))) + (else + ;; Unsupported 'guix pull' version. + #f))) ;;; @@ -385,8 +662,7 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (define %dependency-variables ;; (guix config) variables corresponding to dependencies. - '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate - %sbindir %guix-register-program)) + '(%libgcrypt %libz %xz %gzip %bzip2)) (define %persona-variables ;; (guix config) variables that define Guix's persona. @@ -396,19 +672,16 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." %guix-home-page-url)) (define %config-variables - ;; (guix config) variables corresponding to Guix configuration (storedir, - ;; localstatedir, etc.) - (sort (filter pair? - (module-map (lambda (name var) - (and (not (memq name %dependency-variables)) - (not (memq name %persona-variables)) - (cons name (variable-ref var)))) - (resolve-interface '(guix config)))) - (lambda (name+value1 name+value2) - (string<? (symbol->string (car name+value1)) - (symbol->string (car name+value2)))))) - -(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 guix + ;; (guix config) variables corresponding to Guix configuration. + (letrec-syntax ((variables (syntax-rules () + ((_) + '()) + ((_ variable rest ...) + (cons `(variable . ,variable) + (variables rest ...)))))) + (variables %localstatedir %storedir %sysconfdir %system))) + +(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -424,36 +697,46 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." %guix-version %guix-bug-report-address %guix-home-page-url - %sbindir - %guix-register-program + %store-directory + %state-directory + %store-database-directory + %config-directory %libgcrypt %libz %gzip %bzip2 - %xz - %nix-instantiate)) + %xz)) #$@(map (match-lambda ((name . value) #~(define-public #$name #$value))) %config-variables) + (define %store-directory + (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) + %storedir)) + + (define %state-directory + ;; This must match `NIX_STATE_DIR' as defined in + ;; `nix/local.mk'. + (or (getenv "NIX_STATE_DIR") + (string-append %localstatedir "/guix"))) + + (define %store-database-directory + (or (getenv "NIX_DB_DIR") + (string-append %state-directory "/db"))) + + (define %config-directory + ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as + ;; defined in `nix/local.mk'. + (or (getenv "GUIX_CONFIGURATION_DIRECTORY") + (string-append %sysconfdir "/guix"))) + (define %guix-package-name #$package-name) (define %guix-version #$package-version) (define %guix-bug-report-address #$bug-report-address) (define %guix-home-page-url #$home-page-url) - (define %sbindir - ;; This is used to define '%guix-register-program'. - ;; TODO: Use a derivation that builds nothing but the - ;; C++ part. - #+(and guix (file-append guix "/sbin"))) - - (define %guix-register-program - (or (getenv "GUIX_REGISTER") - (and %sbindir - (string-append %sbindir "/guix-register")))) - (define %gzip #+(and gzip (file-append gzip "/bin/gzip"))) (define %bzip2 @@ -466,13 +749,10 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (file-append libgcrypt "/lib/libgcrypt"))) (define %libz #+(and zlib - (file-append zlib "/lib/libz"))) - - (define %nix-instantiate ;for (guix import snix) - "nix-instantiate")) + (file-append zlib "/lib/libz")))) ;; Guile 2.0 *requires* the 'define-module' to be at the - ;; top-level or it 'toplevel-ref' in the resulting .go file are + ;; top-level or the 'toplevel-ref' in the resulting .go file are ;; made relative to a nonexistent anonymous module. #:splice? #t)) @@ -630,9 +910,12 @@ running Guile." 'guile-2.0)))) (define* (guix-derivation source version - #:optional (guile-version (effective-version))) + #:optional (guile-version (effective-version)) + #:key (pull-version 0)) "Return, as a monadic value, the derivation to build the Guix from SOURCE -for GUILE-VERSION. Use VERSION as the version string." +for GUILE-VERSION. Use VERSION as the version string. PULL-VERSION specifies +the version of the 'guix pull' protocol. Return #f if this PULL-VERSION value +is not supported." (define (shorten version) (if (and (string-every char-set:hex-digit version) (> (string-length version) 9)) @@ -644,11 +927,15 @@ for GUILE-VERSION. Use VERSION as the version string." (mbegin %store-monad (set-guile-for-build guile) - (lower-object (compiled-guix source - #:version version - #:name (string-append "guix-" - (shorten version)) - #:guile-version (match guile-version - ("2.2.2" "2.2") - (version version)) - #:guile-for-build guile)))) + (let ((guix (compiled-guix source + #:version version + #:name (string-append "guix-" + (shorten version)) + #:pull-version pull-version + #:guile-version (match guile-version + ("2.2.2" "2.2") + (version version)) + #:guile-for-build guile))) + (if guix + (lower-object guix) + (return #f))))) diff --git a/guix/store.scm b/guix/store.scm index 6742611c6f..3bf56573bf 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -65,6 +65,7 @@ build-mode open-connection + port->connection close-connection with-store set-build-options @@ -122,8 +123,6 @@ current-build-output-port - register-path - %store-monad store-bind store-return @@ -519,6 +518,23 @@ for this connection will be pinned. Return a server object." (or done? (process-stderr conn))) conn))))))))) +(define* (port->connection port + #:key (version %protocol-version)) + "Assimilate PORT, an input/output port, and return a connection to the +daemon, assuming the given protocol VERSION. + +Warning: this procedure assumes that the initial handshake with the daemon has +already taken place on PORT and that we're just continuing on this established +connection. Use with care." + (let-values (((output flush) + (buffering-output-port port (make-bytevector 8192)))) + (%make-nix-server port + (protocol-major version) + (protocol-minor version) + output flush + (make-hash-table 100) + (make-hash-table 100)))) + (define (write-buffered-output server) "Flush SERVER's output port." (force-output (nix-server-output-port server)) @@ -1301,33 +1317,6 @@ The result is always the empty list unless the daemon was started with This makes sense only when the daemon was started with '--cache-failures'." boolean) -(define* (register-path path - #:key (references '()) deriver prefix - state-directory) - "Register PATH as a valid store file, with REFERENCES as its list of -references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is -not #f, it must be the name of the directory containing the new store to -initialize; if STATE-DIRECTORY is not #f, it must be a string containing the -absolute file name to the state directory of the store being initialized. -Return #t on success. - -Use with care as it directly modifies the store! This is primarily meant to -be used internally by the daemon's build hook." - ;; Currently this is implemented by calling out to the fine C++ blob. - (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program - `(,@(if prefix - `("--prefix" ,prefix) - '()) - ,@(if state-directory - `("--state-directory" ,state-directory) - '()))))) - (and pipe - (begin - (format pipe "~a~%~a~%~a~%" - path (or deriver "") (length references)) - (for-each (cut format pipe "~a~%" <>) references) - (zero? (close-pipe pipe)))))) - ;;; ;;; Store monad. diff --git a/guix/store/database.scm b/guix/store/database.scm index 3623c0e7a0..05b2ba6c3f 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -24,30 +24,76 @@ #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix build syscalls) + #:use-module ((guix build utils) + #:select (mkdir-p executable-file?)) + #:use-module (guix build store-copy) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (rnrs io ports) #:use-module (ice-9 match) - #:export (sqlite-register + #:use-module (system foreign) + #:export (sql-schema + with-database + sqlite-register register-path + register-items + %epoch reset-timestamps)) ;;; Code for working with the store database directly. +(define sql-schema + ;; Name of the file containing the SQL scheme or #f. + (make-parameter #f)) -(define-syntax-rule (with-database file db exp ...) - "Open DB from FILE and close it when the dynamic extent of EXP... is left." - (let ((db (sqlite-open file))) +(define sqlite-exec + ;; XXX: This is was missing from guile-sqlite3 until + ;; <https://notabug.org/civodul/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>. + (let ((exec (pointer->procedure + int + (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) + '(* * * * *)))) + (lambda (db text) + (let ((ret (exec ((@@ (sqlite3) db-pointer) db) + (string->pointer text) + %null-pointer %null-pointer %null-pointer))) + (unless (zero? ret) + ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret)))))) + +(define (initialize-database db) + "Initializing DB, an empty database, by creating all the tables and indexes +as specified by SQL-SCHEMA." + (define schema + (or (sql-schema) + (search-path %load-path "guix/store/schema.sql"))) + + (sqlite-exec db (call-with-input-file schema get-string-all))) + +(define (call-with-database file proc) + "Pass PROC a database record corresponding to FILE. If FILE doesn't exist, +create it and initialize it as a new database." + (let ((new? (not (file-exists? file))) + (db (sqlite-open file))) (dynamic-wind noop (lambda () - exp ...) + (when new? + (initialize-database db)) + (proc db)) (lambda () (sqlite-close db))))) +(define-syntax-rule (with-database file db exp ...) + "Open DB from FILE and close it when the dynamic extent of EXP... is left. +If FILE doesn't exist, create it and initialize it as a new database." + (call-with-database file (lambda (db) exp ...))) + (define (last-insert-row-id db) ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. ;; Work around that. (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" - #:cache? #t)) + #:cache? #t)) (result (sqlite-fold cons '() stmt))) (sqlite-finalize stmt) (match result @@ -85,7 +131,7 @@ of course. Returns the row id of the row that was modified or inserted." (if id (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) (sqlite-bind-arguments stmt #:id id - #:path path #:deriver deriver + #:deriver deriver #:hash hash #:size nar-size #:time time) (sqlite-fold cons '() stmt) (sqlite-finalize stmt) @@ -99,13 +145,11 @@ of course. Returns the row id of the row that was modified or inserted." (last-insert-row-id db))))) (define add-reference-sql - "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id -FROM ValidPaths WHERE path = :reference") + "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);") (define (add-references db referrer references) "REFERRER is the id of the referring store item, REFERENCES is a list -containing store items being referred to. Note that all of the store items in -REFERENCES must already be registered." +ids of items referred to." (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) (for-each (lambda (reference) (sqlite-reset stmt) @@ -116,37 +160,41 @@ REFERENCES must already be registered." (last-insert-row-id db)) references))) -;; XXX figure out caching of statement and database objects... later -(define* (sqlite-register #:key db-file path (references '()) - deriver hash nar-size) - "Registers this stuff in a database specified by DB-FILE. PATH is the string -path of some store item, REFERENCES is a list of string paths which the store -item PATH refers to (they need to be already registered!), DERIVER is a string -path of the derivation that created the store item PATH, HASH is the -base16-encoded sha256 hash of the store item denoted by PATH (prefixed with -\"sha256:\") after being converted to nar form, and nar-size is the size in -bytes of the store item denoted by PATH after being converted to nar form." - (with-database db-file db - (let ((id (update-or-insert db #:path path - #:deriver deriver - #:hash hash - #:nar-size nar-size - #:time (time-second (current-time time-utc))))) - (add-references db id references)))) +(define* (sqlite-register db #:key path (references '()) + deriver hash nar-size time) + "Registers this stuff in DB. PATH is the store item to register and +REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv' +that produced PATH, HASH is the base16-encoded Nix sha256 hash of +PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after +being converted to nar form. TIME is the registration time to be recorded in +the database or #f, meaning \"right now\". + +Every store item in REFERENCES must already be registered." + (let ((id (update-or-insert db #:path path + #:deriver deriver + #:hash hash + #:nar-size nar-size + #:time (time-second + (or time + (current-time time-utc)))))) + ;; Call 'path-id' on each of REFERENCES. This ensures we get a + ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. + (add-references db id + (map (cut path-id db <>) references)))) ;;; ;;; High-level interface. ;;; -;; TODO: Factorize with that in (gnu build install). (define (reset-timestamps file) "Reset the modification time on FILE and on all the files it contains, if -it's a directory." +it's a directory. While at it, canonicalize file permissions." (let loop ((file file) (type (stat:type (lstat file)))) (case type ((directory) + (chmod file #o555) (utime file 0 0 0 0) (let ((parent file)) (for-each (match-lambda @@ -165,24 +213,14 @@ it's a directory." ;; symlinks. #f) (else + (chmod file (if (executable-file? file) #o555 #o444)) (utime file 0 0 0 0))))) -;; TODO: make this canonicalize store items that are registered. This involves -;; setting permissions and timestamps, I think. Also, run a "deduplication -;; pass", whatever that involves. Also, handle databases not existing yet -;; (what should the default behavior be? Figuring out how the C++ stuff -;; currently does it sounds like a lot of grepping for global -;; variables...). Also, return #t on success like the documentation says we -;; should. - (define* (register-path path #:key (references '()) deriver prefix - state-directory (deduplicate? #t)) - ;; Priority for options: first what is given, then environment variables, - ;; then defaults. %state-directory, %store-directory, and - ;; %store-database-directory already handle the "environment variables / - ;; defaults" question, so we only need to choose between what is given and - ;; those. + state-directory (deduplicate? #t) + (reset-timestamps? #t) + (schema (sql-schema))) "Register PATH as a valid store file, with REFERENCES as its list of references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is given, it must be the name of the directory containing the new store to @@ -192,43 +230,76 @@ Return #t on success. Use with care as it directly modifies the store! This is primarily meant to be used internally by the daemon's build hook." - (let* ((db-dir (cond - (state-directory - (string-append state-directory "/db")) - (prefix - ;; If prefix is specified, the value of NIX_STATE_DIR - ;; (which affects %state-directory) isn't supposed to - ;; affect db-dir, only the compile-time-customized - ;; default should. - (string-append prefix %localstatedir "/guix/db")) - (else - %store-database-directory))) - (store-dir (if prefix - ;; same situation as above - (string-append prefix %storedir) - %store-directory)) - (to-register (if prefix - (string-append %storedir "/" (basename path)) - ;; note: we assume here that if path is, for - ;; example, /foo/bar/gnu/store/thing.txt and prefix - ;; isn't given, then an environment variable has - ;; been used to change the store directory to - ;; /foo/bar/gnu/store, since otherwise real-path - ;; would end up being /gnu/store/thing.txt, which is - ;; probably not the right file in this case. - path)) - (real-path (string-append store-dir "/" (basename path)))) - (let-values (((hash nar-size) - (nar-sha256 real-path))) - (reset-timestamps real-path) - (sqlite-register - #:db-file (string-append db-dir "/db.sqlite") - #:path to-register - #:references references - #:deriver deriver - #:hash (string-append "sha256:" - (bytevector->base16-string hash)) - #:nar-size nar-size) + (register-items (list (store-info path deriver references)) + #:prefix prefix #:state-directory state-directory + #:deduplicate? deduplicate? + #:reset-timestamps? reset-timestamps? + #:schema schema)) +(define %epoch + ;; When it all began. + (make-time time-utc 0 1)) + +(define* (register-items items + #:key prefix state-directory + (deduplicate? #t) + (reset-timestamps? #t) + registration-time + (schema (sql-schema))) + "Register all of ITEMS, a list of <store-info> records as returned by +'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS +must be in topological order (with leaves first.) If the database is +initially empty, apply SCHEMA to initialize it. REGISTRATION-TIME must be the +registration time to be recorded in the database; #f means \"now\"." + + ;; Priority for options: first what is given, then environment variables, + ;; then defaults. %state-directory, %store-directory, and + ;; %store-database-directory already handle the "environment variables / + ;; defaults" question, so we only need to choose between what is given and + ;; those. + + (define db-dir + (cond (state-directory + (string-append state-directory "/db")) + (prefix + (string-append prefix %localstatedir "/guix/db")) + (else + %store-database-directory))) + + (define store-dir + (if prefix + (string-append prefix %storedir) + %store-directory)) + + (define (register db item) + (define to-register + (if prefix + (string-append %storedir "/" (basename (store-info-item item))) + ;; note: we assume here that if path is, for example, + ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an + ;; environment variable has been used to change the store directory + ;; to /foo/bar/gnu/store, since otherwise real-path would end up + ;; being /gnu/store/thing.txt, which is probably not the right file + ;; in this case. + (store-info-item item))) + + (define real-file-name + (string-append store-dir "/" (basename (store-info-item item)))) + + (let-values (((hash nar-size) (nar-sha256 real-file-name))) + (when reset-timestamps? + (reset-timestamps real-file-name)) + (sqlite-register db #:path to-register + #:references (store-info-references item) + #:deriver (store-info-deriver item) + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size + #:time registration-time) (when deduplicate? - (deduplicate real-path hash #:store store-dir))))) + (deduplicate real-file-name hash #:store store-dir)))) + + (mkdir-p db-dir) + (parameterize ((sql-schema schema)) + (with-database (string-append db-dir "/db.sqlite") db + (for-each (cut register db <>) items)))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 4b4ac01f64..d3139eb904 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -85,7 +85,7 @@ LINK-PREFIX." (lambda () (link target tempname) tempname) - (lambda (args) + (lambda args (if (= (system-error-errno args) EEXIST) (try (tempname-in link-prefix)) (throw 'system-error args)))))) @@ -120,12 +120,15 @@ under STORE." (link-file (string-append links-directory "/" (bytevector->base16-string hash)))) (mkdir-p links-directory) - (if (file-is-directory? path) + (if (eq? 'directory (stat:type (lstat path))) ;; Can't hardlink directories, so hardlink their atoms. (for-each (lambda (file) - (unless (member file '("." "..")) - (deduplicate file (nar-sha256 file) - #:store store))) + (unless (or (member file '("." "..")) + (and (string=? path store) + (string=? file ".links"))) + (let ((file (string-append path "/" file))) + (deduplicate file (nar-sha256 file) + #:store store)))) (scandir path)) (if (file-exists? link-file) (false-if-system-error (EMLINK) diff --git a/guix/store/schema.sql b/guix/store/schema.sql new file mode 100644 index 0000000000..c1b4a689af --- /dev/null +++ b/guix/store/schema.sql @@ -0,0 +1,44 @@ +create table if not exists ValidPaths ( + id integer primary key autoincrement not null, + path text unique not null, + hash text not null, + registrationTime integer not null, + deriver text, + narSize integer +); + +create table if not exists Refs ( + referrer integer not null, + reference integer not null, + primary key (referrer, reference), + foreign key (referrer) references ValidPaths(id) on delete cascade, + foreign key (reference) references ValidPaths(id) on delete restrict +); + +create index if not exists IndexReferrer on Refs(referrer); +create index if not exists IndexReference on Refs(reference); + +-- Paths can refer to themselves, causing a tuple (N, N) in the Refs +-- table. This causes a deletion of the corresponding row in +-- ValidPaths to cause a foreign key constraint violation (due to `on +-- delete restrict' on the `reference' column). Therefore, explicitly +-- get rid of self-references. +create trigger if not exists DeleteSelfRefs before delete on ValidPaths + begin + delete from Refs where referrer = old.id and reference = old.id; + end; + +create table if not exists DerivationOutputs ( + drv integer not null, + id text not null, -- symbolic output id, usually "out" + path text not null, + primary key (drv, id), + foreign key (drv) references ValidPaths(id) on delete cascade +); + +create index if not exists IndexDerivationOutputs on DerivationOutputs(path); + +create table if not exists FailedPaths ( + path text primary key not null, + time integer not null +); diff --git a/guix/ui.scm b/guix/ui.scm index 45f438fc45..ec709450d8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -42,11 +42,12 @@ #:use-module ((guix build syscalls) #:select (free-disk-space terminal-columns)) #:use-module ((guix build utils) - #:select (invoke-error? invoke-error-program - invoke-error-arguments - invoke-error-exit-status - invoke-error-term-signal - invoke-error-stop-signal)) + ;; XXX: All we need are the bindings related to + ;; '&invoke-error'. However, to work around the bug described + ;; in 5d669883ecc104403c5d3ba7d172e9c02234577c, #:hide + ;; unwanted bindings instead of #:select'ing the needed + ;; bindings. + #:hide (package-name->name+version)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -420,8 +421,21 @@ report them in a user-friendly way." (lambda _ (setlocale LC_ALL "")) (lambda args - (warning (G_ "failed to install locale: ~a~%") - (strerror (system-error-errno args)))))) + (cond-expand + ;; Guile 2.2 already emits a warning, so let's not add a second one. + (guile-2.2 #t) + (else (warning (G_ "failed to install locale: ~a~%") + (strerror (system-error-errno args))))) + (display-hint (G_ "Consider installing the @code{glibc-utf8-locales} or +@code{glibc-locales} package and defining @code{GUIX_LOCPATH}, along these +lines: + +@example +guix package -i glibc-utf8-locales +export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\" +@end example + +See the \"Application Setup\" section in the manual, for more info.\n"))))) (define (initialize-guix) "Perform the usual initialization for stand-alone Guix commands." @@ -1390,7 +1404,12 @@ DURATION-RELATION with the current time." (date->string (time-utc->date (generation-time profile number)) - "~b ~d ~Y ~T"))) + ;; TRANSLATORS: This is a format-string for date->string. + ;; Please choose a format that corresponds to the + ;; usual way of presenting dates in your locale. + ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html + ;; for details. + (G_ "~b ~d ~Y ~T")))) (current (generation-number profile))) (if (= number current) ;; TRANSLATORS: The word "current" here is an adjective for diff --git a/guix/utils.scm b/guix/utils.scm index e9efea5866..a5de9605e7 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -77,6 +78,7 @@ package-name->name+version target-mingw? target-arm32? + target-64bit? version-compare version>? version>=? @@ -474,6 +476,10 @@ a character other than '@'." (define (target-arm32?) (string-prefix? "arm" (or (%current-target-system) (%current-system)))) +(define (target-64bit?) + (let ((system (or (%current-target-system) (%current-system)))) + (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64")))) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) |