From e13240f598d8e89eeb1fbf34fd94f49d6bf0b7a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 16:47:19 +0200 Subject: self: Reduce the set of dependencies. By mistake we were adding more dependencies than needed to the Scheme derivations. * guix/self.scm (compiled-guix)[dependencies]: Use 'package-transitive-propagated-inputs', not 'package-transitive-inputs'. --- guix/self.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 4378a3dee5..9620abf994 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -219,7 +219,7 @@ (define guile-git (define dependencies (match (append-map (lambda (package) (cons (list "x" package) - (package-transitive-inputs package))) + (package-transitive-propagated-inputs package))) (list guile-git guile-json guile-ssh)) (((labels packages _ ...) ...) packages))) -- cgit v1.2.3 From 9768848af80764af6040e75867ae15a41228364b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 17:32:22 +0200 Subject: records: Make a couple of procedures available at expansion time. * guix/records.scm (current-abi-identifier, abi-check): Wrap in 'eval-when'. --- guix/records.scm | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index c71cfcfe32..da3ecdaaf8 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -63,22 +63,25 @@ (define (print-record-abi-mismatch-error port key args (set-exception-printer! 'record-abi-mismatch-error print-record-abi-mismatch-error) -(define (current-abi-identifier type) - "Return an identifier unhygienically derived from TYPE for use as its +(eval-when (expand load eval) + ;; The procedures below are needed both at run time and at expansion time. + + (define (current-abi-identifier type) + "Return an identifier unhygienically derived from TYPE for use as its \"current ABI\" variable." - (let ((type-name (syntax->datum type))) - (datum->syntax - type - (string->symbol - (string-append "% " (symbol->string type-name) - " abi-cookie"))))) - -(define (abi-check type cookie) - "Return syntax that checks that the current \"application binary + (let ((type-name (syntax->datum type))) + (datum->syntax + type + (string->symbol + (string-append "% " (symbol->string type-name) + " abi-cookie"))))) + + (define (abi-check type cookie) + "Return syntax that checks that the current \"application binary interface\" (ABI) for TYPE is equal to COOKIE." - (with-syntax ((current-abi (current-abi-identifier type))) - #`(unless (eq? current-abi #,cookie) - (throw 'record-abi-mismatch-error #,type)))) + (with-syntax ((current-abi (current-abi-identifier type))) + #`(unless (eq? current-abi #,cookie) + (throw 'record-abi-mismatch-error #,type))))) (define-syntax make-syntactic-constructor (syntax-rules () -- cgit v1.2.3 From 8fc3a971b0b0785895d1a23f7ad372026cb63550 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 17 Apr 2018 09:23:00 +0200 Subject: scripts: system: Sort profile generations in reverse order. * guix/scripts/system.scm (profile-boot-parameters): Reverse generation-numbers list. This allows old generations to be listed from most recent to oldest in bootloaders configuration files. --- guix/scripts/system.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5d0df14924..766cab1aad 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -393,9 +393,11 @@ (define (seconds->string seconds) "~Y-~m-~d ~H:~M"))) (define* (profile-boot-parameters #:optional (profile %system-profile) - (numbers (generation-numbers profile))) - "Return a list of 'boot-parameters' for the generations of PROFILE specified by -NUMBERS, which is a list of generation numbers." + (numbers + (reverse (generation-numbers profile)))) + "Return a list of 'boot-parameters' for the generations of PROFILE specified +by NUMBERS, which is a list of generation numbers. The list is ordered from +the most recent to the oldest profiles." (define (system->boot-parameters system number time) (unless-file-not-found (let* ((params (read-boot-parameters-file system)) -- cgit v1.2.3 From 5d669883ecc104403c5d3ba7d172e9c02234577c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 13:45:36 +0200 Subject: gexp: 'compiled-modules' no longer overrides (guix build utils). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Until now 'compiled-modules' would override (guix build utils) with its own. Thus, when asked to build a different (guix build utils), via #:module-path, it would fail badly because a (guix build utils) module was already loaded and possibly incompatible with the new one. This happened when running 'guix pull --branch=core-updates' from current master: in 'core-updates', (guix build utils) exports 'ignore-error?' but in 'master' it does not. Thus, 'guix pull' would fail with: no binding `invoke-error?' in module (guix build utils) builder for `/gnu/store/…-module-import-compiled.drv' failed with exit code 1 cannot build derivation `/gnu/store/…-compute-guix-derivation.drv': 1 dependencies couldn't be built This patch fixes it. * guix/gexp.scm (compiled-modules)[build-utils-hack?]: New variable. [build]: Load MODULES/build/utils.scm when it exists. --- guix/gexp.scm | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index dd5eb81bd3..fdfd734245 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1075,6 +1075,14 @@ (define* (compiled-modules modules "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." + (define build-utils-hack? + ;; To avoid a full rebuild, we limit the fix below to the case where + ;; MODULE-PATH is different from %LOAD-PATH. This happens when building + ;; modules for 'compute-guix-derivation' upon 'guix pull'. TODO: Make + ;; this unconditional on the next rebuild cycle. + (and (member '(guix build utils) modules) + (not (equal? module-path %load-path)))) + (mlet %store-monad ((modules (imported-modules modules #:system system #:guile guile @@ -1114,7 +1122,27 @@ (define (process-directory directory output) %auto-compilation-options)))) entries))) + (ungexp-splicing + (if build-utils-hack? + (gexp ((define mkdir-p + ;; Capture 'mkdir-p'. + (@ (guix build utils) mkdir-p)))) + '())) + (set! %load-path (cons (ungexp modules) %load-path)) + + (ungexp-splicing + (if build-utils-hack? + ;; Above we loaded our own (guix build utils) but now we may + ;; need to load a compile a different one. Thus, force a + ;; reload. + (gexp ((let ((utils (ungexp + (file-append modules + "/guix/build/utils.scm")))) + (when (file-exists? utils) + (load utils))))) + '())) + (mkdir (ungexp output)) (chdir (ungexp modules)) (process-directory "." (ungexp output))))) -- cgit v1.2.3 From 838e17d8050236a6d3ffde991fb0035412eb3046 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 18:14:37 +0200 Subject: gexp: Add 'with-extensions'. * guix/gexp.scm ()[extensions]: New field. (gexp-attribute): New procedure. (gexp-modules): Write in terms of 'gexp-attribute'. (gexp-extensions): New procedure. (gexp->derivation): Add #:effective-version. [extension-flags]: New procedure. Honor extensions of EXP. (current-imported-extensions): New syntax parameter. (with-extensions): New macro. (gexp): Honor CURRENT-IMPORTED-EXTENSIONS. (compiled-modules): Add #:extensions and honor it. (load-path-expression): Likewise. (gexp->script, gexp->file): Honor extensions. * tests/gexp.scm (%extension-package): New variable. ("gexp-extensions & ungexp") ("gexp-extensions & ungexp-splicing") ("gexp-extensions and literal Scheme object") ("gexp->derivation & with-extensions") ("program-file & with-extensions"): New tests. * doc/guix.texi (G-Expressions): Document 'with-extensions'. --- .dir-locals.el | 1 + doc/guix.texi | 33 ++++++++++++ guix/gexp.scm | 168 ++++++++++++++++++++++++++++++++++++++++++--------------- tests/gexp.scm | 86 +++++++++++++++++++++++++++++ 4 files changed, 246 insertions(+), 42 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index dac6cb1453..2db751ca22 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -73,6 +73,7 @@ (eval . (put 'run-with-state 'scheme-indent-function 1)) (eval . (put 'wrap-program 'scheme-indent-function 1)) (eval . (put 'with-imported-modules 'scheme-indent-function 1)) + (eval . (put 'with-extensions 'scheme-indent-function 1)) (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index 3b5078741d..77bdaa50eb 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5064,6 +5064,23 @@ headers, which comes in handy in this case: @dots{}))) @end example +@cindex extensions, for gexps +@findex with-extensions +In the same vein, sometimes you want to import not just pure-Scheme +modules, but also ``extensions'' such as Guile bindings to C libraries +or other ``full-blown'' packages. Say you need the @code{guile-json} +package available on the build side, here's how you would do it: + +@example +(use-modules (gnu packages guile)) ;for 'guile-json' + +(with-extensions (list guile-json) + (gexp->derivation "something-with-json" + #~(begin + (use-modules (json)) + @dots{}))) +@end example + The syntactic form to construct gexps is summarized below. @deffn {Scheme Syntax} #~@var{exp} @@ -5147,6 +5164,18 @@ directly defined in @var{body}@dots{}, but not on those defined, say, in procedures called from @var{body}@dots{}. @end deffn +@deffn {Scheme Syntax} with-extensions @var{extensions} @var{body}@dots{} +Mark the gexps defined in @var{body}@dots{} as requiring +@var{extensions} in their build and execution environment. +@var{extensions} is typically a list of package objects such as those +defined in the @code{(gnu packages guile)} module. + +Concretely, the packages listed in @var{extensions} are added to the +load path while compiling imported modules in @var{body}@dots{}; they +are also added to the load path of the gexp returned by +@var{body}@dots{}. +@end deffn + @deffn {Scheme Procedure} gexp? @var{obj} Return @code{#t} if @var{obj} is a G-expression. @end deffn @@ -5161,6 +5190,7 @@ information about monads.) [#:hash #f] [#:hash-algo #f] @ [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:module-path @var{%load-path}] @ + [#:effective-version "2.2"] @ [#:references-graphs #f] [#:allowed-references #f] @ [#:disallowed-references #f] @ [#:leaked-env-vars #f] @ @@ -5181,6 +5211,9 @@ make @var{modules} available in the evaluation context of @var{exp}; the load path during the execution of @var{exp}---e.g., @code{((guix build utils) (guix build gnu-build-system))}. +@var{effective-version} determines the string to use when adding extensions of +@var{exp} (see @code{with-extensions}) to the search path---e.g., @code{"2.2"}. + @var{graft?} determines whether packages referred to by @var{exp} should be grafted when applicable. diff --git a/guix/gexp.scm b/guix/gexp.scm index fdfd734245..338c339da9 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -33,6 +33,7 @@ (define-module (guix gexp) #:export (gexp gexp? with-imported-modules + with-extensions gexp-input gexp-input? @@ -118,10 +119,11 @@ (define-module (guix gexp) ;; "G expressions". (define-record-type - (make-gexp references modules proc) + (make-gexp references modules extensions proc) gexp? (references gexp-references) ;list of (modules gexp-self-modules) ;list of module names + (extensions gexp-self-extensions) ;list of lowerable things (proc gexp-proc)) ;procedure (define (write-gexp gexp port) @@ -492,19 +494,20 @@ (define (write-gexp-output output port) (set-record-type-printer! write-gexp-output) -(define (gexp-modules gexp) - "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is -false, meaning that GEXP is a plain Scheme object, return the empty list." +(define (gexp-attribute gexp self-attribute) + "Recurse on GEXP and the expressions it refers to, summing the items +returned by SELF-ATTRIBUTE, a procedure that takes a gexp." (if (gexp? gexp) (delete-duplicates - (append (gexp-self-modules gexp) + (append (self-attribute gexp) (append-map (match-lambda (($ (? gexp? exp)) - (gexp-modules exp)) + (gexp-attribute exp self-attribute)) (($ (lst ...)) (append-map (lambda (item) (if (gexp? item) - (gexp-modules item) + (gexp-attribute item + self-attribute) '())) lst)) (_ @@ -512,6 +515,17 @@ (define (gexp-modules gexp) (gexp-references gexp)))) '())) ;plain Scheme data type +(define (gexp-modules gexp) + "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is +false, meaning that GEXP is a plain Scheme object, return the empty list." + (gexp-attribute gexp gexp-self-modules)) + +(define (gexp-extensions gexp) + "Return the list of Guile extensions (packages) GEXP relies on. If (gexp? +GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty +list." + (gexp-attribute gexp gexp-self-extensions)) + (define* (lower-inputs inputs #:key system target) "Turn any package from INPUTS into a derivation for SYSTEM; return the @@ -577,6 +591,7 @@ (define* (gexp->derivation name exp (modules '()) (module-path %load-path) (guile-for-build (%guile-for-build)) + (effective-version "2.2") (graft? (%graft?)) references-graphs allowed-references disallowed-references @@ -595,6 +610,9 @@ (define* (gexp->derivation name exp compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). +EFFECTIVE-VERSION determines the string to use when adding extensions of +EXP (see 'with-extensions') to the search path---e.g., \"2.2\". + GRAFT? determines whether packages referred to by EXP should be grafted when applicable. @@ -630,7 +648,7 @@ (define outputs (gexp-outputs exp)) (define (graphs-file-names graphs) ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. (map (match-lambda - ;; TODO: Remove 'derivation?' special cases. + ;; TODO: Remove 'derivation?' special cases. ((file-name (? derivation? drv)) (cons file-name (derivation->output-path drv))) ((file-name (? derivation? drv) sub-drv) @@ -639,7 +657,13 @@ (define (graphs-file-names graphs) (cons file-name thing))) graphs)) - (mlet* %store-monad (;; The following binding forces '%current-system' and + (define (extension-flags extension) + `("-L" ,(string-append (derivation->output-path extension) + "/share/guile/site/" effective-version) + "-C" ,(string-append (derivation->output-path extension) + "/lib/guile/" effective-version "/site-ccache"))) + + (mlet* %store-monad ( ;; The following binding forces '%current-system' and ;; '%current-target-system' to be looked up at >>= ;; time. (graft? (set-grafting graft?)) @@ -660,6 +684,11 @@ (define (graphs-file-names graphs) #:target target)) (builder (text-file script-name (object->string sexp))) + (extensions -> (gexp-extensions exp)) + (exts (mapm %store-monad + (lambda (obj) + (lower-object obj system)) + extensions)) (modules (if (pair? %modules) (imported-modules %modules #:system system @@ -672,6 +701,7 @@ (define (graphs-file-names graphs) (compiled-modules %modules #:system system #:module-path module-path + #:extensions extensions #:guile guile-for-build #:deprecation-warnings deprecation-warnings) @@ -704,6 +734,7 @@ (define (graphs-file-names graphs) `("-L" ,(derivation->output-path modules) "-C" ,(derivation->output-path compiled)) '()) + ,@(append-map extension-flags exts) ,builder) #:outputs outputs #:env-vars env-vars @@ -713,6 +744,7 @@ (define (graphs-file-names graphs) ,@(if modules `((,modules) (,compiled) ,@inputs) inputs) + ,@(map list exts) ,@(match graphs (((_ . inputs) ...) inputs) (_ '()))) @@ -861,6 +893,17 @@ (define-syntax-rule (with-imported-modules modules body ...) (identifier-syntax modules))) body ...)) +(define-syntax-parameter current-imported-extensions + ;; Current list of extensions. + (identifier-syntax '())) + +(define-syntax-rule (with-extensions extensions body ...) + "Mark the gexps defined in BODY... as requiring EXTENSIONS in their +execution environment." + (syntax-parameterize ((current-imported-extensions + (identifier-syntax extensions))) + body ...)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -957,6 +1000,7 @@ (define (substitute-references exp substs) (refs (map escape->ref escapes))) #`(make-gexp (list #,@refs) current-imported-modules + current-imported-extensions (lambda #,formals #,sexp))))))) @@ -1071,6 +1115,7 @@ (define* (compiled-modules modules (system (%current-system)) (guile (%guile-for-build)) (module-path %load-path) + (extensions '()) (deprecation-warnings #f)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where @@ -1129,6 +1174,26 @@ (define (process-directory directory output) (@ (guix build utils) mkdir-p)))) '())) + ;; Add EXTENSIONS to the search path. + ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle. + (ungexp-splicing + (if (null? extensions) + '() + (gexp ((set! %load-path + (append (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + '((ungexp-native-splicing extensions))) + %load-path)) + (set! %load-compiled-path + (append (map (lambda (extension) + (string-append extension "/lib/guile/" + (effective-version) + "/site-ccache")) + '((ungexp-native-splicing extensions))) + %load-compiled-path)))))) + (set! %load-path (cons (ungexp modules) %load-path)) (ungexp-splicing @@ -1174,20 +1239,34 @@ (define (default-guile) (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.2)) -(define* (load-path-expression modules #:optional (path %load-path)) +(define* (load-path-expression modules #:optional (path %load-path) + #:key (extensions '())) "Return as a monadic value a gexp that sets '%load-path' and '%load-compiled-path' to point to MODULES, a list of module names. MODULES are searched for in PATH." (mlet %store-monad ((modules (imported-modules modules #:module-path path)) (compiled (compiled-modules modules + #:extensions extensions #:module-path path))) (return (gexp (eval-when (expand load eval) (set! %load-path - (cons (ungexp modules) %load-path)) + (cons (ungexp modules) + (append (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + '((ungexp-native-splicing extensions))) + %load-path))) (set! %load-compiled-path (cons (ungexp compiled) - %load-compiled-path))))))) + (append (map (lambda (extension) + (string-append extension + "/lib/guile/" + (effective-version) + "/site-ccache")) + '((ungexp-native-splicing extensions))) + %load-compiled-path)))))))) (define* (gexp->script name exp #:key (guile (default-guile)) @@ -1196,7 +1275,9 @@ (define* (gexp->script name exp imported modules in its search path. Look up EXP's modules in MODULE-PATH." (mlet %store-monad ((set-load-path (load-path-expression (gexp-modules exp) - module-path))) + module-path + #:extensions + (gexp-extensions exp)))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1225,35 +1306,38 @@ (define* (gexp->file name exp #:key When SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path' and '%load-compiled-path' to honor EXP's imported modules. Lookup EXP's modules in MODULE-PATH." - (match (if set-load-path? (gexp-modules exp) '()) - (() ;zero modules - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (for-each (lambda (exp) - (write exp port)) - '(ungexp (if splice? - exp - (gexp ((ungexp exp))))))))) - #:local-build? #t - #:substitutable? #f)) - ((modules ...) - (mlet %store-monad ((set-load-path (load-path-expression modules - module-path))) - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (write '(ungexp set-load-path) port) - (for-each (lambda (exp) - (write exp port)) - '(ungexp (if splice? - exp - (gexp ((ungexp exp))))))))) - #:module-path module-path - #:local-build? #t - #:substitutable? #f))))) + (define modules (gexp-modules exp)) + (define extensions (gexp-extensions exp)) + + (if (or (not set-load-path?) + (and (null? modules) (null? extensions))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (for-each (lambda (exp) + (write exp port)) + '(ungexp (if splice? + exp + (gexp ((ungexp exp))))))))) + #:local-build? #t + #:substitutable? #f) + (mlet %store-monad ((set-load-path + (load-path-expression modules module-path + #:extensions extensions))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp set-load-path) port) + (for-each (lambda (exp) + (write exp port)) + '(ungexp (if splice? + exp + (gexp ((ungexp exp))))))))) + #:module-path module-path + #:local-build? #t + #:substitutable? #f)))) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing diff --git a/tests/gexp.scm b/tests/gexp.scm index 3c8b4624da..a560adfc5c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -23,6 +23,7 @@ (define-module (test-gexp) #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix build-system trivial) #:use-module (guix tests) #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module ((guix utils) #:select (call-with-temporary-directory)) @@ -66,6 +67,27 @@ (define-syntax-rule (test-assertm name exp) (run-with-store %store exp #:guile-for-build (%guile-for-build)))) +(define %extension-package + ;; Example of a package to use when testing 'with-extensions'. + (dummy-package "extension" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils)) + (let* ((out (string-append (assoc-ref %outputs "out") + "/share/guile/site/" + (effective-version)))) + (mkdir-p out) + (call-with-output-file (string-append out "/hg2g.scm") + (lambda (port) + (write '(define-module (hg2g) + #:export (the-answer)) + port) + (write '(define the-answer 42) port))))))))) + (test-begin "gexp") @@ -739,6 +761,54 @@ (define the-answer 42)) (built-derivations (list drv)) (return (= 42 (call-with-input-file out read)))))) +(test-equal "gexp-extensions & ungexp" + (list sed grep) + ((@@ (guix gexp) gexp-extensions) + #~(foo #$(with-extensions (list grep) #~+) + #+(with-extensions (list sed) #~-)))) + +(test-equal "gexp-extensions & ungexp-splicing" + (list grep sed) + ((@@ (guix gexp) gexp-extensions) + #~(foo #$@(list (with-extensions (list grep) #~+) + (with-imported-modules '((foo)) + (with-extensions (list sed) #~-)))))) + +(test-equal "gexp-extensions and literal Scheme object" + '() + ((@@ (guix gexp) gexp-extensions) #t)) + +(test-assertm "gexp->derivation & with-extensions" + ;; Create a fake Guile extension and make sure it is accessible both to the + ;; imported modules and to the derivation build script. + (mlet* %store-monad + ((extension -> %extension-package) + (module -> (scheme-file "x" #~( ;; splice! + (define-module (foo) + #:use-module (hg2g) + #:export (multiply)) + + (define (multiply x) + (* the-answer x))) + #:splice? #t)) + (build -> (with-extensions (list extension) + (with-imported-modules `((guix build utils) + ((foo) => ,module)) + #~(begin + (use-modules (guix build utils) + (hg2g) (foo)) + (call-with-output-file #$output + (lambda (port) + (write (list the-answer (multiply 2)) + port))))))) + (drv (gexp->derivation "thingie" build + ;; %BOOTSTRAP-GUILE is 2.0. + #:effective-version "2.0")) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (equal? '(42 84) (call-with-input-file out read)))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) @@ -948,6 +1018,22 @@ (define-public %stupid-thing ,text)) (return (and (zero? (close-pipe pipe)) (string=? text str)))))))))) +(test-assertm "program-file & with-extensions" + (let* ((exp (with-extensions (list %extension-package) + (gexp (begin + (use-modules (hg2g)) + (display the-answer))))) + (file (program-file "program" exp + #:guile %bootstrap-guile))) + (mlet* %store-monad ((drv (lower-object file)) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (= 42 (string->number str))))))))) + (test-assertm "scheme-file" (let* ((text (plain-file "foo" "Hello, world!")) (scheme (scheme-file "bar" #~(list "foo" #$text)))) -- cgit v1.2.3 From 13993c77fec7580f4f10ea07256db9e5f5a7949b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 18:22:24 +0200 Subject: pack: Use 'with-extensions' when referring to (guix docker). * guix/docker.scm: Use module (json) the normal way. * guix/scripts/pack.scm (docker-image)[build]: Wrap in 'with-extensions'. --- guix/docker.scm | 6 ++---- guix/scripts/pack.scm | 41 +++++++++++++++++++---------------------- 2 files changed, 21 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index a75534c33b..b869901599 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; Copyright © 2018 Chris Marusich ;;; ;;; This file is part of GNU Guix. @@ -26,6 +26,7 @@ (define-module (guix docker) delete-file-recursively with-directory-excursion invoke)) + #:use-module (json) ;guile-json #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module ((texinfo string-utils) @@ -34,9 +35,6 @@ (define-module (guix docker) #:use-module (ice-9 match) #:export (build-docker-image)) -;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co. -(module-use! (current-module) (resolve-interface '(json))) - ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image. (define docker-id (compose bytevector->base16-string sha256 string->utf8)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 35b8a7e729..76729d8e10 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -340,28 +340,25 @@ (define json guile-json)) (define build - (with-imported-modules `(,@(source-module-closure '((guix docker)) - #:select? not-config?) - (guix build store-copy) - ((guix config) => ,config)) - #~(begin - ;; Guile-JSON is required by (guix docker). - (add-to-load-path - (string-append #+json "/share/guile/site/" - (effective-version))) - - (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) - - (setenv "PATH" (string-append #$archiver "/bin")) - - (build-docker-image #$output - (call-with-input-file "profile" - read-reference-graph) - #$profile - #:system (or #$target (utsname:machine (uname))) - #:symlinks '#$symlinks - #:compressor '#$(compressor-command compressor) - #:creation-time (make-time time-utc 0 1))))) + ;; Guile-JSON is required by (guix docker). + (with-extensions (list json) + (with-imported-modules `(,@(source-module-closure '((guix docker)) + #:select? not-config?) + (guix build store-copy) + ((guix config) => ,config)) + #~(begin + (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) + + (setenv "PATH" (string-append #$archiver "/bin")) + + (build-docker-image #$output + (call-with-input-file "profile" + read-reference-graph) + #$profile + #:system (or #$target (utsname:machine (uname))) + #:symlinks '#$symlinks + #:compressor '#$(compressor-command compressor) + #:creation-time (make-time time-utc 0 1)))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) -- cgit v1.2.3 From 331ac4cc239727992329207ba428b3f26cae91d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 22:00:11 +0200 Subject: profiles: Use 'with-extensions'. * guix/profiles.scm (manual-database)[build]: Use 'with-extensions'. Remove 'add-to-load-path' call. * guix/man-db.scm: Use (gdbm) the normal way; remove 'module-autoload!' call. --- guix/man-db.scm | 6 ++--- guix/profiles.scm | 68 +++++++++++++++++++++++++++---------------------------- 2 files changed, 35 insertions(+), 39 deletions(-) (limited to 'guix') diff --git a/guix/man-db.scm b/guix/man-db.scm index 732aef1083..4cef874f8b 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,7 @@ (define-module (guix man-db) #:use-module (guix zlib) #:use-module ((guix build utils) #:select (find-files)) + #:use-module (gdbm) ;gdbm-ffi #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (ice-9 match) @@ -44,9 +45,6 @@ (define-module (guix man-db) ;;; ;;; Code: -;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co. -(module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT)) - (define-record-type (mandb-entry file-name name section synopsis kind) mandb-entry? diff --git a/guix/profiles.scm b/guix/profiles.scm index fd7e5b922c..9bddf88162 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1196,41 +1196,39 @@ (define modules (define build (with-imported-modules modules - #~(begin - (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/" - (effective-version))) - - (use-modules (guix man-db) - (guix build utils) - (srfi srfi-1) - (srfi srfi-19)) - - (define (compute-entries) - (append-map (lambda (directory) - (let ((man (string-append directory "/share/man"))) - (if (directory-exists? man) - (mandb-entries man) - '()))) - '#$(manifest-inputs manifest))) - - (define man-directory - (string-append #$output "/share/man")) - - (mkdir-p man-directory) - - (format #t "Creating manual page database...~%") - (force-output) - (let* ((start (current-time)) - (entries (compute-entries)) - (_ (write-mandb-database (string-append man-directory - "/index.db") - entries)) - (duration (time-difference (current-time) start))) - (format #t "~a entries processed in ~,1f s~%" - (length entries) - (+ (time-second duration) - (* (time-nanosecond duration) (expt 10 -9)))) - (force-output))))) + (with-extensions (list gdbm-ffi) ;for (guix man-db) + #~(begin + (use-modules (guix man-db) + (guix build utils) + (srfi srfi-1) + (srfi srfi-19)) + + (define (compute-entries) + (append-map (lambda (directory) + (let ((man (string-append directory "/share/man"))) + (if (directory-exists? man) + (mandb-entries man) + '()))) + '#$(manifest-inputs manifest))) + + (define man-directory + (string-append #$output "/share/man")) + + (mkdir-p man-directory) + + (format #t "Creating manual page database...~%") + (force-output) + (let* ((start (current-time)) + (entries (compute-entries)) + (_ (write-mandb-database (string-append man-directory + "/index.db") + entries)) + (duration (time-difference (current-time) start))) + (format #t "~a entries processed in ~,1f s~%" + (length entries) + (+ (time-second duration) + (* (time-nanosecond duration) (expt 10 -9)))) + (force-output)))))) (gexp->derivation "manual-database" build -- cgit v1.2.3 From d59e75f3b5b82692bd250a1a3a9965397bb588c5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 May 2018 15:43:52 +0200 Subject: build: Check for Guile-SQLite3. * m4/guix.m4 (GUIX_CHECK_GUILE_SQLITE3): New macro. * configure.ac: Use it and define 'HAVE_GUILE_SQLITE3'. * guix/self.scm (specification->package): Add "guile-sqlite3". (compiled-guix)[guile-sqlite3]: New variable. [dependencies]: Add it. --- configure.ac | 5 +++++ guix/self.scm | 9 ++++++++- m4/guix.m4 | 18 ++++++++++++++++++ 3 files changed, 31 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/configure.ac b/configure.ac index 557da63189..d338bfda53 100644 --- a/configure.ac +++ b/configure.ac @@ -124,6 +124,11 @@ dnl Guile-JSON is used in various places. GUILE_MODULE_AVAILABLE([have_guile_json], [(json)]) AM_CONDITIONAL([HAVE_GUILE_JSON], [test "x$have_guile_json" = "xyes"]) +dnl Guile-Sqlite3 is used by the (guix store ...) modules. +GUIX_CHECK_GUILE_SQLITE3 +AM_CONDITIONAL([HAVE_GUILE_SQLITE3], + [test "x$guix_cv_have_recent_guile_sqlite3" = "xyes"]) + dnl Make sure we have a full-fledged Guile. GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) diff --git a/guix/self.scm b/guix/self.scm index 9620abf994..64cf3033b7 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -82,6 +82,7 @@ (define specification->package ("guile-json" (ref '(gnu packages guile) 'guile-json)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) + ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) ("zlib" (ref '(gnu packages compression) 'zlib)) ("gzip" (ref '(gnu packages compression) 'gzip)) @@ -92,6 +93,7 @@ (define specification->package ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) + ;; XXX: No "guile2.0-sqlite3". (_ #f)))) ;no such package @@ -216,11 +218,16 @@ (define guile-git "guile2.0-git")) + (define guile-sqlite3 + (package-for-guile guile-version + "guile-sqlite3" + "guile2.0-sqlite3")) + (define dependencies (match (append-map (lambda (package) (cons (list "x" package) (package-transitive-propagated-inputs package))) - (list guile-git guile-json guile-ssh)) + (list guile-git guile-json guile-ssh guile-sqlite3)) (((labels packages _ ...) ...) packages))) diff --git a/m4/guix.m4 b/m4/guix.m4 index 8e174e92e5..a6897be961 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -174,6 +174,24 @@ AC_DEFUN([GUIX_CHECK_GUILE_SSH], [ fi]) ]) +dnl GUIX_CHECK_GUILE_SQLITE3 +dnl +dnl Check whether a recent-enough Guile-Sqlite3 is available. +AC_DEFUN([GUIX_CHECK_GUILE_SQLITE3], [ + dnl Check whether 'sqlite-bind-arguments' is available. It was introduced + dnl in February 2018: + dnl . + AC_CACHE_CHECK([whether Guile-Sqlite3 is available and recent enough], + [guix_cv_have_recent_guile_sqlite3], + [GUILE_CHECK([retval], + [(@ (sqlite3) sqlite-bind-arguments)]) + if test "$retval" = 0; then + guix_cv_have_recent_guile_sqlite3="yes" + else + guix_cv_have_recent_guile_sqlite3="no" + fi]) +]) + dnl GUIX_TEST_ROOT_DIRECTORY AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [ AC_CACHE_CHECK([for unit test root directory], -- cgit v1.2.3 From 7f9d184d9b688d13ce76eefabaddcfa76bdde2b5 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sun, 27 May 2018 19:19:30 +0200 Subject: Add (gnu store database). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/config.scm.in (%store-database-directory): New variable. * guix/store/database.scm: New file. * tests/store-database.scm: New file. * Makefile.am (STORE_MODULES): New variable. (MODULES, MODULES_NOT_COMPILED): Adjust accordingly. (SCM_TESTS) [HAVE_GUILE_SQLITE3]: Add tests/store-database.scm. Co-authored-by: Ludovic Courtès --- .dir-locals.el | 2 + Makefile.am | 17 ++++ guix/config.scm.in | 6 ++ guix/store/database.scm | 234 +++++++++++++++++++++++++++++++++++++++++++++++ tests/store-database.scm | 54 +++++++++++ 5 files changed, 313 insertions(+) create mode 100644 guix/store/database.scm create mode 100644 tests/store-database.scm (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 2db751ca22..eb99a5bcc1 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -75,6 +75,8 @@ (eval . (put 'with-imported-modules 'scheme-indent-function 1)) (eval . (put 'with-extensions 'scheme-indent-function 1)) + (eval . (put 'with-database 'scheme-indent-function 2)) + (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) (eval . (put 'eventually 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index 2a0a858429..d81fce5585 100644 --- a/Makefile.am +++ b/Makefile.am @@ -257,6 +257,16 @@ MODULES += \ endif BUILD_DAEMON_OFFLOAD +# Scheme implementation of the build daemon and related functionality. +STORE_MODULES = \ + guix/store/database.scm + +if HAVE_GUILE_SQLITE3 +MODULES += $(STORE_MODULES) +else +MODULES_NOT_COMPILED += $(STORE_MODULES) +endif !HAVE_GUILE_SQLITE3 + # Internal modules with test suite support. dist_noinst_DATA = guix/tests.scm guix/tests/http.scm @@ -379,6 +389,13 @@ SCM_TESTS += \ endif +if HAVE_GUILE_SQLITE3 + +SCM_TESTS += \ + tests/store-database.scm + +endif + SH_TESTS = \ tests/guix-build.sh \ tests/guix-download.sh \ diff --git a/guix/config.scm.in b/guix/config.scm.in index 8f2c4abd8e..dfe5fe0dbf 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2017 Caleb Ristvedt ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ (define-module (guix config) %store-directory %state-directory + %store-database-directory %config-directory %guix-register-program @@ -80,6 +82,10 @@ (define %state-directory (or (getenv "NIX_STATE_DIR") (string-append %localstatedir "/guix"))) +(define %store-database-directory + (or (and=> (getenv "NIX_DB_DIR") canonicalize-path) + (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") diff --git a/guix/store/database.scm b/guix/store/database.scm new file mode 100644 index 0000000000..4233219ba0 --- /dev/null +++ b/guix/store/database.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Caleb Ristvedt +;;; Copyright © 2018 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 . + +(define-module (guix store database) + #:use-module (sqlite3) + #:use-module (guix config) + #:use-module (guix serialization) + #:use-module (guix base16) + #:use-module (guix hash) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (ice-9 match) + #:export (sqlite-register + register-path)) + +;;; Code for working with the store database directly. + + +(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))) + (dynamic-wind noop + (lambda () + exp ...) + (lambda () + (sqlite-close db))))) + +(define (last-insert-row-id db) + ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. + ;; Work around that. + (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" + #:cache? #t)) + (result (sqlite-fold cons '() stmt))) + (sqlite-finalize stmt) + (match result + ((#(id)) id) + (_ #f)))) + +(define path-id-sql + "SELECT id FROM ValidPaths WHERE path = :path") + +(define* (path-id db path) + "If PATH exists in the 'ValidPaths' table, return its numerical +identifier. Otherwise, return #f." + (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t))) + (sqlite-bind-arguments stmt #:path path) + (let ((result (sqlite-fold cons '() stmt))) + (sqlite-finalize stmt) + (match result + ((#(id) . _) id) + (_ #f))))) + +(define update-sql + "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver = +:deriver, narSize = :size WHERE id = :id") + +(define insert-sql + "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) +VALUES (:path, :hash, :time, :deriver, :size)") + +(define* (update-or-insert db #:key path deriver hash nar-size time) + "The classic update-if-exists and insert-if-doesn't feature that sqlite +doesn't exactly have... they've got something close, but it involves deleting +and re-inserting instead of updating, which causes problems with foreign keys, +of course. Returns the row id of the row that was modified or inserted." + (let ((id (path-id db path))) + (if id + (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) + (sqlite-bind-arguments stmt #:id id + #:path path #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt) + (sqlite-finalize stmt) + (last-insert-row-id db)) + (let ((stmt (sqlite-prepare db insert-sql #:cache? #t))) + (sqlite-bind-arguments stmt + #:path path #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt) ;execute it + (sqlite-finalize stmt) + (last-insert-row-id db))))) + +(define add-reference-sql + "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id +FROM ValidPaths WHERE path = :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." + (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) + (for-each (lambda (reference) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt #:referrer referrer + #:reference reference) + (sqlite-fold cons '() stmt) ;execute it + (sqlite-finalize stmt) + (last-insert-row-id db)) + references))) + +;; XXX figure out caching of statement and database objects... later +(define* (sqlite-register #:key db-file path (references '()) + deriver hash nar-size) + "Registers this stuff in a database specified by DB-FILE. PATH is the string +path of some store item, REFERENCES is a list of string paths which the store +item PATH refers to (they need to be already registered!), DERIVER is a string +path of the derivation that created the store item PATH, HASH is the +base16-encoded sha256 hash of the store item denoted by PATH (prefixed with +\"sha256:\") after being converted to nar form, and nar-size is the size in +bytes of the store item denoted by PATH after being converted to nar form." + (with-database db-file db + (let ((id (update-or-insert db #:path path + #:deriver deriver + #:hash hash + #:nar-size nar-size + #:time (time-second (current-time time-utc))))) + (add-references db id references)))) + + +;;; +;;; High-level interface. +;;; + +;; XXX: Would it be better to just make WRITE-FILE give size as well? I question +;; the general utility of this approach. +(define (counting-wrapper-port output-port) + "Some custom ports don't implement GET-POSITION at all. But if we want to +figure out how many bytes are being written, we will want to use that. So this +makes a wrapper around a port which implements GET-POSITION." + (let ((byte-count 0)) + (make-custom-binary-output-port "counting-wrapper" + (lambda (bytes offset count) + (set! byte-count + (+ byte-count count)) + (put-bytevector output-port bytes + offset count) + count) + (lambda () + byte-count) + #f + (lambda () + (close-port output-port))))) + + +(define (nar-sha256 file) + "Gives the sha256 hash of a file and the size of the file in nar form." + (let-values (((port get-hash) (open-sha256-port))) + (let ((wrapper (counting-wrapper-port port))) + (write-file file wrapper) + (force-output wrapper) + (force-output port) + (let ((hash (get-hash)) + (size (port-position wrapper))) + (close-port wrapper) + (values hash size))))) + +;; 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) + ;; 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 +initialize; if STATE-DIRECTORY is given, 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." + (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))) + (sqlite-register + #:db-file (string-append db-dir "/db.sqlite") + #:path to-register + #:references references + #:deriver deriver + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size)))) diff --git a/tests/store-database.scm b/tests/store-database.scm new file mode 100644 index 0000000000..1348a75c26 --- /dev/null +++ b/tests/store-database.scm @@ -0,0 +1,54 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017, 2018 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 . + +(define-module (test-store-database) + #:use-module (guix tests) + #:use-module ((guix store) #:hide (register-path)) + #:use-module (guix store database) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64)) + +;; Test the (guix store database) module. + +(define %store + (open-connection-for-tests)) + + +(test-begin "store-database") + +(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-end "store-database") -- cgit v1.2.3 From 285cc75c3160421005ba0181490de4b290755b63 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 May 2018 21:32:17 +0200 Subject: database: 'register-path' resets timestamps. * guix/store/database.scm (reset-timestamps): New procedure. (register-path): Use it. --- guix/store/database.scm | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 4233219ba0..b9745dbe14 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -23,12 +23,14 @@ (define-module (guix store database) #:use-module (guix serialization) #:use-module (guix base16) #:use-module (guix hash) + #:use-module (guix build syscalls) #:use-module (rnrs io ports) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (ice-9 match) #:export (sqlite-register - register-path)) + register-path + reset-timestamps)) ;;; Code for working with the store database directly. @@ -171,6 +173,34 @@ (define (nar-sha256 file) (close-port wrapper) (values hash size))))) +;; 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." + (let loop ((file file) + (type (stat:type (lstat file)))) + (case type + ((directory) + (utime file 0 0 0 0) + (let ((parent file)) + (for-each (match-lambda + (("." . _) #f) + ((".." . _) #f) + ((file . properties) + (let ((file (string-append parent "/" file))) + (loop file + (match (assoc-ref properties 'type) + ((or 'unknown #f) + (stat:type (lstat file))) + (type type)))))) + (scandir* parent)))) + ((symlink) + ;; FIXME: Implement bindings for 'futime' to reset the timestamps on + ;; symlinks. + #f) + (else + (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 @@ -224,6 +254,7 @@ (define* (register-path path (real-path (string-append store-dir "/" (basename path)))) (let-values (((hash nar-size) (nar-sha256 real-path))) + (reset-timestamps real-path) (sqlite-register #:db-file (string-append db-dir "/db.sqlite") #:path to-register -- cgit v1.2.3 From bf5bf5778cb7c3a2475c6acd707abc925b1819aa Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sun, 27 May 2018 23:20:54 +0200 Subject: Add (guix store deduplication). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/store/database.scm (register-path): Add #:deduplicate? and call 'deduplicate' when it's true. (counting-wrapper-port, nar-sha256): Move to... * guix/store/deduplication.scm: ... here. New file. * tests/store-deduplication.scm: New file. * Makefile.am (STORE_MODULES): Add deduplication.scm. (SCM_TESTS) [HAVE_GUILE_SQLITE3]: Add store-deduplication.scm. Co-authored-by: Ludovic Courtès --- Makefile.am | 6 +- guix/store/database.scm | 43 ++---------- guix/store/deduplication.scm | 148 ++++++++++++++++++++++++++++++++++++++++++ tests/store-deduplication.scm | 64 ++++++++++++++++++ 4 files changed, 222 insertions(+), 39 deletions(-) create mode 100644 guix/store/deduplication.scm create mode 100644 tests/store-deduplication.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index d81fce5585..474575c9f2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -259,7 +259,8 @@ endif BUILD_DAEMON_OFFLOAD # Scheme implementation of the build daemon and related functionality. STORE_MODULES = \ - guix/store/database.scm + guix/store/database.scm \ + guix/store/deduplication.scm if HAVE_GUILE_SQLITE3 MODULES += $(STORE_MODULES) @@ -392,7 +393,8 @@ endif if HAVE_GUILE_SQLITE3 SCM_TESTS += \ - tests/store-database.scm + tests/store-database.scm \ + tests/store-deduplication.scm endif diff --git a/guix/store/database.scm b/guix/store/database.scm index b9745dbe14..3623c0e7a0 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -21,10 +21,9 @@ (define-module (guix store database) #:use-module (sqlite3) #:use-module (guix config) #:use-module (guix serialization) + #:use-module (guix store deduplication) #:use-module (guix base16) - #:use-module (guix hash) #:use-module (guix build syscalls) - #:use-module (rnrs io ports) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (ice-9 match) @@ -140,39 +139,6 @@ (define* (sqlite-register #:key db-file path (references '()) ;;; High-level interface. ;;; -;; XXX: Would it be better to just make WRITE-FILE give size as well? I question -;; the general utility of this approach. -(define (counting-wrapper-port output-port) - "Some custom ports don't implement GET-POSITION at all. But if we want to -figure out how many bytes are being written, we will want to use that. So this -makes a wrapper around a port which implements GET-POSITION." - (let ((byte-count 0)) - (make-custom-binary-output-port "counting-wrapper" - (lambda (bytes offset count) - (set! byte-count - (+ byte-count count)) - (put-bytevector output-port bytes - offset count) - count) - (lambda () - byte-count) - #f - (lambda () - (close-port output-port))))) - - -(define (nar-sha256 file) - "Gives the sha256 hash of a file and the size of the file in nar form." - (let-values (((port get-hash) (open-sha256-port))) - (let ((wrapper (counting-wrapper-port port))) - (write-file file wrapper) - (force-output wrapper) - (force-output port) - (let ((hash (get-hash)) - (size (port-position wrapper))) - (close-port wrapper) - (values hash size))))) - ;; 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 @@ -211,7 +177,7 @@ (define (reset-timestamps file) (define* (register-path path #:key (references '()) deriver prefix - state-directory) + state-directory (deduplicate? #t)) ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and ;; %store-database-directory already handle the "environment variables / @@ -262,4 +228,7 @@ (define* (register-path path #:deriver deriver #:hash (string-append "sha256:" (bytevector->base16-string hash)) - #:nar-size nar-size)))) + #:nar-size nar-size) + + (when deduplicate? + (deduplicate real-path hash #:store store-dir))))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm new file mode 100644 index 0000000000..4b4ac01f64 --- /dev/null +++ b/guix/store/deduplication.scm @@ -0,0 +1,148 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Caleb Ristvedt +;;; Copyright © 2018 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 . + +;;; This houses stuff we do to files when they arrive at the store - resetting +;;; timestamps, deduplicating, etc. + +(define-module (guix store deduplication) + #:use-module (guix hash) + #:use-module (guix build utils) + #:use-module (guix base16) + #:use-module (srfi srfi-11) + #:use-module (rnrs io ports) + #:use-module (ice-9 ftw) + #:use-module (guix serialization) + #:export (nar-sha256 + deduplicate)) + +;; Would it be better to just make WRITE-FILE give size as well? I question +;; the general utility of this approach. +(define (counting-wrapper-port output-port) + "Some custom ports don't implement GET-POSITION at all. But if we want to +figure out how many bytes are being written, we will want to use that. So this +makes a wrapper around a port which implements GET-POSITION." + (let ((byte-count 0)) + (make-custom-binary-output-port "counting-wrapper" + (lambda (bytes offset count) + (set! byte-count + (+ byte-count count)) + (put-bytevector output-port bytes + offset count) + count) + (lambda () + byte-count) + #f + (lambda () + (close-port output-port))))) + +(define (nar-sha256 file) + "Gives the sha256 hash of a file and the size of the file in nar form." + (let-values (((port get-hash) (open-sha256-port))) + (let ((wrapper (counting-wrapper-port port))) + (write-file file wrapper) + (force-output wrapper) + (force-output port) + (let ((hash (get-hash)) + (size (port-position wrapper))) + (close-port wrapper) + (values hash size))))) + +(define (tempname-in directory) + "Gives an unused temporary name under DIRECTORY. Not guaranteed to still be +unused by the time you create anything with that name, but a good shot." + (let ((const-part (string-append directory "/.tmp-link-" + (number->string (getpid))))) + (let try ((guess-part + (number->string (random most-positive-fixnum) 16))) + (if (file-exists? (string-append const-part "-" guess-part)) + (try (number->string (random most-positive-fixnum) 16)) + (string-append const-part "-" guess-part))))) + +(define* (get-temp-link target #:optional (link-prefix (dirname target))) + "Like mkstemp!, but instead of creating a new file and giving you the name, +it creates a new hardlink to TARGET and gives you the name. Since +cross-filesystem hardlinks don't work, the temp link must be created on the +same filesystem - where in that filesystem it is can be controlled by +LINK-PREFIX." + (let try ((tempname (tempname-in link-prefix))) + (catch 'system-error + (lambda () + (link target tempname) + tempname) + (lambda (args) + (if (= (system-error-errno args) EEXIST) + (try (tempname-in link-prefix)) + (throw 'system-error args)))))) + +;; There are 3 main kinds of errors we can get from hardlinking: "Too many +;; things link to this" (EMLINK), "this link already exists" (EEXIST), and +;; "can't fit more stuff in this directory" (ENOSPC). + +(define (replace-with-link target to-replace) + "Atomically replace the file TO-REPLACE with a link to TARGET. Note: TARGET +and TO-REPLACE must be on the same file system." + (let ((temp-link (get-temp-link target (dirname to-replace)))) + (rename-file temp-link to-replace))) + +(define-syntax-rule (false-if-system-error (errors ...) exp ...) + "Given ERRORS, a list of system error codes to ignore, evaluates EXP... and +return #f if any of the system error codes in the given list are thrown." + (catch 'system-error + (lambda () + exp ...) + (lambda args + (if (member (system-error-errno args) (list errors ...)) + #f + (apply throw args))))) + +(define* (deduplicate path hash #:key (store %store-directory)) + "Check if a store item with sha256 hash HASH already exists. If so, +replace PATH with a hardlink to the already-existing one. If not, register +PATH so that future duplicates can hardlink to it. PATH is assumed to be +under STORE." + (let* ((links-directory (string-append store "/.links")) + (link-file (string-append links-directory "/" + (bytevector->base16-string hash)))) + (mkdir-p links-directory) + (if (file-is-directory? path) + ;; Can't hardlink directories, so hardlink their atoms. + (for-each (lambda (file) + (unless (member file '("." "..")) + (deduplicate file (nar-sha256 file) + #:store store))) + (scandir path)) + (if (file-exists? link-file) + (false-if-system-error (EMLINK) + (replace-with-link link-file path)) + (catch 'system-error + (lambda () + (link path link-file)) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EEXIST) + ;; Someone else put an entry for PATH in + ;; LINKS-DIRECTORY before we could. Let's use it. + (false-if-system-error (EMLINK) + (replace-with-link path link-file))) + ((= errno ENOSPC) + ;; There's not enough room in the directory index for + ;; more entries in .links, but that's fine: we can + ;; just stop. + #f) + (else (apply throw args)))))))))) diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm new file mode 100644 index 0000000000..04817a193a --- /dev/null +++ b/tests/store-deduplication.scm @@ -0,0 +1,64 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 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 . + +(define-module (test-store-deduplication) + #:use-module (guix tests) + #:use-module (guix store deduplication) + #:use-module (guix hash) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (guix build utils) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(test-begin "store-deduplication") + +(test-equal "deduplicate" + (cons* #t #f ;inode comparisons + 2 (make-list 5 6)) ;'nlink' values + + (call-with-temporary-directory + (lambda (store) + (let ((data (string->utf8 "Hello, world!")) + (identical (map (lambda (n) + (string-append store "/" (number->string n))) + (iota 5))) + (unique (string-append store "/unique"))) + (for-each (lambda (file) + (call-with-output-file file + (lambda (port) + (put-bytevector port data)))) + identical) + (call-with-output-file unique + (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) + + ;; (system (string-append "ls -lRia " store)) + (cons* (apply = (map (compose stat:ino stat) identical)) + (= (stat:ino (stat unique)) + (stat:ino (stat (car identical)))) + (stat:nlink (stat unique)) + (map (compose stat:nlink stat) identical)))))) + +(test-end "store-deduplication") -- cgit v1.2.3 From 6d52844cd4c376b7b344b448de8a2c7a3d252afb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 17:31:44 +0200 Subject: self: Add dependency on guile-gdbm-ffi. Fixes a regression introduced in 331ac4cc239727992329207ba428b3f26cae91d9 whereby "guile-gdbm-ffi" would now be mandatory. * guix/self.scm (specification->package): Add "guile-gdbm-ffi" and "guile2.0-gdbm-ffi". (compiled-guix)[guile-gdbm-ffi]: New variables. [dependencies]: Add it. --- guix/self.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 64cf3033b7..9ff949075d 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -82,6 +82,7 @@ (define specification->package ("guile-json" (ref '(gnu packages guile) 'guile-json)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) + ("guile-gdbm-ffi" (ref '(gnu packages guile) 'guile-gdbm-ffi)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) ("zlib" (ref '(gnu packages compression) 'zlib)) @@ -93,6 +94,7 @@ (define specification->package ("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)) + ("guile2.0-gdbm-ffi" (ref '(gnu packages guile) 'guile2.0-gdbm-ffi)) ;; XXX: No "guile2.0-sqlite3". (_ #f)))) ;no such package @@ -217,6 +219,11 @@ (define guile-git "guile-git" "guile2.0-git")) + (define guile-gdbm-ffi + (package-for-guile guile-version + "guile-gdbm-ffi" + "guile2.0-gdbm-ffi")) + (define guile-sqlite3 (package-for-guile guile-version @@ -227,7 +234,8 @@ (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 guile-git guile-json guile-ssh + guile-gdbm-ffi guile-sqlite3)) (((labels packages _ ...) ...) packages))) -- cgit v1.2.3 From 54be2b4d759c9e40c5b564726f882470bbac4387 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 18:36:28 +0200 Subject: self: Show backtraces on more columns. * guix/self.scm (compiled-modules): Add "COLUMNS" to #:env-vars. --- guix/self.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 9ff949075d..3503fbda43 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -588,7 +588,11 @@ (define (process-directory directory output) `(#:local-build? #f ;allow substitutes ;; Don't annoy people about _IONBF deprecation. - #:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) + ;; Initialize 'terminal-width' in (system repl debug) + ;; to a large-enough value to make backtrace more + ;; verbose. + #:env-vars (("GUILE_WARN_DEPRECATED" . "no") + ("COLUMNS" . "200"))))) ;;; -- cgit v1.2.3