From ae9e5d6602544390fa5da0a87450405ebba012fd Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Fri, 8 Jun 2018 13:46:43 +0300 Subject: import: utils: Add recursive-import. * guix/import/cran.scm (cran-guix-name, cran-recursive-import): New procedures. (recursive-import): Remove procedure. * guix/import/utils.scm (guix-name, recursive-import): New procedures. * guix/scripts/import/cran.scm (guix-import-cran): Use 'cran-recursive-import' procedure. --- guix/import/cran.scm | 78 +++++--------------------------------------- guix/import/utils.scm | 77 ++++++++++++++++++++++++++++++++++++++++++- guix/scripts/import/cran.scm | 6 ++-- 3 files changed, 89 insertions(+), 72 deletions(-) (limited to 'guix') 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/utils.scm b/guix/import/utils.scm index efc6169077..df85904c6f 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Jelle Licht ;;; Copyright © 2016 David Craven ;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Oleg Pykhalov ;;; ;;; 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 package-name 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/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)))) -- cgit v1.2.3 From 74032da3a2ef3e99e89dd58701414004f5a6c061 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Fri, 8 Jun 2018 13:49:29 +0300 Subject: import: elpa: Add recursive import. * doc/guix.texi (Invoking guix import): Document elpa recursive import. * guix/import/elpa.scm (elpa-package->sexp): Return package and dependencies values. (elpa-guix-name, elpa-recursive-import): New procedures. * guix/scripts/import/elpa.scm (show-help, %options): Add recursive option. (guix-import-elpa): Use 'elpa-recursive-import'. --- doc/guix.texi | 6 +++++ guix/import/elpa.scm | 62 +++++++++++++++++++++++++++----------------- guix/scripts/import/elpa.scm | 26 ++++++++++++++++--- 3 files changed, 66 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e1353842e4..1183565ad3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6586,6 +6586,12 @@ signatures,, emacs, The GNU Emacs Manual}). @uref{http://melpa.org/packages, MELPA}, selected by the @code{melpa} identifier. @end itemize + +@item --recursive +@itemx -r +Traverse the dependency graph of the given upstream package recursively +and generate package expressions for all those packages that are not yet +in Guix. @end table @item crate diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 43e9eb60c9..0a95b3cb53 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 ;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2018 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (gnu packages) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module (guix http-client) @@ -37,7 +39,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 +203,15 @@ type ''." (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 +223,25 @@ type ''." (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 +296,11 @@ type ''." (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/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 +;;; Copyright © 2018 Oleg Pykhalov ;;; ;;; 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 ...) -- cgit v1.2.3 From 9953685c0985c6cc4481db3e351f1cc1dbf81e8b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jun 2018 12:21:23 +0200 Subject: config: Remove 'canonicalize-path' call. The call was unnecessary and would cause test failures because 'test-tmp/db' does not exist initially. * guix/config.scm.in (%store-database-directory): Remove 'canonicalize-path' call. --- guix/config.scm.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/config.scm.in b/guix/config.scm.in index dfe5fe0dbf..aeea81bd3f 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -83,7 +83,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 -- cgit v1.2.3 From 62d78ec076033c1bc855c4022a9fadef5f6cb768 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Fri, 8 Jun 2018 17:03:38 +0300 Subject: import: elpa: Remove unused (gnu packages) module. * guix/import/elpa.scm: Remove unused (gnu packages) module. --- guix/import/elpa.scm | 1 - 1 file changed, 1 deletion(-) (limited to 'guix') diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 0a95b3cb53..65e0be45ab 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -27,7 +27,6 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (gnu packages) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module (guix http-client) -- cgit v1.2.3 From 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 May 2018 11:10:27 +0200 Subject: self: Produce a complete package with the 'guix' command. * guix/self.scm (guix-command): New procedure. (compiled-guix): Add #:pull-version parameter. [command, package]: New variables. Honor PULL-VERSION. (guix-derivation): Add #:pull-version and pass it to 'compiled-guix'. * build-aux/build-self.scm (build-program): Add #:pull-version parameter. Pass it to 'guix-derivation'. (build): Add #:pull-version and pass it to 'build-program'. * build-aux/compile-as-derivation.scm: Pass #:pull-version to BUILD. --- build-aux/build-self.scm | 19 +++-- build-aux/compile-as-derivation.scm | 2 +- guix/self.scm | 153 +++++++++++++++++++++++++++--------- 3 files changed, 132 insertions(+), 42 deletions(-) (limited to 'guix') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index bccb7a959e..5898b6515c 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -184,7 +184,8 @@ person's version identifier." (date->string (current-date 0) "~Y~m~d.~H")) (define* (build-program source version - #:optional (guile-version (effective-version))) + #:optional (guile-version (effective-version)) + #:key (pull-version 0)) "Return a program that computes the derivation to build Guix from SOURCE." (define select? ;; Select every module but (guix config) and non-Guix modules. @@ -253,11 +254,14 @@ person's version identifier." (spin system))) (display - (derivation-file-name + (and=> (run-with-store store (guix-derivation #$source #$version - #$guile-version) - #:system system))))))) + #$guile-version + #:pull-version + #$pull-version) + #:system system) + derivation-file-name)))))) #:module-path (list source)))) ;; The procedure below is our return value. @@ -266,13 +270,15 @@ person's version identifier." (guile-version (match ((@ (guile) version)) ("2.2.2" "2.2.2") (_ (effective-version)))) + (pull-version 0) #:allow-other-keys #:rest rest) "Return a derivation that unpacks SOURCE into STORE and compiles Scheme files." ;; Build the build program and then use it as a trampoline to build from ;; SOURCE. - (mlet %store-monad ((build (build-program source version guile-version)) + (mlet %store-monad ((build (build-program source version guile-version + #:pull-version pull-version)) (system (if system (return system) (current-system)))) (mbegin %store-monad (show-what-to-build* (list build)) @@ -292,6 +298,9 @@ files." (return (newline (current-output-port))) ((store-lift add-temp-root) drv) (return (read-derivation-from-file drv)))) + ("#f" + ;; Unsupported PULL-VERSION. + (return #f)) ((? string? str) (error "invalid build result" (list build str)))))))) diff --git a/build-aux/compile-as-derivation.scm b/build-aux/compile-as-derivation.scm index afb134a92a..2a45e71bb9 100644 --- a/build-aux/compile-as-derivation.scm +++ b/build-aux/compile-as-derivation.scm @@ -43,7 +43,7 @@ (mlet* %store-monad ((source (interned-file source "guix-source" #:select? git? #:recursive? #t)) - (drv (build source))) + (drv (build source #:pull-version 1))) (mbegin %store-monad (show-what-to-build* (list drv)) (built-derivations (list drv)) diff --git a/guix/self.scm b/guix/self.scm index 3acfac6f80..28faeaab0c 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -34,6 +34,7 @@ #: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)) @@ -192,7 +193,66 @@ 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* (guix-command modules #:key (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 #$modules %load-compiled-path)) + + (let ((guix-main (module-ref (resolve-interface '(guix ui)) + 'guix-main))) + ;; TODO: Compute locale data. + ;; (bindtextdomain "guix" "@localedir@") + ;; (bindtextdomain "guix-packages" "@localedir@") + + ;; 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))) + "Return the whole Guix package NAME that uses MODULES, a derivation of all +the modules, and DEPENDENCIES, a list of packages depended on." + (let ((command (guix-command modules + #:dependencies dependencies + #:guile-version guile-version))) + ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'. + (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")) + + (let ((modules (string-append #$output + "/share/guile/site/" + (effective-version)))) + (mkdir-p (dirname modules)) + (symlink #$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)) @@ -351,32 +411,46 @@ 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 + (directory-union (string-append name "-modules") + (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)) + + ;; 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. + (whole-package name built-modules dependencies + #:guile-version guile-version)) + ((= 0 pull-version) + ;; Legacy 'guix pull': just return the compiled modules. + built-modules) + (else + ;; Unsupported 'guix pull' version. + #f))) ;;; @@ -630,9 +704,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 +721,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))))) -- cgit v1.2.3 From 75e24d7b0e19ab2164aecb340e82d07d2b9714e7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 May 2018 17:50:21 +0200 Subject: pull: Install the new Guix in a profile. * guix/scripts/pull.scm (%pull-version): New variable. (build-from-source): Pass #:pull-version to BUILD. (whole-package-for-legacy, derivation->manifest-entry): New procedure. (build-and-install): Rewrite in terms of 'build-and-use-profile'. * guix/scripts/system.scm (maybe-suggest-running-guix-pull)[latest]: Switch to "/current". * scripts/guix.in (augment-load-paths!): Remove use of ~/.config/guix/latest. * build-aux/compile-as-derivation.scm: Replace "/guix/latest/" with "/current/share/guile/site/X.Y" * guix/scripts.scm (warn-about-old-distro)[age]: Check "/current" instead of "/latest". * doc/guix.texi (Invoking guix pull): Document it. * doc/contributing.texi (Running Guix Before It Is Installed): Remove footnote about abusing ~/.config/guix/latest. --- build-aux/compile-as-derivation.scm | 3 +- doc/contributing.texi | 10 +---- doc/guix.texi | 38 +++++++++++++++--- guix/scripts.scm | 4 +- guix/scripts/pull.scm | 79 +++++++++++++++++++++++++------------ guix/scripts/system.scm | 2 +- scripts/guix.in | 14 +------ 7 files changed, 94 insertions(+), 56 deletions(-) (limited to 'guix') diff --git a/build-aux/compile-as-derivation.scm b/build-aux/compile-as-derivation.scm index 2a45e71bb9..59a84b1415 100644 --- a/build-aux/compile-as-derivation.scm +++ b/build-aux/compile-as-derivation.scm @@ -25,7 +25,8 @@ (and=> (or (getenv "XDG_CONFIG_HOME") (and=> (getenv "HOME") (cut string-append <> "/.config"))) - (cut string-append <> "/guix/latest"))) + (cute string-append <> "/guix/current/share/guile/site/" + (effective-version)))) (use-modules (guix) (guix ui) (guix git-download) diff --git a/doc/contributing.texi b/doc/contributing.texi index 2792fe2b29..205c972aea 100644 --- a/doc/contributing.texi +++ b/doc/contributing.texi @@ -155,15 +155,9 @@ The @command{pre-inst-env} script sets up all the environment variables necessary to support this, including @env{PATH} and @env{GUILE_LOAD_PATH}. Note that @command{./pre-inst-env guix pull} does @emph{not} upgrade the -local source tree; it simply updates the @file{~/.config/guix/latest} +local source tree; it simply updates the @file{~/.config/guix/current} symlink (@pxref{Invoking guix pull}). Run @command{git pull} instead if -you want to upgrade your local source tree.@footnote{If you would like -to set up @command{guix} to use your Git checkout, you can point the -@file{~/.config/guix/latest} symlink to your Git checkout directory. -If you are the sole user of your system, you may also consider pointing -the @file{/root/.config/guix/latest} symlink to point to -@file{~/.config/guix/latest}; this way it will always use the same -@command{guix} as your user does.} +you want to upgrade your local source tree. @node The Perfect Setup diff --git a/doc/guix.texi b/doc/guix.texi index 6ed4799dfc..13b42f59f3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2743,11 +2743,39 @@ Any user can update their Guix copy using @command{guix pull}, and the effect is limited to the user who run @command{guix pull}. For instance, when user @code{root} runs @command{guix pull}, this has no effect on the version of Guix that user @code{alice} sees, and vice -versa@footnote{Under the hood, @command{guix pull} updates the -@file{~/.config/guix/latest} symbolic link to point to the latest Guix, -and the @command{guix} command loads code from there. Currently, the -only way to roll back an invocation of @command{guix pull} is to -manually update this symlink to point to the previous Guix.}. +versa. + +The result of running @command{guix pull} is a @dfn{profile} available +under @file{~/.config/guix/current} containing the latest Guix. Thus, +make sure to add it to the beginning of your search path so that you use +the latest version, and similarly for the Info manual +(@pxref{Documentation}): + +@example +export PATH="$HOME/.config/guix/current/bin:$PATH" +export INFOPATH="$HOME/.config/guix/current/share/info:$INFOPATH" +@end example + +This @code{~/.config/guix/current} profile works like any other profile +created by @command{guix package} (@pxref{Invoking guix package}). That +is, you can list generations, roll back to the previous +generation---i.e., the previous Guix---and so on: + +@example +$ guix package -p ~/.config/guix/current -l +Generation 1 May 25 2018 10:06:41 + guix 221951a out /gnu/store/i4dfk7vw5k112s49jrhl6hwsfnh6wr7l-guix-221951af4 + +Generation 2 May 27 2018 19:07:47 + + guix 2fbae00 out /gnu/store/44cv9hyvxg34xf5kblf5dz57hc52y4bm-guix-2fbae006f + - guix 221951a out /gnu/store/i4dfk7vw5k112s49jrhl6hwsfnh6wr7l-guix-221951af4 + +Generation 3 May 30 2018 16:11:39 (current) + + guix a076f19 out /gnu/store/332czkicwwg6lc3x4aqbw5q2mq12s7fj-guix-a076f1990 + - guix 2fbae00 out /gnu/store/44cv9hyvxg34xf5kblf5dz57hc52y4bm-guix-2fbae006f +$ guix package -p ~/.config/guix/current --roll-back +switched from generation 3 to 2 +@end example The @command{guix pull} command is usually invoked with no arguments, but it supports the following options: 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 +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès ;;; Copyright © 2014 Deck Pickard ;;; Copyright © 2015, 2016 Alex Kost ;;; @@ -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/pull.scm b/guix/scripts/pull.scm index 64c2196e03..c5ceebccb6 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 +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès ;;; Copyright © 2017 Marius Bakke ;;; ;;; 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) @@ -158,6 +163,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 +181,51 @@ 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 commit) + "Return a manifest entry for DRV, which represents Guix at COMMIT." + (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)))))))) (define* (build-and-install source config-dir #:key verbose? 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 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." diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 766cab1aad..14be8ff8cf 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -740,7 +740,7 @@ checking this by themselves in their 'check' procedure." ;; 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/scripts/guix.in b/scripts/guix.in index d1c12eae5c..0a3ab1f64d 100644 --- a/scripts/guix.in +++ b/scripts/guix.in @@ -23,25 +23,13 @@ ;; IMPORTANT: We must avoid loading any modules from Guix here, ;; because we need to adjust the guile load paths first. ;; It's okay to import modules from core Guile though. -(use-modules (srfi srfi-26)) (define-syntax-rule (push! elt v) (set! v (cons elt v))) (define (augment-load-paths!) ;; Add installed modules to load-path. (push! "@guilemoduledir@" %load-path) - (push! "@guileobjectdir@" %load-compiled-path) - - ;; Add modules fetched by 'guix pull' to load-path. - (let ((updates-dir (and=> (or (getenv "XDG_CONFIG_HOME") - (and=> (getenv "HOME") - (cut string-append <> "/.config"))) - (cut string-append <> "/guix/latest")))) - (when (and=> updates-dir file-exists?) - ;; XXX: Currently 'guix pull' puts both .scm and .go files in - ;; UPDATES-DIR. - (push! updates-dir %load-path) - (push! updates-dir %load-compiled-path)))) + (push! "@guileobjectdir@" %load-compiled-path)) (define* (main #:optional (args (command-line))) (unless (getenv "GUIX_UNINSTALLED") -- cgit v1.2.3 From 9f1c3559b00a41ca5a5f3230e7437ac8ea123ee4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 May 2018 22:12:09 +0200 Subject: self: Compute and use locale data. * guix/self.scm (sub-directory, locale-data): New procedures. (guix-command): Add SOURCE parameter. Call 'locale-data' when SOURCE is true and use it in staged 'bindtextdomain' calls. (whole-package): Add #:command and honor it. (compiled-guix): Pass #:command to 'whole-package'. --- guix/self.scm | 119 ++++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 94 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 28faeaab0c..5c3daf15ee 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -193,7 +193,63 @@ 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* (guix-command modules #:key (dependencies '()) +(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* (guix-command modules #:key source (dependencies '()) (guile-version (effective-version))) "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its load path." @@ -221,35 +277,43 @@ load path." (let ((guix-main (module-ref (resolve-interface '(guix ui)) 'guix-main))) - ;; TODO: Compute locale data. - ;; (bindtextdomain "guix" "@localedir@") - ;; (bindtextdomain "guix-packages" "@localedir@") + #$(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))) + #:key + (guile-version (effective-version)) + (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." - (let ((command (guix-command modules - #:dependencies dependencies - #:guile-version guile-version))) - ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'. - (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")) - - (let ((modules (string-append #$output - "/share/guile/site/" - (effective-version)))) - (mkdir-p (dirname modules)) - (symlink #$modules modules))))))) +the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the +'guix' program to use." + ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'. + (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")) + + (let ((modules (string-append #$output + "/share/guile/site/" + (effective-version)))) + (mkdir-p (dirname modules)) + (symlink #$modules modules)))))) (define* (compiled-guix source #:key (version %guix-version) (pull-version 1) @@ -443,8 +507,13 @@ the modules, and DEPENDENCIES, a list of packages depended on." ;; Version 1 is when we return the full package. (cond ((= 1 pull-version) ;; The whole package, with a standard file hierarchy. - (whole-package name built-modules dependencies - #:guile-version guile-version)) + (let ((command (guix-command built-modules + #:source source + #:dependencies dependencies + #:guile-version guile-version))) + (whole-package name built-modules dependencies + #:command command + #:guile-version guile-version))) ((= 0 pull-version) ;; Legacy 'guix pull': just return the compiled modules. built-modules) -- cgit v1.2.3 From 4554d4c8a925ed94ce846f927b43a65263acdd84 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 13:42:43 +0200 Subject: self: Build the Info manual. * guix/self.scm (info-manual): New procedure. (whole-package): Add #:info and honor it. (compiled-guix): Pass #:info. --- guix/self.scm | 106 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 103 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 5c3daf15ee..e71e086cdc 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -249,6 +249,99 @@ DOMAIN, a gettext domain." (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 #:key source (dependencies '()) (guile-version (effective-version))) "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its @@ -294,12 +387,13 @@ load path." (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) + info (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." +'guix' program to use; INFO is the Info manual." ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'. (computed-file name (with-imported-modules '((guix build utils)) @@ -311,9 +405,14 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (let ((modules (string-append #$output "/share/guile/site/" - (effective-version)))) + (effective-version))) + (info #$info)) (mkdir-p (dirname modules)) - (symlink #$modules modules)))))) + (symlink #$modules modules) + (when info + (symlink #$info + (string-append #$output + "/share/info")))))))) (define* (compiled-guix source #:key (version %guix-version) (pull-version 1) @@ -513,6 +612,7 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the #:guile-version guile-version))) (whole-package name built-modules dependencies #:command command + #:info (info-manual source) #:guile-version guile-version))) ((= 0 pull-version) ;; Legacy 'guix pull': just return the compiled modules. -- cgit v1.2.3 From 24cb66d18e37162721d636c277838718d3b23966 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 9 Jun 2018 10:21:26 +0200 Subject: ui: Avoid #:select'ing bindings introduced in the latest (guix build utils). This should allow 'guix pull' to complete even when invoked from a Guix that predates commit 5d669883ecc104403c5d3ba7d172e9c02234577c. * guix/ui.scm: Use #:hide instead of #:select. This is a followup to 5d669883ecc104403c5d3ba7d172e9c02234577c. --- guix/ui.scm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 45f438fc45..99f66b0fdc 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) -- cgit v1.2.3 From efcb4441f1c2dd6729938ca68f2fdfd6243e24e4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 May 2018 16:08:24 +0200 Subject: profiles: Add '%current-profile', 'user-friendly-profile', & co. * guix/scripts/package.scm (%user-profile-directory) (%profile-directory, %current-profile, canonicalize-profile) (user-friendly-profile): Move to... * guix/profiles.scm: ... here. --- guix/profiles.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++- guix/scripts/package.scm | 40 --------------------------------------- 2 files changed, 48 insertions(+), 41 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 9bddf88162..95a8f30335 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -25,6 +25,7 @@ ;;; along with GNU Guix. If not, see . (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)) @@ -118,7 +119,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: ;;; @@ -1515,4 +1522,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 + + ;; 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/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 - - ;; 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." -- cgit v1.2.3 From c423ae89185abab9ca6381a12285b85079367072 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 May 2018 18:46:13 +0200 Subject: packages: Add 'package-patched-vulnerabilities'. * guix/packages.scm (patch-file-name): New procedure. (%vulnerability-regexp): New variable. (package-patched-vulnerabilities): New procedure. * guix/scripts/lint.scm (patch-file-name): Remove. (check-vulnerabilities): Adjust to use 'package-patched-vulnerabilities'. * tests/packages.scm ("package-patched-vulnerabilities"): New test. --- guix/packages.scm | 28 ++++++++++++++++++++++++++++ guix/scripts/lint.scm | 23 ++++------------------- tests/packages.scm | 15 +++++++++++++++ 3 files changed, 47 insertions(+), 19 deletions(-) (limited to 'guix') 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/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 ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel @@ -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/tests/packages.scm b/tests/packages.scm index f1e7d3119b..65ccb14889 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -959,6 +959,21 @@ ((("x" dep)) (eq? dep findutils))))))))) +(test-equal "package-patched-vulnerabilities" + '(("CVE-2015-1234") + ("CVE-2016-1234" "CVE-2018-4567") + ()) + (let ((p1 (dummy-package "pi" + (source (dummy-origin + (patches (list "/a/b/pi-CVE-2015-1234.patch")))))) + (p2 (dummy-package "pi" + (source (dummy-origin + (patches (list + "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch")))))) + (p3 (dummy-package "pi" (source (dummy-origin))))) + (map package-patched-vulnerabilities + (list p1 p2 p3)))) + (test-eq "fold-packages" hello (fold-packages (lambda (p r) (if (string=? (package-name p) "hello") -- cgit v1.2.3 From f6f2346f9b9387d449844fe5b3207ccbede069f4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 May 2018 18:48:22 +0200 Subject: profiles: Add 'properties' field to manifest entries. * guix/profiles.scm ()[properties]: New field. (manifest->gexp)[entry->gexp]: Serialize it. (sexp->manifest)[sexp->manifest-entry]: Deserialize it. --- guix/profiles.scm | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 95a8f30335..ebd7da2a24 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -78,6 +78,7 @@ manifest-entry-dependencies manifest-entry-search-paths manifest-entry-parent + manifest-entry-properties manifest-pattern manifest-pattern? @@ -181,7 +182,9 @@ (search-paths manifest-entry-search-paths ; search-path-specification* (default '())) (parent manifest-entry-parent ; promise (#f | ) - (default (delay #f)))) + (default (delay #f))) + (properties manifest-entry-properties ; list of symbol/value pairs + (default '()))) (define-record-type* manifest-pattern make-manifest-pattern @@ -320,18 +323,20 @@ denoting a specific output of a package." (define (entry->gexp entry) (match 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))) (($ 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 (($ (entries ...)) @@ -394,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 -- cgit v1.2.3 From 77a1aac6cccc79d7c8085762f610e22e6ebfb43b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 9 Jun 2018 11:31:18 +0200 Subject: pull: Record the URL, branch, and commit as a manifest entry property. * guix/scripts/pull.scm (derivation->manifest-entry): Turn COMMIT into a keyword parameter; add #:url and #:branch. Add a 'source' property to the manifest entry. (build-and-install): Add #:url and #:branch and pass it to 'derivation->manifest-entry'. (guix-pull): Adjust accordingly. --- guix/scripts/pull.scm | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index c5ceebccb6..499de0ec45 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -199,8 +199,10 @@ modules in the old ~/.config/guix/latest style." (list guile-json guile-git guile-bytestructures guile-ssh gnutls))) -(define (derivation->manifest-entry drv commit) - "Return a manifest entry for DRV, which represents Guix at COMMIT." +(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)) @@ -212,10 +214,16 @@ modules in the old ~/.config/guix/latest style." drv (whole-package-for-legacy (string-append name "-" version) - drv)))))))) + 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." (define update-profile (store-lift build-and-use-profile)) @@ -223,7 +231,10 @@ modules in the old ~/.config/guix/latest style." (mlet* %store-monad ((drv (build-from-source source #:commit commit #:verbose? verbose?)) - (entry (derivation->manifest-entry drv commit))) + (entry (derivation->manifest-entry drv + #:url url + #:branch branch + #:commit commit))) (update-profile (string-append config-dir "/current") (manifest (list entry))))) @@ -306,6 +317,11 @@ certificates~%")) (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?)))))))))))) -- cgit v1.2.3 From 3edf0d53a4043c30f3ff87b3b4b7b47d1bac1397 Mon Sep 17 00:00:00 2001 From: Jelle Licht Date: Sun, 10 Jun 2018 20:35:39 +0200 Subject: import: json: Consolidate duplicate json-fetch functionality. * guix/import/json.scm (json-fetch): Return a list or hash table. (json-fetch-alist): New procedure. * guix/import/github.scm (json-fetch*): Remove. (latest-released-version): Use json-fetch. * guix/import/cpan.scm (module->dist-name): Use json-fetch-alist. (cpan-fetch): Likewise. * guix/import/crate.scm (crate-fetch): Likewise. * guix/import/gem.scm (rubygems-fetch): Likewise. * guix/import/pypi.scm (pypi-fetch): Likewise. * guix/import/stackage.scm (stackage-lts-info-fetch): Likewise. --- guix/import/cpan.scm | 9 +++++---- guix/import/crate.scm | 4 ++-- guix/import/gem.scm | 2 +- guix/import/github.scm | 19 ++----------------- guix/import/json.scm | 24 +++++++++++++++++------- guix/import/pypi.scm | 4 ++-- guix/import/stackage.scm | 2 +- 7 files changed, 30 insertions(+), 34 deletions(-) (limited to 'guix') 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/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/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/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)))))) -- cgit v1.2.3 From a708de151c255712071e42e5c8284756b51768cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 11 Jun 2018 11:42:59 +0200 Subject: offload: Honor the build timeout internally. * guix/scripts/offload.scm (call-with-timeout): New procedure. (with-timeout): New macro. (process-request): Use it around 'transfer-and-offload' call. --- guix/scripts/offload.scm | 46 ++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 38 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 56d6de6308..fb61d7c059 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -494,6 +494,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 +544,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))) @@ -755,6 +784,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 -- cgit v1.2.3 From 4c97a368a698ccf89113a258e8cf5e7947fbcc08 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jun 2018 09:28:28 +0200 Subject: substitute: Erase the current line when reporting progress. * guix/scripts/substitute.scm (fetch-narinfos)[update-progress!]: Use the ANSI erase-current-line sequence next to \r. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8e1119fb49..ab52245e8e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -613,7 +613,7 @@ 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%") -- cgit v1.2.3 From 2bf9351e311cce0004756890b93f50693f133bb6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jun 2018 10:30:30 +0200 Subject: substitute: Make progress message shorter. * guix/scripts/substitute.scm (fetch-narinfos)[update-progress!]: Shorten progress message so it fits on 80 columns. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ab52245e8e..d0beacc8ea 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -616,7 +616,7 @@ if file doesn't exist, and the narinfo otherwise." (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))))) -- cgit v1.2.3 From 38212ff7b91a276228d9e6b9b6e265eb1a5e6fff Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Mon, 11 Jun 2018 17:36:06 +0300 Subject: import: utils: Import more dependencies. * guix/import/utils.scm (recursive-import): Import more dependencies. --- guix/import/utils.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index df85904c6f..0dc8fd5857 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -420,7 +420,7 @@ dependencies." ;; generator: update the queue (lambda (state) (receive (package . dependencies) - (repo->guix-package package-name repo) + (repo->guix-package (next state) repo) (if package (update state (filter (cut unknown? <> (cons (next state) -- cgit v1.2.3 From e2f8be0664609223369f01290b69b44196783ab3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Jun 2018 23:39:24 +0200 Subject: pull: Add '--list-generations'. * guix/scripts/pull.scm (show-help, %options): Add '--list-generations'. (display-profile-content, process-query): New procedures. (guix-pull): Honor '--list-generations'. --- doc/guix.texi | 44 +++++++++++---- guix/scripts/pull.scm | 149 +++++++++++++++++++++++++++++++++++++------------- 2 files changed, 144 insertions(+), 49 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e734147681..4871bbcfe4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2756,25 +2756,40 @@ export PATH="$HOME/.config/guix/current/bin:$PATH" export INFOPATH="$HOME/.config/guix/current/share/info:$INFOPATH" @end example +The @code{--list-generations} or @code{-l} option lists past generations +produced by @command{guix pull}, along with details about their provenance: + +@example +$ guix pull -l +Generation 1 Jun 10 2018 00:18:18 + guix 65956ad + repository URL: https://git.savannah.gnu.org/git/guix.git + branch: origin/master + commit: 65956ad3526ba09e1f7a40722c96c6ef7c0936fe + +Generation 2 Jun 11 2018 11:02:49 + guix e0cc7f6 + repository URL: https://git.savannah.gnu.org/git/guix.git + branch: origin/master + commit: e0cc7f669bec22c37481dd03a7941c7d11a64f1d + +Generation 3 Jun 13 2018 23:31:07 (current) + guix 844cc1c + repository URL: https://git.savannah.gnu.org/git/guix.git + branch: origin/master + commit: 844cc1c8f394f03b404c5bb3aee086922373490c +@end example + This @code{~/.config/guix/current} profile works like any other profile created by @command{guix package} (@pxref{Invoking guix package}). That is, you can list generations, roll back to the previous generation---i.e., the previous Guix---and so on: @example -$ guix package -p ~/.config/guix/current -l -Generation 1 May 25 2018 10:06:41 - guix 221951a out /gnu/store/i4dfk7vw5k112s49jrhl6hwsfnh6wr7l-guix-221951af4 - -Generation 2 May 27 2018 19:07:47 - + guix 2fbae00 out /gnu/store/44cv9hyvxg34xf5kblf5dz57hc52y4bm-guix-2fbae006f - - guix 221951a out /gnu/store/i4dfk7vw5k112s49jrhl6hwsfnh6wr7l-guix-221951af4 - -Generation 3 May 30 2018 16:11:39 (current) - + guix a076f19 out /gnu/store/332czkicwwg6lc3x4aqbw5q2mq12s7fj-guix-a076f1990 - - guix 2fbae00 out /gnu/store/44cv9hyvxg34xf5kblf5dz57hc52y4bm-guix-2fbae006f $ guix package -p ~/.config/guix/current --roll-back switched from generation 3 to 2 +$ guix package -p ~/.config/guix/current --delete-generations=1 +deleting /home/charlie/.config/guix/current-1-link @end example The @command{guix pull} command is usually invoked with no arguments, @@ -2800,6 +2815,13 @@ string. Deploy the tip of @var{branch}, the name of a Git branch available on the repository at @var{url}. +@item --list-generations[=@var{pattern}] +@itemx -l [@var{pattern}] +List all the generations of @file{~/.config/guix/current} or, if @var{pattern} +is provided, the subset of generations that match @var{pattern}. +The syntax of @var{pattern} is the same as with @code{guix package +--list-generations} (@pxref{Invoking guix package}). + @item --bootstrap Use the bootstrap Guile to build the latest Guix. This option is only useful to Guix developers. diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 499de0ec45..7202e3cc16 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -45,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)) @@ -109,6 +110,9 @@ Download and deploy the latest version of Guix.\n")) --commit=COMMIT download the specified COMMIT")) (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) @@ -125,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 @@ -273,6 +281,66 @@ certificates~%")) (lambda (key err) (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) @@ -287,43 +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) - #:url url - #:branch (match ref - (('branch . branch) - branch) - (_ #f)) - #: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 -- cgit v1.2.3 From 3931c76154d4f418d5ea9acc5e47bf911d371c24 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 15:40:09 +0200 Subject: database: 'with-database' can now initialize new databases. * nix/libstore/schema.sql: Rename to... * guix/store/schema.sql: ... this. * Makefile.am (nobase_dist_guilemodule_DATA): Add it. * nix/local.mk (%D%/libstore/schema.sql.hh): Adjust accordingly. * guix/store/database.scm (sql-schema): New variable. (sqlite-exec, initialize-database, call-with-database): New procedures. (with-database): Rewrite in terms of 'call-with-database'. * tests/store-database.scm ("new database"): New test. * guix/self.scm (compiled-guix)[*core-modules*]: Add 'schema.sql' to #:extra-files. --- Makefile.am | 1 + guix/self.scm | 4 +++- guix/store/database.scm | 50 +++++++++++++++++++++++++++++++++++++++++++----- guix/store/schema.sql | 44 ++++++++++++++++++++++++++++++++++++++++++ nix/libstore/schema.sql | 44 ------------------------------------------ nix/local.mk | 2 +- tests/store-database.scm | 23 ++++++++++++++++++++++ 7 files changed, 117 insertions(+), 51 deletions(-) create mode 100644 guix/store/schema.sql delete mode 100644 nix/libstore/schema.sql (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 7898a3648a..0267e8fe50 100644 --- a/Makefile.am +++ b/Makefile.am @@ -300,6 +300,7 @@ EXAMPLES = \ GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go $(dist_noinst_DATA:%.scm=%.go) nobase_dist_guilemodule_DATA = \ + guix/store/schema.sql \ $(MODULES) $(MODULES_NOT_COMPILED) $(AUX_FILES) $(EXAMPLES) \ $(MISC_DISTRO_FILES) nobase_nodist_guilemodule_DATA = guix/config.scm diff --git a/guix/self.scm b/guix/self.scm index e71e086cdc..ed3f31cdbc 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -482,7 +482,9 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the ;; 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)) diff --git a/guix/store/database.scm b/guix/store/database.scm index 3623c0e7a0..e81ab3dc99 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -24,25 +24,65 @@ #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix build syscalls) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #: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 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 + ;; . + (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. 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/nix/libstore/schema.sql b/nix/libstore/schema.sql deleted file mode 100644 index c1b4a689af..0000000000 --- a/nix/libstore/schema.sql +++ /dev/null @@ -1,44 +0,0 @@ -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/nix/local.mk b/nix/local.mk index 39717711f8..b4c6ba61a4 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -163,7 +163,7 @@ noinst_HEADERS = \ $(libformat_headers) $(libutil_headers) $(libstore_headers) \ $(guix_daemon_headers) -%D%/libstore/schema.sql.hh: %D%/libstore/schema.sql +%D%/libstore/schema.sql.hh: guix/store/schema.sql $(AM_V_GEN)$(GUILE) --no-auto-compile -c \ "(use-modules (rnrs io ports)) \ (call-with-output-file \"$@\" \ diff --git a/tests/store-database.scm b/tests/store-database.scm index 1348a75c26..7947368595 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module ((guix store) #:hide (register-path)) #:use-module (guix store database) + #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64)) @@ -51,4 +52,26 @@ (null? (valid-derivers %store file)) (null? (referrers %store file)))))) +(test-equal "new database" + (list 1 2) + (call-with-temporary-output-file + (lambda (db-file port) + (delete-file db-file) + (sqlite-register #:db-file db-file + #:path "/gnu/foo" + #:references '() + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size 1234) + (sqlite-register #:db-file db-file + #:path "/gnu/bar" + #:references '("/gnu/foo") + #:deriver "/gnu/bar.drv" + #:hash (string-append "sha256:" (make-string 64 #\a)) + #:nar-size 4321) + (let ((path-id (@@ (guix store database) path-id))) + (with-database db-file db + (list (path-id db "/gnu/foo") + (path-id db "/gnu/bar"))))))) + (test-end "store-database") -- cgit v1.2.3 From f8f9f7cabca3f0ea1f8b8cb4fecfc45889bdfb94 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 18:33:19 +0200 Subject: database: Fail registration when encountering unregistered references. * guix/store/database.scm (add-reference-sql): Remove nested SELECT. (add-references): Expect REFERENCES to be a list of ids. (sqlite-register): Call 'path-id' for each of REFERENCES and pass it to 'add-references'. * tests/store-database.scm ("register-path with unregistered references"): New test. --- guix/store/database.scm | 18 +++++++++++------- tests/store-database.scm | 20 ++++++++++++++++++++ 2 files changed, 31 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index e81ab3dc99..d5e34ef044 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -27,6 +27,7 @@ #: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) #:use-module (system foreign) @@ -139,13 +140,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 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) @@ -164,15 +163,20 @@ 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." +\"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. + +Every store item in REFERENCES must already be registered." (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)))) + ;; 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))))) ;;; diff --git a/tests/store-database.scm b/tests/store-database.scm index 7947368595..9562055fd1 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -74,4 +74,24 @@ (list (path-id db "/gnu/foo") (path-id db "/gnu/bar"))))))) +(test-assert "register-path with unregistered references" + ;; Make sure we get a "NOT NULL constraint failed: Refs.reference" error + ;; when we try to add references that are not registered yet. Better safe + ;; than sorry. + (call-with-temporary-output-file + (lambda (db-file port) + (delete-file db-file) + (catch 'sqlite-error + (lambda () + (sqlite-register #:db-file db-file + #:path "/gnu/foo" + #:references '("/gnu/bar") + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size 1234) + #f) + (lambda args + (pk 'welcome-exception! args) + #t))))) + (test-end "store-database") -- cgit v1.2.3 From 6892f0a247a06ac12c8c462692f8b3f93e872911 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 22:06:34 +0200 Subject: store-copy: 'read-reference-graph' returns a list of records. The previous implementation of 'read-reference-graph' was good enough for many use cases, but it discarded the graph structure, which is useful information in some cases. * guix/build/store-copy.scm (): New record type. (read-reference-graph): Rewrite to return a list of . (closure-size, populate-store): Adjust accordingly. * gnu/services/base.scm (references-file): Adjust accordingly. * gnu/system/vm.scm (system-docker-image): Likewise. * guix/scripts/pack.scm (squashfs-image, docker-image): Likewise. * tests/gexp.scm ("gexp->derivation #:references-graphs"): Likewise. --- gnu/services/base.scm | 5 +- gnu/system/vm.scm | 6 ++- guix/build/store-copy.scm | 120 +++++++++++++++++++++++++++++++++++++++------- guix/scripts/pack.scm | 10 ++-- tests/gexp.scm | 17 ++++--- 5 files changed, 128 insertions(+), 30 deletions(-) (limited to 'guix') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index b34bb7132b..68411439db 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1592,8 +1592,9 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (call-with-output-file #$output (lambda (port) - (write (call-with-input-file "graph" - read-reference-graph) + (write (map store-info-item + (call-with-input-file "graph" + read-reference-graph)) port))))) #:options `(#:local-build? #f #:references-graphs (("graph" ,item)))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 544c0e294d..4aea53d1cd 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -466,8 +466,10 @@ should set REGISTER-CLOSURES? to #f." (build-docker-image (string-append "/xchg/" #$name) ;; The output file. (cons* root-directory - (call-with-input-file (string-append "/xchg/" #$graph) - read-reference-graph)) + (map store-info-item + (call-with-input-file + (string-append "/xchg/" #$graph) + read-reference-graph))) #$os-drv #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:creation-time (make-time time-utc 0 1) diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index fe2eb6f69a..bad1c09cba 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 +;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,10 +18,21 @@ (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-item + store-info-deriver + store-info-references + + read-reference-graph + closure-size populate-store)) @@ -34,19 +45,94 @@ ;;; ;;; Code: +;; Information about a store item as produced by #:references-graphs. +(define-record-type + (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 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 +158,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 +175,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/scripts/pack.scm b/guix/scripts/pack.scm index 76729d8e10..78bfd01eff 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -251,8 +251,9 @@ added to the pack." ;; 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) + `(,@(map store-info-item + (call-with-input-file "profile" + read-reference-graph)) ,#$output ;; Do not perform duplicate checking because we @@ -352,8 +353,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/tests/gexp.scm b/tests/gexp.scm index a560adfc5c..83fe811546 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -615,6 +615,7 @@ `(("graph" ,two)) #:modules '((guix build store-copy) + (guix sets) (guix build utils)))) (ok? (built-derivations (list drv))) (out -> (derivation->output-path drv))) @@ -815,21 +816,25 @@ (two (gexp->derivation "two" #~(symlink #$one #$output:chbouib))) (build -> (with-imported-modules '((guix build store-copy) + (guix sets) (guix build utils)) #~(begin (use-modules (guix build store-copy)) (with-output-to-file #$output (lambda () - (write (call-with-input-file "guile" - read-reference-graph)))) + (write (map store-info-item + (call-with-input-file "guile" + read-reference-graph))))) (with-output-to-file #$output:one (lambda () - (write (call-with-input-file "one" - read-reference-graph)))) + (write (map store-info-item + (call-with-input-file "one" + read-reference-graph))))) (with-output-to-file #$output:two (lambda () - (write (call-with-input-file "two" - read-reference-graph))))))) + (write (map store-info-item + (call-with-input-file "two" + read-reference-graph)))))))) (drv (gexp->derivation "ref-graphs" build #:references-graphs `(("one" ,one) ("two" ,two "chbouib") -- cgit v1.2.3 From 33fddb763a71970961e87d26f222951ab7cd353c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 22:35:48 +0200 Subject: database: Provide a way to specify the schema location. * guix/store/database.scm (sqlite-register): Add #:schema. Parameterize 'sql-schema' based on this. (register-path): Add #:schema and pass it to 'sqlite-register'. --- guix/store/database.scm | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index d5e34ef044..0f6d2e2c06 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -88,7 +88,7 @@ If FILE doesn't exist, create it and initialize it as a new database." ;; 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 @@ -157,7 +157,8 @@ ids of items referred to." ;; XXX figure out caching of statement and database objects... later (define* (sqlite-register #:key db-file path (references '()) - deriver hash nar-size) + deriver hash nar-size + (schema (sql-schema))) "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 @@ -167,16 +168,17 @@ base16-encoded sha256 hash of the store item denoted by PATH (prefixed with bytes of the store item denoted by PATH after being converted to nar form. Every store item in REFERENCES must already be registered." - (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))))) - ;; 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))))) + (parameterize ((sql-schema schema)) + (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))))) + ;; 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)))))) ;;; @@ -221,7 +223,8 @@ it's a directory." (define* (register-path path #:key (references '()) deriver prefix - state-directory (deduplicate? #t)) + state-directory (deduplicate? #t) + (schema (sql-schema))) ;; 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 / @@ -267,6 +270,7 @@ be used internally by the daemon's build hook." (reset-timestamps real-path) (sqlite-register #:db-file (string-append db-dir "/db.sqlite") + #:schema schema #:path to-register #:references references #:deriver deriver -- cgit v1.2.3 From 866ee8c66aad84fe64a20a14ff19d20a4a408e5b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jun 2018 22:37:47 +0200 Subject: database: 'register-path' creates the database directory if needed. * guix/store/database.scm (register-path): Call 'mkdir-p'. --- guix/store/database.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 0f6d2e2c06..1400d0d1c4 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -24,6 +24,7 @@ #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix build syscalls) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -268,6 +269,7 @@ be used internally by the daemon's build hook." (let-values (((hash nar-size) (nar-sha256 real-path))) (reset-timestamps real-path) + (mkdir-p db-dir) (sqlite-register #:db-file (string-append db-dir "/db.sqlite") #:schema schema -- cgit v1.2.3 From 0d0438ed8cb744bffa8c7e0a8d60165ce604939f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 16:36:01 +0200 Subject: deduplicate: Fix a couple of thinkos. * guix/store/deduplication.scm (get-temp-link): Turn 'args' in the 'catch' handler into a rest argument. (deduplicate): Use 'lstat' instead of 'file-is-directory?' to properly handle symlinks. When iterating over the result of 'scandir', exclude the ".links" sub-directory. * tests/store-deduplication.scm ("deduplicate"): Create sub-directories and call 'deduplicate' directly on STORE. --- guix/store/deduplication.scm | 13 ++++++++----- tests/store-deduplication.scm | 9 ++++----- 2 files changed, 12 insertions(+), 10 deletions(-) (limited to 'guix') 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/tests/store-deduplication.scm b/tests/store-deduplication.scm index 04817a193a..2361723199 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -37,10 +37,12 @@ (lambda (store) (let ((data (string->utf8 "Hello, world!")) (identical (map (lambda (n) - (string-append store "/" (number->string n))) + (string-append store "/" (number->string n) + "/a/b/c")) (iota 5))) (unique (string-append store "/unique"))) (for-each (lambda (file) + (mkdir-p (dirname file)) (call-with-output-file file (lambda (port) (put-bytevector port data)))) @@ -49,10 +51,7 @@ (lambda (port) (put-bytevector port (string->utf8 "This is unique.")))) - (for-each (lambda (file) - (deduplicate file (sha256 data) #:store store)) - identical) - (deduplicate unique (nar-sha256 unique) #:store store) + (deduplicate store (nar-sha256 store) #:store store) ;; (system (string-append "ls -lRia " store)) (cons* (apply = (map (compose stat:ino stat) identical)) -- cgit v1.2.3 From b85e2ff4841f1b91c104668bbcf93e39d9792827 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 17:06:05 +0200 Subject: database: Remove extra SQL parameter in 'update-or-insert'. * guix/store/database.scm (update-or-insert): Remove extra #:path parameter. --- guix/store/database.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 1400d0d1c4..b9170dda73 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -127,7 +127,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) -- cgit v1.2.3 From 4bd86f0d62e948f76536ecfea1225a6e9bfa89c8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 17:06:42 +0200 Subject: database: Add #:reset-timestamps? to 'register-path'. * guix/store/database.scm (register-path): Add #:reset-timestamps? and honor it. --- guix/store/database.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index b9170dda73..bfd2c36264 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -225,6 +225,7 @@ it's a directory." (define* (register-path path #:key (references '()) deriver prefix state-directory (deduplicate? #t) + (reset-timestamps? #t) (schema (sql-schema))) ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and @@ -268,7 +269,8 @@ be used internally by the daemon's build hook." (real-path (string-append store-dir "/" (basename path)))) (let-values (((hash nar-size) (nar-sha256 real-path))) - (reset-timestamps real-path) + (when reset-timestamps? + (reset-timestamps real-path)) (mkdir-p db-dir) (sqlite-register #:db-file (string-append db-dir "/db.sqlite") -- cgit v1.2.3 From 122a6cad7d4a7520593d1dd0c16b3bb8094d7f5a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 17:14:18 +0200 Subject: database: Replace existing entries in Refs. * guix/store/database.scm (add-reference-sql): Add "OR REPLACE". --- guix/store/database.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index bfd2c36264..094dea3ec8 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -141,7 +141,7 @@ of course. Returns the row id of the row that was modified or inserted." (last-insert-row-id db))))) (define add-reference-sql - "INSERT INTO Refs (referrer, reference) VALUES (:referrer, :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 -- cgit v1.2.3 From 49c393ccaae99dbddffcbebac73ecabeacd1bc9b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 22:53:52 +0200 Subject: database: 'reset-timestamps' sets file permissions as well. * guix/store/database.scm (reset-timestamps): Add 'chmod' calls. --- guix/store/database.scm | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 094dea3ec8..67dfb8b0ee 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -24,7 +24,8 @@ #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix build syscalls) - #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build utils) + #:select (mkdir-p executable-file?)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -189,11 +190,12 @@ Every store item in REFERENCES must already be registered." ;; 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 @@ -212,16 +214,9 @@ 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) -- cgit v1.2.3 From c45477d2a1a651485feede20fe0f3d15aec48b39 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jun 2018 23:58:18 +0200 Subject: install: Use (guix store database) instead of 'guix-register'. * gnu/build/install.scm (register-closure): Add #:reset-timestamps? and and #:schema; honor them. Rewrite in terms of 'register-path'. (populate-single-profile-directory): Add #:schema and honor it. Make /var/guix/profiles and /var/guix/gcroots. * gnu/build/vm.scm (root-partition-initializer): Pass #:reset-timestamps? to 'register-closure'. * gnu/system/vm.scm (not-config?): New procedure. (guile-sqlite3&co): New variable. (expression->derivation-in-linux-vm)[config]: New variable. [builder]: Use 'with-extensions'. (iso9660-image)[schema, config]: New variables. Wrap build expression in 'with-extensions'; add 'sql-schema' call. Remove GUIX from INPUTS. (qemu-image)[schema, config]: New variables. Wrap body in 'with-extensions'. (system-docker-image)[not-config?]: Remove. [config]: Use 'make-config.scm'. [schema]: New variable. [build]: Use 'with-extensions'. Add call to 'sql-schema'. Remove GUIX from INPUTS. * gnu/system/file-systems.scm (%store-prefix): Check whether '%store-prefix' is defined. * guix/scripts/pack.scm (self-contained-tarball)[not-config?] [libgcrypt, schema]: New variables. [build]: Wrap in 'with-extensions'. Adjust imported module list to use 'make-config.scm' for (guix config). --- gnu/build/install.scm | 45 +++-- gnu/build/vm.scm | 1 + gnu/system/file-systems.scm | 11 +- gnu/system/vm.scm | 391 ++++++++++++++++++++++++-------------------- guix/scripts/pack.scm | 233 ++++++++++++++------------ 5 files changed, 379 insertions(+), 302 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 9e30c0d23e..6cc678b44b 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich ;;; ;;; This file is part of GNU Guix. @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build install) + #:use-module (guix store database) #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-26) @@ -158,23 +159,31 @@ as created and modified at the Epoch." (utime file 0 0 0 0)))) (find-files directory #:directories? #t))) -(define* (register-closure store closure - #:key (deduplicate? #t)) - "Register CLOSURE in STORE, where STORE is the directory name of the target -store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'. As a side effect, this resets timestamps on store files -and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the -rest of STORE." - (let ((status (apply system* "guix-register" "--prefix" store - (append (if deduplicate? '() '("--no-deduplication")) - (list closure))))) - (unless (zero? status) - (error "failed to register store items" closure)))) +(define* (register-closure prefix closure + #:key + (deduplicate? #t) (reset-timestamps? #t) + (schema (sql-schema))) + "Register CLOSURE in PREFIX, where PREFIX is the directory name of the +target store and CLOSURE is the name of a file containing a reference graph as +produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is +true, reset timestamps on store files and, if DEDUPLICATE? is true, +deduplicates files common to CLOSURE and the rest of PREFIX." + (let ((items (call-with-input-file closure read-reference-graph))) + ;; TODO: Add a procedure to register all of ITEMS at once. + (for-each (lambda (item) + (register-path (store-info-item item) + #:references (store-info-references item) + #:deriver (store-info-deriver item) + #:prefix prefix + #:deduplicate? deduplicate? + #:reset-timestamps? reset-timestamps? + #:schema schema)) + items))) (define* (populate-single-profile-directory directory #:key profile closure deduplicate? - register?) + register? schema) "Populate DIRECTORY with a store containing PROFILE, whose closure is given in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY is initialized to contain a single profile under /root pointing to PROFILE. @@ -200,11 +209,11 @@ This is used to create the self-contained tarballs with 'guix pack'." (when register? (register-closure (canonicalize-path directory) closure - #:deduplicate? deduplicate?) + #:deduplicate? deduplicate? + #:schema schema) - ;; XXX: 'guix-register' registers profiles as GC roots but the symlink - ;; target uses $TMPDIR. Fix that. - (delete-file (scope "/var/guix/gcroots/profiles")) + (mkdir-p* "/var/guix/profiles") + (mkdir-p* "/var/guix/gcroots") (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index fa3ce7790d..37639f723a 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -354,6 +354,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (for-each (lambda (closure) (register-closure target (string-append "/xchg/" closure) + #:reset-timestamps? copy-closures? #:deduplicate? deduplicate?)) closures) (unless copy-closures? diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 2b5948256a..393dd0df70 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -194,10 +194,15 @@ ;; differs from user to user. (define (%store-prefix) "Return the store prefix." - (cond ((resolve-module '(guix store) #:ensure #f) + ;; Note: If we have (guix store database) in the search path and we do *not* + ;; have (guix store) proper, 'resolve-module' returns an empty (guix store) + ;; with one sub-module. + (cond ((and=> (resolve-module '(guix store) #:ensure #f) + (lambda (store) + (module-variable store '%store-prefix))) => - (lambda (store) - ((module-ref store '%store-prefix)))) + (lambda (variable) + ((variable-ref variable)))) ((getenv "NIX_STORE") => identity) (else diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 94f1c6197a..b505b0cf6b 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -34,6 +34,7 @@ #:use-module (guix utils) #:use-module (guix hash) #:use-module (guix base32) + #:use-module ((guix self) #:select (make-config.scm)) #:use-module ((gnu build vm) #:select (qemu-command)) @@ -50,7 +51,6 @@ #:use-module (gnu packages disk) #:use-module (gnu packages zile) #:use-module (gnu packages linux) - #:use-module (gnu packages package-management) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) #:use-module (gnu packages admin) @@ -116,6 +116,19 @@ (options "trans=virtio") (check? #f)))) +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + +(define guile-sqlite3&co + ;; Guile-SQLite3 and its propagated inputs. + (cons guile-sqlite3 + (package-transitive-propagated-inputs guile-sqlite3))) + (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) @@ -151,6 +164,10 @@ based on the size of the closure of REFERENCES-GRAPHS. When REFERENCES-GRAPHS is true, it must be a list of file name/store path pairs, as for `derivation'. The files containing the reference graphs are made available under the /xchg CIFS share." + (define config + ;; (guix config) module for consumption by (guix gcrypt). + (make-config.scm #:libgcrypt libgcrypt)) + (define user-builder (program-file "builder-in-linux-vm" exp)) @@ -178,40 +195,44 @@ made available under the /xchg CIFS share." (define builder ;; Code that launches the VM that evaluates EXP. - (with-imported-modules (source-module-closure '((guix build utils) - (gnu build vm))) - #~(begin - (use-modules (guix build utils) - (gnu build vm)) - - (let* ((inputs '#$(list qemu coreutils)) - (linux (string-append #$linux "/" - #$(system-linux-image-file-name))) - (initrd (string-append #$initrd "/initrd")) - (loader #$loader) - (graphs '#$(match references-graphs - (((graph-files . _) ...) graph-files) - (_ #f))) - (size #$(if (eq? 'guess disk-image-size) - #~(+ (* 70 (expt 2 20)) ;ESP - (estimated-partition-size graphs)) - disk-image-size))) - - (set-path-environment-variable "PATH" '("bin") inputs) - - (load-in-linux-vm loader - #:output #$output - #:linux linux #:initrd initrd - #:memory-size #$memory-size - #:make-disk-image? #$make-disk-image? - #:single-file-output? #$single-file-output? - ;; FIXME: ‘target-arm32?’ may not operate on - ;; the right system/target values. Rewrite - ;; using ‘let-system’ when available. - #:target-arm32? #$(target-arm32?) - #:disk-image-format #$disk-image-format - #:disk-image-size size - #:references-graphs graphs))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure + '((guix build utils) + (gnu build vm)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (guix build utils) + (gnu build vm)) + + (let* ((inputs '#$(list qemu (canonical-package coreutils))) + (linux (string-append #$linux "/" + #$(system-linux-image-file-name))) + (initrd (string-append #$initrd "/initrd")) + (loader #$loader) + (graphs '#$(match references-graphs + (((graph-files . _) ...) graph-files) + (_ #f))) + (size #$(if (eq? 'guess disk-image-size) + #~(+ (* 70 (expt 2 20)) ;ESP + (estimated-partition-size graphs)) + disk-image-size))) + + (set-path-environment-variable "PATH" '("bin") inputs) + + (load-in-linux-vm loader + #:output #$output + #:linux linux #:initrd initrd + #:memory-size #$memory-size + #:make-disk-image? #$make-disk-image? + #:single-file-output? #$single-file-output? + ;; FIXME: ‘target-arm32?’ may not operate on + ;; the right system/target values. Rewrite + ;; using ‘let-system’ when available. + #:target-arm32? #$(target-arm32?) + #:disk-image-format #$disk-image-format + #:disk-image-size size + #:references-graphs graphs)))))) (gexp->derivation name builder ;; TODO: Require the "kvm" feature. @@ -234,42 +255,56 @@ made available under the /xchg CIFS share." "Return a bootable, stand-alone iso9660 image. INPUTS is a list of inputs (as for packages)." + (define config + (make-config.scm #:libgcrypt libgcrypt)) + + (define schema + (and register-closures? + (local-file (search-path %load-path + "guix/store/schema.sql")))) + (expression->derivation-in-linux-vm name - (with-imported-modules (source-module-closure '((gnu build vm) - (guix build utils))) - #~(begin - (use-modules (gnu build vm) - (guix build utils)) - - (let ((inputs - '#$(append (list qemu parted e2fsprogs dosfstools xorriso) - (map canonical-package - (list sed grep coreutils findutils gawk)) - (if register-closures? (list guix) '()))) - - - (graphs '#$(match inputs - (((names . _) ...) - names))) - ;; This variable is unused but allows us to add INPUTS-TO-COPY - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (make-iso9660-image #$(bootloader-package bootloader) - #$bootcfg-drv - #$os-drv - "/xchg/guixsd.iso" - #:register-closures? #$register-closures? - #:closures graphs - #:volume-id #$file-system-label - #:volume-uuid #$(and=> file-system-uuid - uuid-bytevector))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure '((gnu build vm) + (guix store database) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (gnu build vm) + (guix store database) + (guix build utils)) + + (sql-schema #$schema) + + (let ((inputs + '#$(append (list qemu parted e2fsprogs dosfstools xorriso) + (map canonical-package + (list sed grep coreutils findutils gawk)))) + + + (graphs '#$(match inputs + (((names . _) ...) + names))) + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-register + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (make-iso9660-image #$(bootloader-package bootloader) + #$bootcfg-drv + #$os-drv + "/xchg/guixsd.iso" + #:register-closures? #$register-closures? + #:closures graphs + #:volume-id #$file-system-label + #:volume-uuid #$(and=> file-system-uuid + uuid-bytevector)))))) #:system system ;; Keep a local file system for /tmp so that we can populate it directly as @@ -312,90 +347,104 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in the image." + (define config + (make-config.scm #:libgcrypt libgcrypt)) + + (define schema + (and register-closures? + (local-file (search-path %load-path + "guix/store/schema.sql")))) + (expression->derivation-in-linux-vm name - (with-imported-modules (source-module-closure '((gnu build bootloader) - (gnu build vm) - (guix build utils))) - #~(begin - (use-modules (gnu build bootloader) - (gnu build vm) - (guix build utils) - (srfi srfi-26) - (ice-9 binary-ports)) - - (let ((inputs - '#$(append (list qemu parted e2fsprogs dosfstools) - (map canonical-package - (list sed grep coreutils findutils gawk)) - (if register-closures? (list guix) '()))) - - ;; This variable is unused but allows us to add INPUTS-TO-COPY - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - - (let* ((graphs '#$(match inputs - (((names . _) ...) - names))) - (initialize (root-partition-initializer - #:closures graphs - #:copy-closures? #$copy-inputs? - #:register-closures? #$register-closures? - #:system-directory #$os-drv)) - (root-size #$(if (eq? 'guess disk-image-size) - #~(max - ;; Minimum 20 MiB root size - (* 20 (expt 2 20)) - (estimated-partition-size - (map (cut string-append "/xchg/" <>) - graphs))) - (- disk-image-size - (* 50 (expt 2 20))))) - (partitions - (append - (list (partition - (size root-size) - (label #$file-system-label) - (uuid #$(and=> file-system-uuid - uuid-bytevector)) - (file-system #$file-system-type) - (flags '(boot)) - (initializer initialize))) - ;; Append a small EFI System Partition for use with UEFI - ;; bootloaders if we are not targeting ARM because UEFI - ;; support in U-Boot is experimental. - ;; - ;; FIXME: ‘target-arm32?’ may be not operate on the right - ;; system/target values. Rewrite using ‘let-system’ when - ;; available. - (if #$(target-arm32?) - '() - (list (partition - ;; The standalone grub image is about 10MiB, but - ;; leave some room for custom or multiple images. - (size (* 40 (expt 2 20))) - (label "GNU-ESP") ;cosmetic only - ;; Use "vfat" here since this property is used - ;; when mounting. The actual FAT-ness is based - ;; on file system size (16 in this case). - (file-system "vfat") - (flags '(esp)))))))) - (initialize-hard-disk "/dev/vda" - #:partitions partitions - #:grub-efi #$grub-efi - #:bootloader-package - #$(bootloader-package bootloader) - #:bootcfg #$bootcfg-drv - #:bootcfg-location - #$(bootloader-configuration-file bootloader) - #:bootloader-installer - #$(bootloader-installer bootloader)))))) + (with-extensions guile-sqlite3&co + (with-imported-modules `(,@(source-module-closure '((gnu build vm) + (gnu build bootloader) + (guix store database) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + (use-modules (gnu build bootloader) + (gnu build vm) + (guix store database) + (guix build utils) + (srfi srfi-26) + (ice-9 binary-ports)) + + (sql-schema #$schema) + + (let ((inputs + '#$(append (list qemu parted e2fsprogs dosfstools) + (map canonical-package + (list sed grep coreutils findutils gawk)))) + + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-register + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + (let* ((graphs '#$(match inputs + (((names . _) ...) + names))) + (initialize (root-partition-initializer + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? + #:system-directory #$os-drv)) + (root-size #$(if (eq? 'guess disk-image-size) + #~(max + ;; Minimum 20 MiB root size + (* 20 (expt 2 20)) + (estimated-partition-size + (map (cut string-append "/xchg/" <>) + graphs))) + (- disk-image-size + (* 50 (expt 2 20))))) + (partitions + (append + (list (partition + (size root-size) + (label #$file-system-label) + (uuid #$(and=> file-system-uuid + uuid-bytevector)) + (file-system #$file-system-type) + (flags '(boot)) + (initializer initialize))) + ;; Append a small EFI System Partition for use with UEFI + ;; bootloaders if we are not targeting ARM because UEFI + ;; support in U-Boot is experimental. + ;; + ;; FIXME: ‘target-arm32?’ may be not operate on the right + ;; system/target values. Rewrite using ‘let-system’ when + ;; available. + (if #$(target-arm32?) + '() + (list (partition + ;; The standalone grub image is about 10MiB, but + ;; leave some room for custom or multiple images. + (size (* 40 (expt 2 20))) + (label "GNU-ESP") ;cosmetic only + ;; Use "vfat" here since this property is used + ;; when mounting. The actual FAT-ness is based + ;; on file system size (16 in this case). + (file-system "vfat") + (flags '(esp)))))))) + (initialize-hard-disk "/dev/vda" + #:partitions partitions + #:grub-efi #$grub-efi + #:bootloader-package + #$(bootloader-package bootloader) + #:bootcfg #$bootcfg-drv + #:bootcfg-location + #$(bootloader-configuration-file bootloader) + #:bootloader-installer + #$(bootloader-installer bootloader))))))) #:system system #:make-disk-image? #t #:disk-image-size disk-image-size @@ -413,49 +462,41 @@ makes sense when you want to build a GuixSD Docker image that has Guix installed inside of it. If you don't need Guix (e.g., your GuixSD Docker image just contains a web server that is started by the Shepherd), then you should set REGISTER-CLOSURES? to #f." - (define not-config? - (match-lambda - (('guix 'config) #f) - (('guix rest ...) #t) - (('gnu rest ...) #t) - (rest #f))) - (define config ;; (guix config) module for consumption by (guix gcrypt). - (scheme-file "gcrypt-config.scm" - #~(begin - (define-module (guix config) - #:export (%libgcrypt)) + (make-config.scm #:libgcrypt libgcrypt)) - ;; XXX: Work around . - (eval-when (expand load eval) - (define %libgcrypt - #+(file-append libgcrypt "/lib/libgcrypt")))))) + (define schema + (and register-closures? + (local-file (search-path %load-path + "guix/store/schema.sql")))) (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (name -> (string-append name ".tar.gz")) (graph -> "system-graph")) (define build - (with-extensions (list guile-json) ;for (guix docker) + (with-extensions (cons guile-json ;for (guix docker) + guile-sqlite3&co) ;for (guix store database) (with-imported-modules `(,@(source-module-closure '((guix docker) + (guix store database) (guix build utils) + (guix build store-copy) (gnu build vm)) #:select? not-config?) - (guix build store-copy) ((guix config) => ,config)) #~(begin (use-modules (guix docker) (guix build utils) (gnu build vm) (srfi srfi-19) - (guix build store-copy)) + (guix build store-copy) + (guix store database)) + + ;; Set the SQL schema location. + (sql-schema #$schema) - (let* ((inputs '#$(append (list tar) - (if register-closures? - (list guix) - '()))) - ;; This initializer requires elevated privileges that are + (let* (;; This initializer requires elevated privileges that are ;; not normally available in the build environment (e.g., ;; it needs to create device nodes). In order to obtain ;; such privileges, we run it as root in a VM. @@ -470,7 +511,7 @@ should set REGISTER-CLOSURES? to #f." ;; lack of privileges if we use a root-directory that is on ;; a file system that is shared with the host (e.g., /tmp). (root-directory "/guixsd-system-root")) - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar)) (mkdir root-directory) (initialize root-directory) (build-docker-image diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78bfd01eff..ed876b2592 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) @@ -101,113 +102,133 @@ 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 not-config? + (match-lambda + (('guix 'config) #f) + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) - (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: - ;; . - (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 libgcrypt + (module-ref (resolve-interface '(gnu packages gnupg)) + 'libgcrypt)) + + (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 (cons guile-sqlite3 + (package-transitive-propagated-inputs + guile-sqlite3)) + #~(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: + ;; . + (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)) -- cgit v1.2.3 From ef1297e8c74a0358d2538a5dd43d50cde7bf14a3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Jun 2018 21:55:15 +0200 Subject: database: 'sqlite-register' takes a database, not a file name. * guix/store/database.scm (sqlite-register): Remove #:db-file and add 'db' parameter. Remove #:schema and 'parameterize'. (register-path): Wrap 'sqlite-register' call in 'with-database' and in 'parameterize'. * tests/store-database.scm ("new database") ("register-path with unregistered references"): Adjust accordingly. --- guix/store/database.scm | 57 ++++++++++++++++++++++-------------------------- tests/store-database.scm | 40 ++++++++++++++++----------------- 2 files changed, 46 insertions(+), 51 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 67dfb8b0ee..1e5e3bcc71 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -157,30 +157,24 @@ ids of items referred to." (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 - (schema (sql-schema))) - "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. +(define* (sqlite-register db #:key path (references '()) + deriver hash nar-size) + "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. Every store item in REFERENCES must already be registered." - (parameterize ((sql-schema schema)) - (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))))) - ;; 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)))))) + (let ((id (update-or-insert db #:path path + #:deriver deriver + #:hash hash + #:nar-size nar-size + #:time (time-second (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)))) ;;; @@ -267,15 +261,16 @@ be used internally by the daemon's build hook." (when reset-timestamps? (reset-timestamps real-path)) (mkdir-p db-dir) - (sqlite-register - #:db-file (string-append db-dir "/db.sqlite") - #:schema schema - #:path to-register - #:references references - #:deriver deriver - #:hash (string-append "sha256:" - (bytevector->base16-string hash)) - #:nar-size nar-size) + (parameterize ((sql-schema schema)) + (with-database (string-append db-dir "/db.sqlite") db + (sqlite-register + db + #:path to-register + #:references references + #:deriver deriver + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size))) (when deduplicate? (deduplicate real-path hash #:store store-dir))))) diff --git a/tests/store-database.scm b/tests/store-database.scm index 9562055fd1..22c356679b 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -57,20 +57,20 @@ (call-with-temporary-output-file (lambda (db-file port) (delete-file db-file) - (sqlite-register #:db-file db-file - #:path "/gnu/foo" - #:references '() - #:deriver "/gnu/foo.drv" - #:hash (string-append "sha256:" (make-string 64 #\e)) - #:nar-size 1234) - (sqlite-register #:db-file db-file - #:path "/gnu/bar" - #:references '("/gnu/foo") - #:deriver "/gnu/bar.drv" - #:hash (string-append "sha256:" (make-string 64 #\a)) - #:nar-size 4321) - (let ((path-id (@@ (guix store database) path-id))) - (with-database db-file db + (with-database db-file db + (sqlite-register db + #:path "/gnu/foo" + #:references '() + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size 1234) + (sqlite-register db + #:path "/gnu/bar" + #:references '("/gnu/foo") + #:deriver "/gnu/bar.drv" + #:hash (string-append "sha256:" (make-string 64 #\a)) + #:nar-size 4321) + (let ((path-id (@@ (guix store database) path-id))) (list (path-id db "/gnu/foo") (path-id db "/gnu/bar"))))))) @@ -83,12 +83,12 @@ (delete-file db-file) (catch 'sqlite-error (lambda () - (sqlite-register #:db-file db-file - #:path "/gnu/foo" - #:references '("/gnu/bar") - #:deriver "/gnu/foo.drv" - #:hash (string-append "sha256:" (make-string 64 #\e)) - #:nar-size 1234) + (with-database db-file db + (sqlite-register db #:path "/gnu/foo" + #:references '("/gnu/bar") + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size 1234)) #f) (lambda args (pk 'welcome-exception! args) -- cgit v1.2.3 From 31a63be8784b2769c2db21388f788a8b975fd4e1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Jun 2018 22:23:57 +0200 Subject: database: Add 'register-items'. * guix/build/store-copy.scm (store-info): Export. * guix/store/database.scm (register-items): New procedure. (register-path): Implement in terms of 'register-items'. * gnu/build/install.scm (register-closure): Use 'register-items' instead of 'for-each' and 'register-path'. --- gnu/build/install.scm | 15 ++---- guix/build/store-copy.scm | 1 + guix/store/database.scm | 113 +++++++++++++++++++++++++++------------------- 3 files changed, 72 insertions(+), 57 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 6cc678b44b..82eb63d726 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -169,16 +169,11 @@ produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is true, reset timestamps on store files and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the rest of PREFIX." (let ((items (call-with-input-file closure read-reference-graph))) - ;; TODO: Add a procedure to register all of ITEMS at once. - (for-each (lambda (item) - (register-path (store-info-item item) - #:references (store-info-references item) - #:deriver (store-info-deriver item) - #:prefix prefix - #:deduplicate? deduplicate? - #:reset-timestamps? reset-timestamps? - #:schema schema)) - items))) + (register-items items + #:prefix prefix + #:deduplicate? deduplicate? + #:reset-timestamps? reset-timestamps? + #:schema schema))) (define* (populate-single-profile-directory directory #:key profile closure diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index bad1c09cba..2d9590d16f 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -27,6 +27,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 vlist) #:export (store-info? + store-info store-info-item store-info-deriver store-info-references diff --git a/guix/store/database.scm b/guix/store/database.scm index 1e5e3bcc71..3dbe5270a3 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -26,6 +26,7 @@ #: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) @@ -37,6 +38,7 @@ with-database sqlite-register register-path + register-items reset-timestamps)) ;;; Code for working with the store database directly. @@ -216,11 +218,6 @@ it's a directory. While at it, canonicalize file permissions." state-directory (deduplicate? #t) (reset-timestamps? #t) (schema (sql-schema))) - ;; 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. "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 @@ -230,47 +227,69 @@ 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))) - (when reset-timestamps? - (reset-timestamps real-path)) - (mkdir-p db-dir) - (parameterize ((sql-schema schema)) - (with-database (string-append db-dir "/db.sqlite") db - (sqlite-register - db - #: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* (register-items items + #:key prefix state-directory + (deduplicate? #t) + (reset-timestamps? #t) + (schema (sql-schema))) + "Register all of ITEMS, a list of 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." + ;; 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) (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)))) -- cgit v1.2.3 From 078c2329c0ffc88ac8e334fcea5e025ee6410e62 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Jun 2018 22:35:36 +0200 Subject: install: Use 'reset-timestamps' from (guix store database). * gnu/build/install.scm (reset-timestamps): Remove. * gnu/build/vm.scm: Use 'reset-timestamps' from (guix store database). --- gnu/build/install.scm | 15 --------------- gnu/build/vm.scm | 1 + guix/store/database.scm | 1 - 3 files changed, 1 insertion(+), 16 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 82eb63d726..5e84cd6f69 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -26,7 +26,6 @@ #:export (install-boot-config evaluate-populate-directive populate-root-file-system - reset-timestamps register-closure populate-single-profile-directory)) @@ -145,20 +144,6 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM." (try)) (apply throw args))))))) -(define (reset-timestamps directory) - "Reset the timestamps of all the files under DIRECTORY, so that they appear -as created and modified at the Epoch." - (display "clearing file timestamps...\n") - (for-each (lambda (file) - (let ((s (lstat file))) - ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so - ;; the timestamp of symlinks cannot be changed, and there are - ;; symlinks here pointing to /gnu/store, which is the host, - ;; read-only store. - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files directory #:directories? #t))) - (define* (register-closure prefix closure #:key (deduplicate? #t) (reset-timestamps? #t) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 37639f723a..803cd5996a 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -25,6 +25,7 @@ #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (guix build syscalls) + #:use-module ((guix store database) #:select (reset-timestamps)) #:use-module (gnu build linux-boot) #:use-module (gnu build install) #:use-module (gnu system uuid) diff --git a/guix/store/database.scm b/guix/store/database.scm index 3dbe5270a3..82938455ba 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -183,7 +183,6 @@ Every store item in REFERENCES must already be registered." ;;; 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. While at it, canonicalize file permissions." -- cgit v1.2.3 From eb9fe97495c012c989f76cb42a14cd78f9d94629 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jun 2018 00:00:47 +0200 Subject: database: Allow for deterministic database construction. Fixes . * guix/store/database.scm (sqlite-register): Add #:time. (%epoch): New variable. (register-items): Add #:registration-time. Pass #:time to 'sqlite-register'. * gnu/build/install.scm (register-closure): Pass #:registration-time. --- gnu/build/install.scm | 1 + guix/store/database.scm | 21 ++++++++++++++++----- 2 files changed, 17 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 5e84cd6f69..06ecb39952 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -158,6 +158,7 @@ deduplicates files common to CLOSURE and the rest of PREFIX." #:prefix prefix #:deduplicate? deduplicate? #:reset-timestamps? reset-timestamps? + #:registration-time %epoch #:schema schema))) (define* (populate-single-profile-directory directory diff --git a/guix/store/database.scm b/guix/store/database.scm index 82938455ba..05b2ba6c3f 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -39,6 +39,7 @@ sqlite-register register-path register-items + %epoch reset-timestamps)) ;;; Code for working with the store database directly. @@ -160,19 +161,22 @@ ids of items referred to." references))) (define* (sqlite-register db #:key path (references '()) - deriver hash nar-size) + 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. +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 (current-time time-utc))))) + #: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 @@ -232,15 +236,21 @@ be used internally by the daemon's build hook." #: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 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." +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 @@ -284,7 +294,8 @@ initially empty, apply SCHEMA to initialize it." #:deriver (store-info-deriver item) #:hash (string-append "sha256:" (bytevector->base16-string hash)) - #:nar-size nar-size) + #:nar-size nar-size + #:time registration-time) (when deduplicate? (deduplicate real-file-name hash #:store store-dir)))) -- cgit v1.2.3 From df2f6400b1fbc282ef4d6dd7124ea1c17adc23c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jun 2018 10:56:19 +0200 Subject: store: Remove 'register-path'. * guix/store.scm (register-path): Remove. * guix/nar.scm: Use (guix store database). * guix/scripts/system.scm: Likewise. * tests/store-database.scm: Remove #:hide (register-path). * tests/store.scm ("register-path"): Remove. --- guix/nar.scm | 3 ++- guix/scripts/system.scm | 1 + guix/store.scm | 29 ----------------------------- tests/store-database.scm | 2 +- tests/store.scm | 22 +--------------------- 5 files changed, 5 insertions(+), 52 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès ;;; Copyright © 2014 Mark H Weaver ;;; ;;; 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/scripts/system.scm b/guix/scripts/system.scm index 14be8ff8cf..9112177bfb 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -23,6 +23,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) diff --git a/guix/store.scm b/guix/store.scm index 6742611c6f..773d53e82b 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -122,8 +122,6 @@ current-build-output-port - register-path - %store-monad store-bind store-return @@ -1301,33 +1299,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/tests/store-database.scm b/tests/store-database.scm index 22c356679b..fcae66e2de 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -18,7 +18,7 @@ (define-module (test-store-database) #:use-module (guix tests) - #:use-module ((guix store) #:hide (register-path)) + #:use-module (guix store) #:use-module (guix store database) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:use-module (srfi srfi-26) diff --git a/tests/store.scm b/tests/store.scm index fdf3be33f6..afecec940a 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -777,26 +777,6 @@ (pk 'corrupt-imported imported) #f))))) -(test-assert "register-path" - (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) - "-fake"))) - (when (valid-path? %store file) - (delete-paths %store (list file))) - (false-if-exception (delete-file file)) - - (let ((ref (add-text-to-store %store "ref-of-fake" (random-text))) - (drv (string-append file ".drv"))) - (call-with-output-file file - (cut display "This is a fake store item.\n" <>)) - (register-path file - #:references (list ref) - #:deriver drv) - - (and (valid-path? %store file) - (equal? (references %store file) (list ref)) - (null? (valid-derivers %store file)) - (null? (referrers %store file)))))) - (test-assert "verify-store" (let* ((text (random-text)) (file1 (add-text-to-store %store "foo" text)) -- cgit v1.2.3 From ea0a06cee2ba05451f94714a4f913db02efbe92c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jun 2018 11:03:31 +0200 Subject: Remove 'guix-register' and its traces. * Makefile.am (SH_TESTS): Remove tests/guix-register.sh. * build-aux/pre-inst-env.in (GUIX_REGISTER): Remove. * gnu/build/install.scm (directives): Remove outdated comment. * gnu/build/vm.scm (root-partition-initializer): Update comment. * gnu/packages/package-management.scm (guix-register): Remove. * guix/config.scm.in (%sbindir, %guix-register-program): Remove. * guix/scripts/system.scm (install): Adjust docstring. * guix/self.scm (make-config.scm): Remove #:guix. Do not generate %sbindir and %guix-register-program. (specification->package): Remove "guix". * nix/guix-register/guix-register.cc: Remove. * nix/libstore/store-api.cc (decodeValidPathInfo): Remove. * nix/libstore/store-api.hh (decodeValidPathInfo): Remove declaration. * nix/local.mk (sbin_PROGRAMS, guix_register_SOURCES) (guix_register_CPPFLAGS, guix_register_LDFLAGS): Remove. * tests/guix-register.sh: Remove. --- .gitignore | 1 - Makefile.am | 7 - build-aux/pre-inst-env.in | 6 +- gnu/build/install.scm | 3 - gnu/build/vm.scm | 4 +- gnu/packages/package-management.scm | 36 ----- guix/config.scm.in | 12 +- guix/scripts/system.scm | 2 +- guix/self.scm | 21 +-- nix/guix-register/guix-register.cc | 254 ------------------------------------ nix/libstore/store-api.cc | 26 ---- nix/libstore/store-api.hh | 4 - nix/local.mk | 16 --- tests/guix-register.sh | 191 --------------------------- 14 files changed, 7 insertions(+), 576 deletions(-) delete mode 100644 nix/guix-register/guix-register.cc delete mode 100644 tests/guix-register.sh (limited to 'guix') diff --git a/.gitignore b/.gitignore index e2568ed5fe..35d50b35af 100644 --- a/.gitignore +++ b/.gitignore @@ -69,7 +69,6 @@ /etc/guix-publish.conf /etc/guix-publish.service /guix-daemon -/guix-register /guix/config.scm /libformat.a /libstore.a diff --git a/Makefile.am b/Makefile.am index f4cdba94a2..61a19b6b9e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -405,13 +405,6 @@ SH_TESTS = \ tests/guix-graph.sh \ tests/guix-lint.sh -if BUILD_DAEMON - -SH_TESTS += tests/guix-register.sh - -endif BUILD_DAEMON - - TESTS = $(SCM_TESTS) $(SH_TESTS) AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" GUILE_AUTO_COMPILE=0 diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in index 14315d40d4..286a81591c 100644 --- a/build-aux/pre-inst-env.in +++ b/build-aux/pre-inst-env.in @@ -1,7 +1,7 @@ #!/bin/sh # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2017 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès # Copyright © 2017 Eric Bavier # # This file is part of GNU Guix. @@ -55,10 +55,6 @@ NIX_BUILD_HOOK="$abs_top_builddir/nix/scripts/offload" @BUILD_DAEMON_OFFLOAD_FALSE@# No offloading support. @BUILD_DAEMON_OFFLOAD_FALSE@unset NIX_BUILD_HOOK -# The 'guix-register' program. -GUIX_REGISTER="$abs_top_builddir/guix-register" -export GUIX_REGISTER - # The following variables need only be defined when compiling Guix # modules, but we define them to be on the safe side in case of # auto-compilation. diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 06ecb39952..5a5e703872 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -110,9 +110,6 @@ STORE." ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") - - ;; XXX: 'guix-register' creates this symlink with a wrong target, so - ;; create it upfront to be sure. ("/var/guix/gcroots/profiles" -> "/var/guix/profiles") (directory "/bin") diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 803cd5996a..73d0191de7 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -346,7 +346,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." ;; Optionally, register the inputs in the image's store. (when register-closures? (unless copy-closures? - ;; XXX: 'guix-register' wants to palpate the things it registers, so + ;; XXX: 'register-closure' wants to palpate the things it registers, so ;; bind-mount the store on the target. (mkdir-p target-store) (mount (%store-directory) target-store "" MS_BIND)) @@ -365,7 +365,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (display "populating...\n") (populate-root-file-system system-directory target) - ;; 'guix-register' resets timestamps and everything, so no need to do it + ;; 'register-closure' resets timestamps and everything, so no need to do it ;; once more in that case. (unless register-closures? (reset-timestamps target)))) diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 786d2a53e9..24cf3ad015 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -294,42 +294,6 @@ the Nix package manager.") ;; Alias for backward compatibility. (define-public guix-devel guix) -(define-public guix-register - ;; This package is for internal consumption: it allows us to quickly build - ;; the 'guix-register' program, which is referred to by (guix config). - ;; TODO: Remove this hack when 'guix-register' has been superseded by Scheme - ;; code. - (package - (inherit guix) - (properties `((hidden? . #t))) - (name "guix-register") - - ;; Use a minimum set of dependencies. - (native-inputs - (fold alist-delete (package-native-inputs guix) - '("po4a" "graphviz" "help2man"))) - (propagated-inputs - `(("gnutls" ,gnutls) - ("guile-git" ,guile-git))) - - (arguments - (substitute-keyword-arguments (package-arguments guix) - ((#:tests? #f #f) - #f) - ((#:phases phases '%standard-phases) - `(modify-phases ,phases - (replace 'build - (lambda _ - (invoke "make" "nix/libstore/schema.sql.hh") - (invoke "make" "-j" (number->string - (parallel-job-count)) - "guix-register"))) - (delete 'copy-bootstrap-guile) - (replace 'install - (lambda _ - (invoke "make" "install-sbinPROGRAMS"))) - (delete 'wrap-program))))))) - (define-public guile2.0-guix (package (inherit guix) diff --git a/guix/config.scm.in b/guix/config.scm.in index aeea81bd3f..4490112e07 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 +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès ;;; Copyright © 2017 Caleb Ristvedt ;;; ;;; This file is part of GNU Guix. @@ -26,13 +26,11 @@ %storedir %localstatedir %sysconfdir - %sbindir %store-directory %state-directory %store-database-directory %config-directory - %guix-register-program %system %libgcrypt @@ -70,9 +68,6 @@ (define %sysconfdir "@guix_sysconfdir@") -(define %sbindir - "@guix_sbindir@") - (define %store-directory (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) %storedir)) @@ -91,11 +86,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@") diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9112177bfb..727f1ac55f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -198,7 +198,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) diff --git a/guix/self.scm b/guix/self.scm index ed3f31cdbc..3023ae379b 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -89,8 +89,6 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("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)) @@ -565,7 +563,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the #:gzip gzip #:bzip2 bzip2 #:xz xz - #:guix guix #:package-name %guix-package-name #:package-version @@ -630,8 +627,7 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (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 %nix-instantiate)) (define %persona-variables ;; (guix config) variables that define Guix's persona. @@ -653,7 +649,7 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (stringstring (car name+value1)) (symbol->string (car name+value2)))))) -(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 guix +(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -669,8 +665,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the %guix-version %guix-bug-report-address %guix-home-page-url - %sbindir - %guix-register-program %libgcrypt %libz %gzip @@ -688,17 +682,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (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 diff --git a/nix/guix-register/guix-register.cc b/nix/guix-register/guix-register.cc deleted file mode 100644 index 16dae62b3d..0000000000 --- a/nix/guix-register/guix-register.cc +++ /dev/null @@ -1,254 +0,0 @@ -/* GNU Guix --- Functional package management for GNU - Copyright (C) 2013, 2014, 2015 Ludovic Courtès - Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, - 2013 Eelco Dolstra - - This file is part of GNU Guix. - - GNU Guix is free software; you can redistribute it and/or modify it - under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 3 of the License, or (at - your option) any later version. - - GNU Guix is distributed in the hope that it will be useful, but - WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with GNU Guix. If not, see . */ - -/* This file derives from the implementation of 'nix-store - --register-validity', by Eelco Dolstra, as found in the Nix package - manager's src/nix-store/nix-store.cc. */ - -#include - -#include -#include - -#include -#include -#include -#include - -#include -#include - -using namespace nix; - -/* Input stream where we read closure descriptions. */ -static std::istream *input = &std::cin; - - - -/* Command-line options. */ - -const char *argp_program_version = - "guix-register (" PACKAGE_NAME ") " PACKAGE_VERSION; -const char *argp_program_bug_address = PACKAGE_BUGREPORT; - -static char doc[] = -"guix-register -- register a closure as valid in a store\ -\v\ -This program is used internally when populating a store with data \ -from an existing store. It updates the new store's database with \ -information about which store files are valid, and what their \ -references are."; - -#define GUIX_OPT_STATE_DIRECTORY 1 -#define GUIX_OPT_DEDUPLICATE 2 - -static const struct argp_option options[] = - { - { "prefix", 'p', "DIRECTORY", 0, - "Open the store that lies under DIRECTORY" }, - { "state-directory", GUIX_OPT_STATE_DIRECTORY, "DIRECTORY", 0, - "Use DIRECTORY as the state directory of the target store" }, - { "no-deduplication", GUIX_OPT_DEDUPLICATE, 0, 0, - "Disable automatic deduplication of registered store items" }, - { 0, 0, 0, 0, 0 } - }; - - -/* Prefix of the store being populated. */ -static std::string prefix; - -/* Whether to deduplicate the registered store items. */ -static bool deduplication = true; - -/* Parse a single option. */ -static error_t -parse_opt (int key, char *arg, struct argp_state *state) -{ - switch (key) - { - case 'p': - { - prefix = canonPath (arg); - settings.nixStore = prefix + NIX_STORE_DIR; - settings.nixDataDir = prefix + NIX_DATA_DIR; - settings.nixLogDir = prefix + NIX_LOG_DIR; - settings.nixStateDir = prefix + NIX_STATE_DIR; - settings.nixDBPath = settings.nixStateDir + "/db"; - break; - } - - case GUIX_OPT_STATE_DIRECTORY: - { - string state_dir = canonPath (arg); - - settings.nixStateDir = state_dir; - settings.nixDBPath = state_dir + "/db"; - break; - } - - case GUIX_OPT_DEDUPLICATE: - deduplication = false; - break; - - case ARGP_KEY_ARG: - { - std::ifstream *file; - - if (state->arg_num >= 2) - /* Too many arguments. */ - argp_usage (state); - - file = new std::ifstream (); - file->open (arg); - - input = file; - } - break; - - default: - return (error_t) ARGP_ERR_UNKNOWN; - } - - return (error_t) 0; -} - -/* Argument parsing. */ -static struct argp argp = { options, parse_opt, 0, doc }; - - -/* Read from INPUT the description of a closure, and register it as valid in - STORE. The expected format on INPUT is that used by #:references-graphs: - - FILE - DERIVER - NUMBER-OF-REFERENCES - REF1 - ... - REFN - - This is really meant as an internal format. */ -static void -register_validity (LocalStore *store, std::istream &input, - bool optimize = true, - bool reregister = true, bool hashGiven = false, - bool canonicalise = true) -{ - ValidPathInfos infos; - - while (1) - { - ValidPathInfo info = decodeValidPathInfo (input, hashGiven); - if (info.path == "") - break; - - if (!prefix.empty ()) - { - /* Rewrite the input to refer to the final name, as if we were in a - chroot under PREFIX. */ - std::string final_prefix (NIX_STORE_DIR "/"); - info.path = final_prefix + baseNameOf (info.path); - } - - /* Keep its real path to canonicalize it and compute its hash. */ - std::string real_path; - real_path = prefix + "/" + settings.nixStore + "/" + baseNameOf (info.path); - - if (!store->isValidPath (info.path) || reregister) - { - /* !!! races */ - if (canonicalise) - canonicalisePathMetaData (real_path, -1); - - if (!hashGiven) - { - HashResult hash = hashPath (htSHA256, real_path); - info.hash = hash.first; - info.narSize = hash.second; - } - infos.push_back (info); - } - } - - store->registerValidPaths (infos); - - /* XXX: When PREFIX is non-empty, store->linksDir points to the original - store's '.links' directory, which means 'optimisePath' would try to link - to that instead of linking to the target store. Thus, disable - deduplication in this case. */ - if (optimize) - { - /* Make sure deduplication is enabled. */ - settings.autoOptimiseStore = true; - - std::string store_dir = settings.nixStore; - - /* 'optimisePath' creates temporary links under 'settings.nixStore' and - this must be the real target store, under PREFIX, to avoid - cross-device links. Thus, temporarily switch the value of - 'settings.nixStore'. */ - settings.nixStore = prefix + store_dir; - for (auto&& i: infos) - store->optimisePath (prefix + i.path); - settings.nixStore = store_dir; - } -} - - -int -main (int argc, char *argv[]) -{ - /* Initialize libgcrypt, which is indirectly used. */ - if (!gcry_check_version (GCRYPT_VERSION)) - { - fprintf (stderr, "error: libgcrypt version mismatch\n"); - exit (EXIT_FAILURE); - } - - /* Tell Libgcrypt that initialization has completed, as per the Libgcrypt - 1.6.0 manual (although this does not appear to be strictly needed.) */ - gcry_control (GCRYCTL_INITIALIZATION_FINISHED, 0); - - /* Honor the environment variables, and initialize the settings. */ - settings.processEnvironment (); - - try - { - argp_parse (&argp, argc, argv, 0, 0, 0); - - /* Instantiate the store. This creates any missing directories among - 'settings.nixStore', 'settings.nixDBPath', etc. */ - LocalStore store; - - if (!prefix.empty ()) - /* Under the --prefix tree, the final name of the store will be - NIX_STORE_DIR. Set it here so that the database uses file names - prefixed by NIX_STORE_DIR and not PREFIX + NIX_STORE_DIR. */ - settings.nixStore = NIX_STORE_DIR; - - register_validity (&store, *input, deduplication); - } - catch (std::exception &e) - { - fprintf (stderr, "error: %s\n", e.what ()); - return EXIT_FAILURE; - } - - return EXIT_SUCCESS; -} diff --git a/nix/libstore/store-api.cc b/nix/libstore/store-api.cc index 6742d2ed49..9e07c67e97 100644 --- a/nix/libstore/store-api.cc +++ b/nix/libstore/store-api.cc @@ -226,32 +226,6 @@ string StoreAPI::makeValidityRegistration(const PathSet & paths, return s; } - -ValidPathInfo decodeValidPathInfo(std::istream & str, bool hashGiven) -{ - ValidPathInfo info; - getline(str, info.path); - if (str.eof()) { info.path = ""; return info; } - if (hashGiven) { - string s; - getline(str, s); - info.hash = parseHash(htSHA256, s); - getline(str, s); - if (!string2Int(s, info.narSize)) throw Error("number expected"); - } - getline(str, info.deriver); - string s; int n; - getline(str, s); - if (!string2Int(s, n)) throw Error("number expected"); - while (n--) { - getline(str, s); - info.references.insert(s); - } - if (!str || str.eof()) throw Error("missing input"); - return info; -} - - string showPaths(const PathSet & paths) { string s; diff --git a/nix/libstore/store-api.hh b/nix/libstore/store-api.hh index e957cedebc..2d9dcbd573 100644 --- a/nix/libstore/store-api.hh +++ b/nix/libstore/store-api.hh @@ -371,10 +371,6 @@ std::shared_ptr openStore(bool reserveSpace = true); string showPaths(const PathSet & paths); -ValidPathInfo decodeValidPathInfo(std::istream & str, - bool hashGiven = false); - - /* Export multiple paths in the format expected by ‘nix-store --import’. */ void exportPaths(StoreAPI & store, const Paths & paths, diff --git a/nix/local.mk b/nix/local.mk index b4c6ba61a4..140c78df37 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -120,7 +120,6 @@ libstore_a_CXXFLAGS = $(AM_CXXFLAGS) \ $(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS) bin_PROGRAMS = guix-daemon -sbin_PROGRAMS = guix-register guix_daemon_SOURCES = \ %D%/nix-daemon/nix-daemon.cc \ @@ -138,24 +137,9 @@ guix_daemon_LDADD = \ guix_daemon_headers = \ %D%/nix-daemon/shared.hh - -guix_register_SOURCES = \ - %D%/guix-register/guix-register.cc - -guix_register_CPPFLAGS = \ - $(libutil_a_CPPFLAGS) \ - $(libstore_a_CPPFLAGS) \ - -I$(top_srcdir)/%D%/libstore - -# XXX: Should we start using shared libs? -guix_register_LDADD = \ - libstore.a libutil.a libformat.a -lz \ - $(SQLITE3_LIBS) $(LIBGCRYPT_LIBS) - if HAVE_LIBBZ2 guix_daemon_LDADD += -lbz2 -guix_register_LDADD += -lbz2 endif HAVE_LIBBZ2 diff --git a/tests/guix-register.sh b/tests/guix-register.sh deleted file mode 100644 index 521735b8a4..0000000000 --- a/tests/guix-register.sh +++ /dev/null @@ -1,191 +0,0 @@ -# GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès -# -# This file is part of GNU Guix. -# -# GNU Guix is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or (at -# your option) any later version. -# -# GNU Guix is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with GNU Guix. If not, see . - -# -# Test the 'guix-register' command-line utility. -# - -guix-register --version - -new_store="t-register-$$" -closure="t-register-closure-$$" -rm -rf "$new_store" - -exit_hook=":" -trap "chmod -R +w $new_store ; rm -rf $new_store $closure ; \$exit_hook" EXIT - -# -# Registering items in the current store---i.e., without '--prefix'. -# - -new_file="$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-guix-register-$$" -echo "Fake store file to test registration." > "$new_file" - -# Register the file with zero references and no deriver. -guix-register < "$new_file2" -guix-register <> "$closure" < Date: Thu, 14 Jun 2018 21:17:08 +0200 Subject: guix: ui: Allow translation of dates. * guix/ui.scm (display-generation): Allow translation of dates. The format string will show dates as month day year, but some languages use a different convention. --- guix/ui.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 99f66b0fdc..31830ee850 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1391,7 +1391,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 -- cgit v1.2.3 From baed923682802b7281bd68274f080d2bb55d3eff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Jun 2018 21:59:23 +0200 Subject: self: Add 'guix-daemon' to the result. * gnu/packages/package-management.scm (guix-daemon): New variable. * guix/self.scm (whole-package): Add #:daemon and honor it. (compiled-guix): Pass #:daemon to 'whole-package'. --- gnu/packages/package-management.scm | 47 +++++++++++++++++++++++++++++++++++++ guix/self.scm | 15 +++++++++++- 2 files changed, 61 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 24cf3ad015..6d99cddc0d 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -294,6 +294,53 @@ the Nix package manager.") ;; Alias for backward compatibility. (define-public guix-devel guix) +(define-public guix-daemon + ;; This package is for internal consumption: it allows us to quickly build + ;; the 'guix-daemon' program and use that in (guix self), used by 'guix + ;; pull'. + (package + (inherit guix) + (properties `((hidden? . #t))) + (name "guix-daemon") + + ;; Use a minimum set of dependencies. + (native-inputs + (fold alist-delete (package-native-inputs guix) + '("po4a" "graphviz" "help2man"))) + (inputs + `(("gnutls" ,gnutls) + ("guile-git" ,guile-git) + ,@(package-inputs guix))) + (propagated-inputs '()) + + (arguments + (substitute-keyword-arguments (package-arguments guix) + ((#:tests? #f #f) + #f) + ((#:phases phases '%standard-phases) + `(modify-phases ,phases + (replace 'build + (lambda _ + (invoke "make" "nix/libstore/schema.sql.hh") + (invoke "make" "-j" (number->string + (parallel-job-count)) + "guix-daemon"))) + (delete 'copy-bootstrap-guile) + (replace 'install + (lambda* (#:key outputs #:allow-other-keys) + (invoke "make" "install-binPROGRAMS" + "install-nodist_pkglibexecSCRIPTS") + + ;; We need to tell 'guix-daemon' which 'guix' command to use. + ;; Here we use a questionable hack where we hard-code + ;; "~root/.config", which could be wrong (XXX). + (let ((out (assoc-ref outputs "out"))) + (substitute* (find-files (string-append out "/libexec")) + (("exec \".*/bin/guix\"") + "exec ~root/.config/current/bin/guix")) + #t))) + (delete 'wrap-program))))))) + (define-public guile2.0-guix (package (inherit guix) diff --git a/guix/self.scm b/guix/self.scm index 3023ae379b..1306df46f5 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -385,7 +385,7 @@ load path." (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) - info + info daemon (command (guix-command modules #:dependencies dependencies #:guile-version guile-version))) @@ -401,6 +401,10 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (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))) @@ -611,6 +615,15 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the #:guile-version guile-version))) (whole-package name built-modules dependencies #: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) -- cgit v1.2.3 From a9a685cc0024a4e0dad5d7abd9ca6fb880ae4f8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Jun 2018 23:08:08 +0200 Subject: offload: Gracefully handle invalid results from 'machines.scm'. * guix/scripts/offload.scm (build-machines): Check the result of FILE. Ignore it if it's not a list of . --- guix/scripts/offload.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index fb61d7c059..664497bcd5 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -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) -- cgit v1.2.3 From 265048cc897af8189c64cdfaa41820490f8fad9e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 Jun 2018 09:02:01 +0200 Subject: offload: Fix error message in 'guix offload test'. Reported by Maxim Cournoyer in . * guix/scripts/offload.scm (assert-node-has-guix): Fix typo in failure message; add missing argument. --- guix/scripts/offload.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 664497bcd5..ee5857e16b 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -613,8 +613,8 @@ If TIMEOUT is #f, simply evaluate EXP..." (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 -- cgit v1.2.3 From 259341cf93de80533d212cb73e5e652aa4bc716c Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Tue, 12 Jun 2018 19:51:23 +0200 Subject: gnu: ldb: Fix build on 32-bit systems. * guix/utils.scm (target-64bit?): New procedure. * gnu/packages/samba.scm (ldb)[inputs]: Only add LMDB on 64-bit systems. [arguments]: Make #:tests? conditional on LMDB availability. --- gnu/packages/samba.scm | 9 +++++++-- guix/utils.scm | 6 ++++++ 2 files changed, 13 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/gnu/packages/samba.scm b/gnu/packages/samba.scm index abbfdd83c4..e10f00a83b 100644 --- a/gnu/packages/samba.scm +++ b/gnu/packages/samba.scm @@ -362,7 +362,10 @@ many event types, including timers, signals, and the classic file descriptor eve #t)))) (build-system gnu-build-system) (arguments - '(#:phases + '(;; LMDB is only supported on 64-bit systems, yet the test suite + ;; requires it. + #:tests? (assoc-ref %build-inputs "lmdb") + #:phases (modify-phases %standard-phases (replace 'configure ;; ldb use a custom configuration script that runs waf. @@ -382,7 +385,9 @@ many event types, including timers, signals, and the classic file descriptor eve `(("talloc" ,talloc) ("tdb" ,tdb))) (inputs - `(("lmdb" ,lmdb) + `(,@(if (target-64bit?) + `(("lmdb" ,lmdb)) + '()) ("popt" ,popt) ("tevent" ,tevent))) (synopsis "LDAP-like embedded database") 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 ;;; Copyright © 2017 Efraim Flashner ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Marius Bakke ;;; ;;; 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)) -- cgit v1.2.3 From a89faa3faac96436cfb2d7052307c58dc2bb4ad6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Jun 2018 01:35:54 +0200 Subject: self: Install .go files to 'lib/guile/X.Y/site-ccache'. * guix/self.scm (guix-command): Add 'compiled-modules' parameter and honor it. (whole-package): Likewise. (compiled-guix)[built-modules]: Turn into a procedure. When PULL-VERSION is 1, use separate source and compiled modules. When PULL-VERSION is 0, return a single directory containing both .scm and .go files. --- guix/self.scm | 48 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 1306df46f5..5a10f72012 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -340,7 +340,8 @@ DOMAIN, a gettext domain." (computed-file "guix-manual" build)) -(define* (guix-command modules #:key source (dependencies '()) +(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." @@ -364,7 +365,8 @@ load path." (set! %load-path (cons #$modules %load-path)) (set! %load-compiled-path - (cons #$modules %load-compiled-path)) + (cons (or #$compiled-modules #$modules) + %load-compiled-path)) (let ((guix-main (module-ref (resolve-interface '(guix ui)) 'guix-main))) @@ -385,14 +387,16 @@ load path." (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." - ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'. +'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 @@ -414,7 +418,15 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the (when info (symlink #$info (string-append #$output - "/share/info")))))))) + "/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) @@ -577,11 +589,9 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the %guix-home-page-url))) #:guile-for-build guile-for-build)) - (define built-modules + (define (built-modules node-subset) (directory-union (string-append name "-modules") - (append-map (lambda (node) - (list (node-source node) - (node-compiled node))) + (append-map node-subset ;; Note: *CONFIG* comes first so that it ;; overrides the (guix config) module that @@ -609,11 +619,14 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the ;; Version 1 is when we return the full package. (cond ((= 1 pull-version) ;; The whole package, with a standard file hierarchy. - (let ((command (guix-command built-modules - #:source source - #:dependencies dependencies - #:guile-version guile-version))) - (whole-package name built-modules dependencies + (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 @@ -627,8 +640,11 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the #:info (info-manual source) #:guile-version guile-version))) ((= 0 pull-version) - ;; Legacy 'guix pull': just return the compiled modules. - built-modules) + ;; 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))) -- cgit v1.2.3 From 32eb44240db23b2320a68a3ab17370531945587f Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 18 Jun 2018 13:50:33 +0200 Subject: build-system/r: Accept #:r argument. * guix/build-system/r.scm (lower): Add #:r to private-keywords. --- guix/build-system/r.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus ;;; ;;; 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 -- cgit v1.2.3 From 870677cbb85d05688ba85deb9807fdef8bd94e19 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jun 2018 15:16:40 +0200 Subject: compile: Work around non-thread-safe module autoloading. * guix/build/compile.scm : Set 'try-module-autoload' when running on Guile < 2.2.4. --- guix/build/compile.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'guix') 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 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) -- cgit v1.2.3 From 45779fa676419de8838cb26b6c7a24678a2be1cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jun 2018 22:43:44 +0200 Subject: self: Make (guix config) generation really stateless. Previously the %CONFIG-VARIABLES list would be generated based on what the current (guix config) contains. Thus, it would include '%guix-register-program', which we recently removed, because existing (guix config) most likely contained that variable. Since its value could differ from machine to machine, the build farm could be building a different config.scm, thereby preventing people from getting substitutes. * guix/self.scm (%config-variables): Turn into a white list instead of taking all the remaining variables from the current (guix config). * build-aux/build-self.scm (%config-variables): Likewise. --- build-aux/build-self.scm | 21 ++++++++++----------- guix/self.scm | 24 +++++++++++------------- 2 files changed, 21 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index 5898b6515c..4de91f7fff 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -63,17 +63,16 @@ %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) - (stringstring (car name+value1)) - (symbol->string (car name+value2)))))) + ;; (guix config) variables corresponding to Guix configuration. + (letrec-syntax ((variables (syntax-rules () + ((_) + '()) + ((_ variable rest ...) + (cons `(variable . ,variable) + (variables rest ...)))))) + (variables %config-directory %localstatedir %state-directory + %store-database-directory %store-directory + %storedir %sysconfdir %system))) (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (package-name "GNU Guix") diff --git a/guix/self.scm b/guix/self.scm index 5a10f72012..cce418df41 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -26,9 +26,8 @@ #: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) @@ -666,17 +665,16 @@ assumed to be part of MODULES." %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) - (stringstring (car name+value1)) - (symbol->string (car name+value2)))))) + ;; (guix config) variables corresponding to Guix configuration. + (letrec-syntax ((variables (syntax-rules () + ((_) + '()) + ((_ variable rest ...) + (cons `(variable . ,variable) + (variables rest ...)))))) + (variables %config-directory %localstatedir %state-directory + %store-database-directory %store-directory + %storedir %sysconfdir %system))) (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (package-name "GNU Guix") -- cgit v1.2.3 From e8cb9c01c684bed2f47767f0b322f3d40d89781a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jun 2018 22:53:25 +0200 Subject: build: Remove checks for 'nix-instantiate'. * guix/import/snix.scm (open-nixpkgs): Use "nix-instantiate" unconditionally. * configure.ac: Remove check for 'nix-instantiate'. * guix/config.scm.in (%nix-instantiate): Remove. * guix/self.scm (%dependency-variables): Remove '%nix-instantiate'. (make-config.scm): Remove it from the generated "config.scm". * build-aux/build-self.scm (%dependency-variables, make-config.scm): Likewise. --- build-aux/build-self.scm | 10 +++------- configure.ac | 9 +-------- guix/config.scm.in | 4 ---- guix/import/snix.scm | 4 ++-- guix/self.scm | 12 ++++-------- 5 files changed, 10 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index 4de91f7fff..6af329b257 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -53,7 +53,7 @@ (define %dependency-variables ;; (guix config) variables corresponding to dependencies. - '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate)) + '(%libgcrypt %libz %xz %gzip %bzip2)) (define %persona-variables ;; (guix config) variables that define Guix's persona. @@ -94,8 +94,7 @@ %libz %gzip %bzip2 - %xz - %nix-instantiate)) + %xz)) ;; XXX: Work around . (eval-when (expand load eval) @@ -121,10 +120,7 @@ (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"))))))) ;;; diff --git a/configure.ac b/configure.ac index b866e91b2c..b34f15a77b 100644 --- a/configure.ac +++ b/configure.ac @@ -160,18 +160,11 @@ AC_ARG_WITH([nix-prefix], esac], []) -AC_PATH_PROG([NIX_INSTANTIATE], [nix-instantiate]) AC_PATH_PROG([NIX_HASH], [nix-hash]) -if test "x$guix_build_daemon$NIX_INSTANTIATE$NIX_HASH" = "xno"; then +if test "x$guix_build_daemon$NIX_HASH" = "xno"; then AC_MSG_ERROR([Nix programs not found; please install Nix or use `--with-nix-prefix'.]) fi -if test "x$NIX_INSTANTIATE" = "x"; then - # This program is an optional dependency, so we just want it to be - # taken from $PATH if it's not available right now. - NIX_INSTANTIATE="nix-instantiate" -fi - AC_ARG_WITH([nixpkgs], [AS_HELP_STRING([--with-nixpkgs=DIR], [search for Nixpkgs in DIR (for testing purposes only)])], diff --git a/guix/config.scm.in b/guix/config.scm.in index 4490112e07..1a761b912e 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -35,7 +35,6 @@ %system %libgcrypt %libz - %nix-instantiate %gzip %bzip2 %xz)) @@ -95,9 +94,6 @@ (define %libz "@LIBZ@") -(define %nix-instantiate - "@NIX_INSTANTIATE@") - (define %gzip "@GZIP@") 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 +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; 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/self.scm b/guix/self.scm index cce418df41..8a474ffb54 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -655,7 +655,7 @@ assumed to be part of MODULES." (define %dependency-variables ;; (guix config) variables corresponding to dependencies. - '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate)) + '(%libgcrypt %libz %xz %gzip %bzip2)) (define %persona-variables ;; (guix config) variables that define Guix's persona. @@ -696,8 +696,7 @@ assumed to be part of MODULES." %libz %gzip %bzip2 - %xz - %nix-instantiate)) + %xz)) #$@(map (match-lambda ((name . value) @@ -721,13 +720,10 @@ assumed to be part of MODULES." (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)) -- cgit v1.2.3 From 7af5c2a248b6c229187fc850517c84b0917c452b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jun 2018 23:56:16 +0200 Subject: self: Define derived '-directory' variables in config.scm. This is a followup to d6b5aa0b031f0e7091f7424ac616d1c4d10fed5b. * guix/self.scm (%config-variables): Remove %CONFIG-DIRECTORY, %STATE-DIRECTORY, %STORE-DATABASE-DIRECTORY, and %STORE-DIRECTORY. (make-config.scm): Define them here. * build-aux/build-self.scm (%config-variables, make-config.scm): Likewise. --- build-aux/build-self.scm | 30 +++++++++++++++++++++++++----- guix/self.scm | 28 +++++++++++++++++++++++++--- 2 files changed, 50 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index 22c4031c2e..bd285bcedd 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -70,11 +70,7 @@ ((_ variable rest ...) (cons `(variable . ,variable) (variables rest ...)))))) - (variables %config-directory %localstatedir %state-directory - ;; Note: No '%store-database-directory', which is too recent - ;; and unnecessary anyway. - %store-directory - %storedir %sysconfdir %system))) + (variables %localstatedir %storedir %sysconfdir %system))) (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (package-name "GNU Guix") @@ -92,6 +88,10 @@ %guix-version %guix-bug-report-address %guix-home-page-url + %store-directory + %state-directory + %store-database-directory + %config-directory %libgcrypt %libz %gzip @@ -105,6 +105,26 @@ #~(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) diff --git a/guix/self.scm b/guix/self.scm index 8a474ffb54..0ad8c34e2a 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -672,9 +672,7 @@ assumed to be part of MODULES." ((_ variable rest ...) (cons `(variable . ,variable) (variables rest ...)))))) - (variables %config-directory %localstatedir %state-directory - %store-database-directory %store-directory - %storedir %sysconfdir %system))) + (variables %localstatedir %storedir %sysconfdir %system))) (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (package-name "GNU Guix") @@ -692,6 +690,10 @@ assumed to be part of MODULES." %guix-version %guix-bug-report-address %guix-home-page-url + %store-directory + %state-directory + %store-database-directory + %config-directory %libgcrypt %libz %gzip @@ -703,6 +705,26 @@ assumed to be part of MODULES." #~(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) -- cgit v1.2.3 From b194da0d6833ee2767b5df34105d12e456c52368 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 19 Jun 2018 10:40:39 +0200 Subject: build-system/waf: Use invoke. * guix/build/waf-build-system.scm (call-waf): Use "invoke" and unconditionally return #t. --- guix/build/waf-build-system.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2015, 2018 Ricardo Wurmus ;;; ;;; 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 -- cgit v1.2.3 From e203f4c26a5b8a26e8e214517fef012fc2cd294e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jun 2018 15:19:52 +0200 Subject: guix system: 'list-generation' correctly displays file system labels. * guix/scripts/system.scm (display-system-generation): Correctly display file system labels. Previously, starting from commit a5acc17a3c10a3779b5b8b1a2565ef130be77e51, it'd print #. --- guix/scripts/system.scm | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 727f1ac55f..a3f01636e6 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -551,10 +551,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)) -- cgit v1.2.3 From 945449b40b4343f1829dfd54aa85f8568711c890 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 21 Jun 2018 16:54:06 +0200 Subject: guix: Fix system reconfigure. This is a follow-up to 378daa8cb677121e1893f9173af1db060720d6e4. * guix/scripts/system.scm (switch-to-system): Lower the script. --- guix/scripts/system.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index a3f01636e6..14aedceac1 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -352,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))) -- cgit v1.2.3 From 5970ceddfaaa449b7224e11d4f6a5f2305408179 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 22 Jun 2018 22:44:12 +0100 Subject: pack: Fix guix pack -f docker. Without this change, running guix pack fails as (guix sets) is missing when compiling (guix build store-copy). * guix/scripts/pack.scm (docker-image): Move (guix build store-copy) to within the source-module-closure call. --- guix/scripts/pack.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index ed876b2592..443d199be5 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -364,9 +364,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)) -- cgit v1.2.3 From 66e9944e078cbb9e0d618377dd6df6e639640efa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 25 Jun 2018 21:49:12 +0200 Subject: pack: Squashfs build expression refers to (guix store database) & co. Fixes a regression introduced in c45477d2a1a651485feede20fe0f3d15aec48b39. Reported by Christopher Baines . * guix/scripts/pack.scm (not-config?, guile-sqlite3&co): New variables. (self-contained-tarball)[not-config?]: Remove. [build]: Use GUILE-SQLITE3&CO for 'with-extensions'. (squashfs-image)[libgcrypt]: New variable. [build]: Use 'source-module-closure', 'make-config.scm', and 'with-extensions'. (docker-image)[not-config?]: Remove. --- guix/scripts/pack.scm | 170 ++++++++++++++++++++++++++------------------------ 1 file changed, 89 insertions(+), 81 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 443d199be5..7f087a3a3c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -88,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? @@ -102,13 +115,6 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define not-config? - (match-lambda - (('guix 'config) #f) - (('guix _ ...) #t) - (('gnu _ ...) #t) - (_ #f))) - (define libgcrypt (module-ref (resolve-interface '(gnu packages gnupg)) 'libgcrypt)) @@ -128,9 +134,7 @@ added to the pack." (guix build store-copy) (gnu build install)) #:select? not-config?)) - (with-extensions (cons guile-sqlite3 - (package-transitive-propagated-inputs - guile-sqlite3)) + (with-extensions guile-sqlite3&co #~(begin (use-modules (guix build utils) ((guix build union) #:select (relative-file-name)) @@ -248,71 +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")) - - ;; 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"))))) + (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" + `(,@(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) @@ -332,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 -- cgit v1.2.3 From 2f608c14893a025b471bcd993096f92331a45a12 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 25 Jun 2018 18:40:10 +0200 Subject: store: Add 'port->connection'. * guix/store.scm (port->connection): New procedure. --- guix/store.scm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 773d53e82b..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 @@ -517,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)) -- cgit v1.2.3 From 26db747a863b08ebcfd630cce635be86c23d829d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 Jun 2018 15:36:03 +0200 Subject: ui: Hint at the installation of locale packages and 'GUIX_LOCPATH'. * guix/ui.scm (install-locale): Hide the "warning: failed to install locale" on Guile 2.2. Add a hint about 'glibc-utf8-locales' and 'GUIX_LOCPATH'. --- guix/ui.scm | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 31830ee850..ec709450d8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -421,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." -- cgit v1.2.3 From 0925c0ea771b949d58be084444fa2c2370f6d74e Mon Sep 17 00:00:00 2001 From: Taylan Kammer Date: Fri, 22 Jun 2018 21:55:26 +0200 Subject: scripts: gc: Report size in MiBs instead of bytes. * guix/scripts/gc.scm (guix-gc): Show info in MiBs not bytes. --- guix/scripts/gc.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') 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) -- cgit v1.2.3 From 108015df6d03e82ac9a6a0a92dcfa389fa702e72 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 Jun 2018 22:33:36 +0200 Subject: self: Add dependency on GnuTLS. Fixes . Reported by Fis Trivial . * guix/self.scm (specification->package): Add "gnutls" and "guile2.0-gnutls". (compiled-guix)[gnutls]: New variable. [dependencies]: Add it. --- guix/self.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 0ad8c34e2a..89c5428039 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -83,6 +83,7 @@ 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)) @@ -92,6 +93,7 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("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 @@ -459,11 +461,16 @@ assumed to be part of MODULES." "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))) -- cgit v1.2.3