From 9daf046c5dd9256e45073dfd4647e12de10dcb3e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Sep 2018 17:30:06 +0200 Subject: inferior: Add 'inferior-package-derivation'. * guix/inferior.scm (read-inferior-response) (send-inferior-request): New procedures. (inferior-eval): Rewrite in terms of these. (proxy, inferior-package-derivation, inferior-package->derivation) (package-compiler): New procedures. * tests/inferior.scm ("inferior-package-derivation"): New test. --- guix/inferior.scm | 125 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 119 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index af37233a03..5bef964887 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -19,9 +19,21 @@ (define-module (guix inferior) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:use-module ((guix utils) #:select (source-properties->location)) + #:use-module ((guix utils) + #:select (%current-system + source-properties->location + call-with-temporary-directory)) + #:use-module ((guix store) + #:select (nix-server-socket + nix-server-major-version + nix-server-minor-version + store-lift)) + #:use-module ((guix derivations) + #:select (read-derivation-from-file)) + #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (ice-9 popen) + #:use-module (ice-9 binary-ports) #:export (inferior? open-inferior close-inferior @@ -36,7 +48,8 @@ inferior-package-synopsis inferior-package-description inferior-package-home-page - inferior-package-location)) + inferior-package-location + inferior-package-derivation)) ;;; Commentary: ;;; @@ -123,8 +136,7 @@ equivalent. Return #f if the inferior could not be launched." (set-record-type-printer! write-inferior-object) -(define (inferior-eval exp inferior) - "Evaluate EXP in INFERIOR." +(define (read-inferior-response inferior) (define sexp->object (match-lambda (('value value) @@ -132,14 +144,21 @@ equivalent. Return #f if the inferior could not be launched." (('non-self-quoting address string) (inferior-object address string)))) - (write exp (inferior-socket inferior)) - (newline (inferior-socket inferior)) (match (read (inferior-socket inferior)) (('values objects ...) (apply values (map sexp->object objects))) (('exception key objects ...) (apply throw key (map sexp->object objects))))) +(define (send-inferior-request exp inferior) + (write exp (inferior-socket inferior)) + (newline (inferior-socket inferior))) + +(define (inferior-eval exp inferior) + "Evaluate EXP in INFERIOR." + (send-inferior-request exp inferior) + (read-inferior-response inferior)) + ;;; ;;; Inferior packages. @@ -216,3 +235,97 @@ record." (location->source-properties loc))) package-location)))) + +(define (proxy client backend) ;adapted from (guix ssh) + "Proxy communication between CLIENT and BACKEND until CLIENT closes the +connection, at which point CLIENT is closed (both CLIENT and BACKEND must be +input/output ports.)" + (define (select* read write except) + ;; This is a workaround for in Guile < 2.2.4: + ;; since 'select' sometimes returns non-empty sets for no good reason, + ;; call 'select' a second time with a zero timeout to filter out incorrect + ;; replies. + (match (select read write except) + ((read write except) + (select read write except 0)))) + + ;; Use buffered ports so that 'get-bytevector-some' returns up to the + ;; whole buffer like read(2) would--see . + (setvbuf client _IOFBF 65536) + (setvbuf backend _IOFBF 65536) + + (let loop () + (match (select* (list client backend) '() '()) + ((reads () ()) + (when (memq client reads) + (match (get-bytevector-some client) + ((? eof-object?) + (close-port client)) + (bv + (put-bytevector backend bv) + (force-output backend)))) + (when (memq backend reads) + (match (get-bytevector-some backend) + (bv + (put-bytevector client bv) + (force-output client)))) + (unless (port-closed? client) + (loop)))))) + +(define* (inferior-package-derivation store package + #:optional + (system (%current-system)) + #:key target) + "Return the derivation for PACKAGE, an inferior package, built for SYSTEM +and cross-built for TARGET if TARGET is true. The inferior corresponding to +PACKAGE must be live." + ;; Create a named socket in /tmp and let the inferior of PACKAGE connect to + ;; it and use it as its store. This ensures the inferior uses the same + ;; store, with the same options, the same per-session GC roots, etc. + (call-with-temporary-directory + (lambda (directory) + (chmod directory #o700) + (let* ((name (string-append directory "/inferior")) + (socket (socket AF_UNIX SOCK_STREAM 0)) + (inferior (inferior-package-inferior package)) + (major (nix-server-major-version store)) + (minor (nix-server-minor-version store)) + (proto (logior major minor))) + (bind socket AF_UNIX name) + (listen socket 1024) + (send-inferior-request + `(let ((socket (socket AF_UNIX SOCK_STREAM 0))) + (connect socket AF_UNIX ,name) + + ;; 'port->connection' appeared in June 2018 and we can hardly + ;; emulate it on older versions. Thus fall back to + ;; 'open-connection', at the risk of talking to the wrong daemon or + ;; having our build result reclaimed (XXX). + (let* ((store (if (defined? 'port->connection) + (port->connection socket #:version ,proto) + (open-connection))) + (package (hashv-ref %package-table + ,(inferior-package-id package))) + (drv ,(if target + `(package-cross-derivation store package + ,target + ,system) + `(package-derivation store package + ,system)))) + (close-connection store) + (close-port socket) + (derivation-file-name drv))) + inferior) + (match (accept socket) + ((client . address) + (proxy client (nix-server-socket store)))) + (close-port socket) + (read-derivation-from-file (read-inferior-response inferior)))))) + +(define inferior-package->derivation + (store-lift inferior-package-derivation)) + +(define-gexp-compiler (package-compiler (package ) system + target) + ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET. + (inferior-package->derivation package system #:target target)) -- cgit v1.2.3 From e1a4ffdab52f616f41de4ff783a712bcd50a5187 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Sep 2018 14:50:14 +0200 Subject: inferior: Add 'lookup-inferior-packages'. * guix/inferior.scm ()[packages, table]: New fields. (open-inferior): Initialize these new fields. (inferior-packages): Rename to... (%inferior-packages): ... this. (inferior-packages): New procedure; force the promise. (%inferior-package-table, lookup-inferior-packages): New procedures. * tests/inferior.scm ("lookup-inferior-packages") ("lookup-inferior-packages and eq?-ness"): New tests. --- guix/inferior.scm | 47 +++++++++++++++++++++++++++++++++++++++++------ tests/inferior.scm | 29 +++++++++++++++++++++++++++++ 2 files changed, 70 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 5bef964887..81b71d0c77 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -22,7 +22,8 @@ #:use-module ((guix utils) #:select (%current-system source-properties->location - call-with-temporary-directory)) + call-with-temporary-directory + version>? version-prefix?)) #:use-module ((guix store) #:select (nix-server-socket nix-server-major-version @@ -31,8 +32,10 @@ #:use-module ((guix derivations) #:select (read-derivation-from-file)) #:use-module (guix gexp) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 popen) + #:use-module (ice-9 vlist) #:use-module (ice-9 binary-ports) #:export (inferior? open-inferior @@ -45,6 +48,7 @@ inferior-package-version inferior-packages + lookup-inferior-packages inferior-package-synopsis inferior-package-description inferior-package-home-page @@ -61,11 +65,13 @@ ;; Inferior Guix process. (define-record-type - (inferior pid socket version) + (inferior pid socket version packages table) inferior? (pid inferior-pid) (socket inferior-socket) - (version inferior-version)) ;REPL protocol version + (version inferior-version) ;REPL protocol version + (packages inferior-package-promise) ;promise of inferior packages + (table inferior-package-table)) ;promise of vhash (define (inferior-pipe directory command) "Return an input/output pipe on the Guix instance in DIRECTORY. This runs @@ -109,7 +115,9 @@ equivalent. Return #f if the inferior could not be launched." (match (read pipe) (('repl-version 0 rest ...) - (let ((result (inferior 'pipe pipe (cons 0 rest)))) + (letrec ((result (inferior 'pipe pipe (cons 0 rest) + (delay (%inferior-packages result)) + (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) (inferior-eval '(define %package-table (make-hash-table)) @@ -181,8 +189,8 @@ equivalent. Return #f if the inferior could not be launched." (set-record-type-printer! write-inferior-package) -(define (inferior-packages inferior) - "Return the list of packages known to INFERIOR." +(define (%inferior-packages inferior) + "Compute the list of inferior packages from INFERIOR." (let ((result (inferior-eval '(fold-packages (lambda (package result) (let ((id (object-address package))) @@ -198,6 +206,33 @@ equivalent. Return #f if the inferior could not be launched." (inferior-package inferior name version id))) result))) +(define (inferior-packages inferior) + "Return the list of packages known to INFERIOR." + (force (inferior-package-promise inferior))) + +(define (%inferior-package-table inferior) + "Compute a package lookup table for INFERIOR." + (fold (lambda (package table) + (vhash-cons (inferior-package-name package) package + table)) + vlist-null + (inferior-packages inferior))) + +(define* (lookup-inferior-packages inferior name #:optional version) + "Return the sorted list of inferior packages matching NAME in INFERIOR, with +highest version numbers first. If VERSION is true, return only packages with +a version number prefixed by VERSION." + ;; This is the counterpart of 'find-packages-by-name'. + (sort (filter (lambda (package) + (or (not version) + (version-prefix? version + (inferior-package-version package)))) + (vhash-fold* cons '() name + (force (inferior-package-table inferior)))) + (lambda (p1 p2) + (version>? (inferior-package-version p1) + (inferior-package-version p2))))) + (define (inferior-package-field package getter) "Return the field of PACKAGE, an inferior package, accessed with GETTER." (let ((inferior (inferior-package-inferior package)) diff --git a/tests/inferior.scm b/tests/inferior.scm index 817fcb6c6b..791e30b179 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -79,6 +79,35 @@ (close-inferior inferior) result)))) +(test-equal "lookup-inferior-packages" + (let ((->list (lambda (package) + (list (package-name package) + (package-version package) + (package-location package))))) + (list (map ->list (find-packages-by-name "guile" #f)) + (map ->list (find-packages-by-name "guile" "2.2")))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (->list (lambda (package) + (list (inferior-package-name package) + (inferior-package-version package) + (inferior-package-location package)))) + (lst1 (map ->list + (lookup-inferior-packages inferior "guile"))) + (lst2 (map ->list + (lookup-inferior-packages inferior + "guile" "2.2")))) + (close-inferior inferior) + (list lst1 lst2))) + +(test-assert "lookup-inferior-packages and eq?-ness" + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (lst1 (lookup-inferior-packages inferior "guile")) + (lst2 (lookup-inferior-packages inferior "guile"))) + (close-inferior inferior) + (every eq? lst1 lst2))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From 6030396aec325b3c3287a472014bc2d530abb99d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Sep 2018 09:55:31 +0200 Subject: inferior: Add 'inferior-package-inputs' & co. * guix/inferior.scm (open-inferior): Use (ice-9 match). (inferior-package-input-field, inferior-package-inputs): (inferior-package-native-inputs) (inferior-package-propagated-inputs) (inferior-package-transitive-propagated-inputs): New procedures. * tests/inferior.scm ("inferior-package-inputs"): New test. inputs fixlet --- guix/inferior.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/inferior.scm | 34 +++++++++++++++++++++++++++++++++- 2 files changed, 84 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 81b71d0c77..ca819c6eff 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -33,6 +33,7 @@ #:select (read-derivation-from-file)) #:use-module (guix gexp) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 vlist) @@ -53,6 +54,10 @@ inferior-package-description inferior-package-home-page inferior-package-location + inferior-package-inputs + inferior-package-native-inputs + inferior-package-propagated-inputs + inferior-package-transitive-propagated-inputs inferior-package-derivation)) ;;; Commentary: @@ -120,6 +125,7 @@ equivalent. Return #f if the inferior could not be launched." (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) + (inferior-eval '(use-modules (ice-9 match)) result) (inferior-eval '(define %package-table (make-hash-table)) result) result)) @@ -271,6 +277,51 @@ record." loc))) package-location)))) +(define (inferior-package-input-field package field) + "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an +inferior package." + (define field* + `(compose (lambda (inputs) + (map (match-lambda + ;; XXX: Origins are not handled. + ((label (? package? package) rest ...) + (let ((id (object-address package))) + (hashv-set! %package-table id package) + `(,label (package ,id + ,(package-name package) + ,(package-version package)) + ,@rest))) + (x + x)) + inputs)) + ,field)) + + (define inputs + (inferior-package-field package field*)) + + (define inferior + (inferior-package-inferior package)) + + (map (match-lambda + ((label ('package id name version) . rest) + ;; XXX: eq?-ness of inferior packages is not preserved here. + `(,label ,(inferior-package inferior name version id) + ,@rest)) + (x x)) + inputs)) + +(define inferior-package-inputs + (cut inferior-package-input-field <> 'package-inputs)) + +(define inferior-package-native-inputs + (cut inferior-package-input-field <> 'package-native-inputs)) + +(define inferior-package-propagated-inputs + (cut inferior-package-input-field <> 'package-propagated-inputs)) + +(define inferior-package-transitive-propagated-inputs + (cut inferior-package-input-field <> 'package-transitive-propagated-inputs)) + (define (proxy client backend) ;adapted from (guix ssh) "Proxy communication between CLIENT and BACKEND until CLIENT closes the connection, at which point CLIENT is closed (both CLIENT and BACKEND must be diff --git a/tests/inferior.scm b/tests/inferior.scm index 791e30b179..03170a19c9 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -24,8 +24,10 @@ #:use-module (guix derivations) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) + #:use-module (gnu packages guile) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) (define %top-srcdir (dirname (search-path %load-path "guix.scm"))) @@ -108,6 +110,36 @@ (close-inferior inferior) (every eq? lst1 lst2))) +(test-equal "inferior-package-inputs" + (let ((->list (match-lambda + ((label (? package? package) . rest) + `(,label + (package ,(package-name package) + ,(package-version package) + ,(package-location package)) + ,@rest))))) + (list (map ->list (package-inputs guile-2.2)) + (map ->list (package-native-inputs guile-2.2)) + (map ->list (package-propagated-inputs guile-2.2)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (->list (match-lambda + ((label (? inferior-package? package) . rest) + `(,label + (package ,(inferior-package-name package) + ,(inferior-package-version package) + ,(inferior-package-location package)) + ,@rest)))) + (result (list (map ->list (inferior-package-inputs guile)) + (map ->list + (inferior-package-native-inputs guile)) + (map ->list + (inferior-package-propagated-inputs + guile))))) + (close-inferior inferior) + result)) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From eee8b303f6d82c1400fd8fd3b097406358ed7875 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Sep 2018 10:04:15 +0200 Subject: inferior: Add 'inferior-package-search-paths' & co. * guix/inferior.scm (%inferior-package-search-paths) (inferior-package-native-search-paths) (inferior-package-search-paths) (inferior-package-transitive-native-search-paths): New procedures. * tests/inferior.scm ("inferior-package-search-paths"): New test. --- guix/inferior.scm | 26 ++++++++++++++++++++++++++ tests/inferior.scm | 9 +++++++++ 2 files changed, 35 insertions(+) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index ca819c6eff..3fa4930095 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -32,6 +32,7 @@ #:use-module ((guix derivations) #:select (read-derivation-from-file)) #:use-module (guix gexp) + #:use-module (guix search-paths) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) @@ -58,6 +59,9 @@ inferior-package-native-inputs inferior-package-propagated-inputs inferior-package-transitive-propagated-inputs + inferior-package-native-search-paths + inferior-package-transitive-native-search-paths + inferior-package-search-paths inferior-package-derivation)) ;;; Commentary: @@ -322,6 +326,28 @@ inferior package." (define inferior-package-transitive-propagated-inputs (cut inferior-package-input-field <> 'package-transitive-propagated-inputs)) +(define (%inferior-package-search-paths package field) + "Return the list of search path specificiations of PACKAGE, an inferior +package." + (define paths + (inferior-package-field package + `(compose (lambda (paths) + (map (@ (guix search-paths) + search-path-specification->sexp) + paths)) + ,field))) + + (map sexp->search-path-specification paths)) + +(define inferior-package-native-search-paths + (cut %inferior-package-search-paths <> 'package-native-search-paths)) + +(define inferior-package-search-paths + (cut %inferior-package-search-paths <> 'package-search-paths)) + +(define inferior-package-transitive-native-search-paths + (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths)) + (define (proxy client backend) ;adapted from (guix ssh) "Proxy communication between CLIENT and BACKEND until CLIENT closes the connection, at which point CLIENT is closed (both CLIENT and BACKEND must be diff --git a/tests/inferior.scm b/tests/inferior.scm index 03170a19c9..99d736bd40 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -140,6 +140,15 @@ (close-inferior inferior) result)) +(test-equal "inferior-package-search-paths" + (package-native-search-paths guile-2.2) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (result (inferior-package-native-search-paths guile))) + (close-inferior inferior) + result)) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From 2e6d64e122ad2745154a38122785895d1b66c2ff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Sep 2018 09:56:34 +0200 Subject: inferior: Add 'inferior-package->manifest-entry'. * guix/inferior.scm (inferior-package->manifest-entry): New procedure. * tests/inferior.scm (manifest-entry->list): New procedure. ("inferior-package->manifest-entry"): New test. --- guix/inferior.scm | 42 ++++++++++++++++++++++++++++++++++++++---- tests/inferior.scm | 18 ++++++++++++++++++ 2 files changed, 56 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 3fa4930095..c86fdd3ec1 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -33,6 +33,7 @@ #:select (read-derivation-from-file)) #:use-module (guix gexp) #:use-module (guix search-paths) + #:use-module (guix profiles) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) @@ -45,12 +46,12 @@ inferior-eval inferior-object? + inferior-packages + lookup-inferior-packages + inferior-package? inferior-package-name inferior-package-version - - inferior-packages - lookup-inferior-packages inferior-package-synopsis inferior-package-description inferior-package-home-page @@ -62,7 +63,9 @@ inferior-package-native-search-paths inferior-package-transitive-native-search-paths inferior-package-search-paths - inferior-package-derivation)) + inferior-package-derivation + + inferior-package->manifest-entry)) ;;; Commentary: ;;; @@ -441,3 +444,34 @@ PACKAGE must be live." target) ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET. (inferior-package->derivation package system #:target target)) + + +;;; +;;; Manifest entries. +;;; + +(define* (inferior-package->manifest-entry package + #:optional (output "out") + #:key (parent (delay #f)) + (properties '())) + "Return a manifest entry for the OUTPUT of package PACKAGE." + ;; For each dependency, keep a promise pointing to its "parent" entry. + (letrec* ((deps (map (match-lambda + ((label package) + (inferior-package->manifest-entry package + #:parent (delay entry))) + ((label package output) + (inferior-package->manifest-entry package output + #:parent (delay entry)))) + (inferior-package-propagated-inputs package))) + (entry (manifest-entry + (name (inferior-package-name package)) + (version (inferior-package-version package)) + (output output) + (item package) + (dependencies (delete-duplicates deps)) + (search-paths + (inferior-package-transitive-native-search-paths package)) + (parent parent) + (properties properties)))) + entry)) diff --git a/tests/inferior.scm b/tests/inferior.scm index 99d736bd40..6f6abd28a1 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -21,6 +21,7 @@ #:use-module (guix inferior) #:use-module (guix packages) #:use-module (guix store) + #:use-module (guix profiles) #:use-module (guix derivations) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) @@ -38,6 +39,13 @@ (define %store (open-connection-for-tests)) +(define (manifest-entry->list entry) + (list (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-output entry) + (manifest-entry-search-paths entry) + (map manifest-entry->list (manifest-entry-dependencies entry)))) + (test-begin "inferior") @@ -164,4 +172,14 @@ (list (inferior-package-derivation %store guile "x86_64-linux") (inferior-package-derivation %store guile "armhf-linux"))))) +(test-equal "inferior-package->manifest-entry" + (manifest-entry->list (package->manifest-entry + (first (find-best-packages-by-name "guile" #f)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (entry (inferior-package->manifest-entry guile))) + (close-inferior inferior) + (manifest-entry->list entry))) + (test-end "inferior") -- cgit v1.2.3 From 811b21fb15d36b06fde994ca7ef5916a9a19f250 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Sep 2018 10:21:28 +0200 Subject: profiles: 'packages->manifest' now accepts inferior packages. * guix/profiles.scm (packages->manifest)[inferiors-loaded?]: New variable. [inferior->entry]: New procedure. Accept inferior packages when INFERIORS-LOADED? is true. * tests/guix-package.sh: Add test using a manifest with an inferior. * tests/inferior.scm ("packages->manifest"): New test. --- guix/profiles.scm | 27 +++++++++++++++++++++++---- tests/guix-package.sh | 15 +++++++++++++++ tests/inferior.scm | 11 +++++++++++ 3 files changed, 49 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 8acfcff8c1..669ebe04e5 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -314,12 +314,31 @@ file name." "Return a list of manifest entries, one for each item listed in PACKAGES. Elements of PACKAGES can be either package objects or package/string tuples denoting a specific output of a package." + (define inferiors-loaded? + ;; This hack allows us to provide seamless integration for inferior + ;; packages while not having a hard dependency on (guix inferior). + (resolve-module '(guix inferior) #f #f #:ensure #f)) + + (define (inferior->entry) + (module-ref (resolve-interface '(guix inferior)) + 'inferior-package->manifest-entry)) + (manifest (map (match-lambda - ((package output) - (package->manifest-entry package output)) - ((? package? package) - (package->manifest-entry package))) + ((package output) + (package->manifest-entry package output)) + ((? package? package) + (package->manifest-entry package)) + ((thing output) + (if inferiors-loaded? + ((inferior->entry) thing output) + (throw 'wrong-type-arg 'packages->manifest + "Wrong package object: ~S" (list thing) (list thing)))) + (thing + (if inferiors-loaded? + ((inferior->entry) thing) + (throw 'wrong-type-arg 'packages->manifest + "Wrong package object: ~S" (list thing) (list thing))))) packages))) (define (manifest->gexp manifest) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index cef3b3452e..f7dfbfad00 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -358,6 +358,21 @@ EOF guix package --bootstrap -m "$module_dir/manifest.scm" guix package -I | grep guile test `guix package -I | wc -l` -eq 1 +guix package --rollback --bootstrap + +# Applying a manifest file with inferior packages. +cat > "$module_dir/manifest.scm"<manifest (list guile))) +EOF +guix package --bootstrap -m "$module_dir/manifest.scm" +guix package -I | grep guile +test `guix package -I | wc -l` -eq 1 # Error reporting. cat > "$module_dir/manifest.scm"<list entry))) +(test-equal "packages->manifest" + (map manifest-entry->list + (manifest-entries (packages->manifest + (find-best-packages-by-name "guile" #f)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (manifest (packages->manifest (list guile)))) + (close-inferior inferior) + (map manifest-entry->list (manifest-entries manifest)))) + (test-end "inferior") -- cgit v1.2.3 From c37f38bde69c072cfd0006ba89f30f0d0ad24448 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Sep 2018 12:08:05 +0200 Subject: channels: Add 'channel-instances->derivation'. * guix/channels.scm (channel-instances->derivation): New procedure. (latest-channel-derivation): Use it. (channel-instance-derivations): Make private. --- guix/channels.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 2e7bffae9f..82389eb583 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -47,9 +47,9 @@ channel-instance-checkout latest-channel-instances - channel-instance-derivations latest-channel-derivation - channel-instances->manifest)) + channel-instances->manifest + channel-instances->derivation)) ;;; Commentary: ;;; @@ -294,13 +294,17 @@ channel instances." (zip instances derivations)))) (return (manifest entries)))) +(define (channel-instances->derivation instances) + "Return the derivation of the profile containing INSTANCES, a list of +channel instances." + (mlet %store-monad ((manifest (channel-instances->manifest instances))) + (profile-derivation manifest))) + (define latest-channel-instances* (store-lift latest-channel-instances)) (define* (latest-channel-derivation #:optional (channels %default-channels)) "Return as a monadic value the derivation that builds the profile for the latest instances of CHANNELS." - (mlet* %store-monad ((instances ((store-lift latest-channel-instances) - channels)) - (manifest (channel-instances->manifest instances))) - (profile-derivation manifest))) + (mlet %store-monad ((instances (latest-channel-instances* channels))) + (channel-instances->derivation instances))) -- cgit v1.2.3 From 2dad0313753c4b506eb1f401136b6fcb4785a3b9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Sep 2018 13:30:48 +0200 Subject: inferior: Add 'inferior-for-channels'. * guix/inferior.scm (%inferior-cache-directory): New variable. (inferior-for-channels): New procedure. --- guix/inferior.scm | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 83 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index c86fdd3ec1..1dbb9e1699 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -23,7 +23,8 @@ #:select (%current-system source-properties->location call-with-temporary-directory - version>? version-prefix?)) + version>? version-prefix? + cache-directory)) #:use-module ((guix store) #:select (nix-server-socket nix-server-major-version @@ -34,12 +35,23 @@ #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix profiles) + #:use-module (guix channels) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix base32) + #:use-module (gcrypt hash) + #:autoload (guix cache) (maybe-remove-expired-cache-entries) + #:autoload (guix ui) (show-what-to-build*) + #:autoload (guix build utils) (mkdir-p) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 vlist) #:use-module (ice-9 binary-ports) + #:use-module ((rnrs bytevectors) #:select (string->utf8)) #:export (inferior? open-inferior close-inferior @@ -65,7 +77,10 @@ inferior-package-search-paths inferior-package-derivation - inferior-package->manifest-entry)) + inferior-package->manifest-entry + + %inferior-cache-directory + inferior-for-channels)) ;;; Commentary: ;;; @@ -475,3 +490,69 @@ PACKAGE must be live." (parent parent) (properties properties)))) entry)) + + +;;; +;;; Cached inferiors. +;;; + +(define %inferior-cache-directory + ;; Directory for cached inferiors (GC roots). + (make-parameter (string-append (cache-directory #:ensure? #f) + "/inferiors"))) + +(define* (inferior-for-channels channels + #:key + (cache-directory (%inferior-cache-directory)) + (ttl (* 3600 24 30))) + "Return an inferior for CHANNELS, a list of channels. Use the cache at +CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This +procedure opens a new connection to the build daemon. + +This is a convenience procedure that people may use in manifests passed to +'guix package -m', for instance." + (with-store store + (let () + (define instances + (latest-channel-instances store channels)) + + (define key + (bytevector->base32-string + (sha256 + (string->utf8 + (string-concatenate (map channel-instance-commit instances)))))) + + (define cached + (string-append cache-directory "/" key)) + + (define (base32-encoded-sha256? str) + (= (string-length str) 52)) + + (define (cache-entries directory) + (map (lambda (file) + (string-append directory "/" file)) + (scandir directory base32-encoded-sha256?))) + + (define symlink* + (lift2 symlink %store-monad)) + + (define add-indirect-root* + (store-lift add-indirect-root)) + + (mkdir-p cache-directory) + (maybe-remove-expired-cache-entries cache-directory + cache-entries + #:entry-expiration + (file-expiration-time ttl)) + + (if (file-exists? cached) + (open-inferior cached) + (run-with-store store + (mlet %store-monad ((profile + (channel-instances->derivation instances))) + (mbegin %store-monad + (show-what-to-build* (list profile)) + (built-derivations (list profile)) + (symlink* (derivation->output-path profile) cached) + (add-indirect-root* cached) + (return (open-inferior cached))))))))) -- cgit v1.2.3 From c122a2e509df98c4391750a066fecba37465eab3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 23 Sep 2018 22:11:35 +0200 Subject: serialization: Remove redundancy in 'write-file'. * guix/serialization.scm (write-file): Remove redundant 'member' call. --- guix/serialization.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/serialization.scm b/guix/serialization.scm index 129374f541..87ad7eeec0 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -301,8 +301,7 @@ result of 'lstat'; exclude entries for which SELECT? does not return true." (filter-map (lambda (base) (let ((file (string-append directory "/" base))) - (and (not (member base '("." ".."))) - (select? file (lstat file)) + (and (select? file (lstat file)) base))) basenames)) -- cgit v1.2.3 From a387b0bebb151a766ca6a454a891f2370c96703c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 23 Sep 2018 22:24:07 +0200 Subject: store-copy: Display a progress bar when copying store items. * guix/build/store-copy.scm (populate-store): Add #:log-port parameter. Use 'progress-reporter/bar' to report progress. --- guix/build/store-copy.scm | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 2d9590d16f..64ade7885c 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -19,6 +19,7 @@ (define-module (guix build store-copy) #:use-module (guix build utils) #:use-module (guix sets) + #:use-module (guix progress) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -167,7 +168,8 @@ REFERENCE-GRAPHS, a list of reference-graph files." (reduce + 0 (map file-size items))) -(define* (populate-store reference-graphs target) +(define* (populate-store reference-graphs target + #:key (log-port (current-error-port))) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." (define store @@ -183,9 +185,20 @@ REFERENCE-GRAPHS, a list of reference-graph files." (mkdir-p store) (chmod store #o1775) - (for-each (lambda (thing) - (copy-recursively thing - (string-append target thing))) - (things-to-copy))) + + (let* ((things (things-to-copy)) + (len (length things)) + (progress (progress-reporter/bar len + (format #f "copying ~a store items" + len) + log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (thing) + (copy-recursively thing + (string-append target thing) + #:log (%make-void-port "w")) + (report)) + things))))) ;;; store-copy.scm ends here -- cgit v1.2.3 From f0addd6461658d13eadf5f6e3bdb89aa02a6e902 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 23 Sep 2018 22:51:51 +0200 Subject: database: 'register-items' shows a progress bar. * guix/store/database.scm (register-items): Add #:log-port. Use 'progress-reporter/bar' to show a progress report. (register-path): Pass #:log-port to 'register-items'. --- guix/store/database.scm | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 0879a95d0b..5d094faaf3 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -23,6 +23,7 @@ #:use-module (guix serialization) #:use-module (guix store deduplication) #:use-module (guix base16) + #:use-module (guix progress) #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (mkdir-p executable-file?)) @@ -234,7 +235,8 @@ be used internally by the daemon's build hook." #:prefix prefix #:state-directory state-directory #:deduplicate? deduplicate? #:reset-timestamps? reset-timestamps? - #:schema schema)) + #:schema schema + #:log-port (%make-void-port "w"))) (define %epoch ;; When it all began. @@ -245,12 +247,14 @@ be used internally by the daemon's build hook." (deduplicate? #t) (reset-timestamps? #t) registration-time - (schema (sql-schema))) + (schema (sql-schema)) + (log-port (current-error-port))) "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. REGISTRATION-TIME must be the -registration time to be recorded in the database; #f means \"now\"." +registration time to be recorded in the database; #f means \"now\". +Write a progress report to LOG-PORT." ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and @@ -302,4 +306,12 @@ registration time to be recorded in the database; #f means \"now\"." (mkdir-p db-dir) (parameterize ((sql-schema schema)) (with-database (string-append db-dir "/db.sqlite") db - (for-each (cut register db <>) items)))) + (let* ((prefix (format #f "registering ~a items" (length items))) + (progress (progress-reporter/bar (length items) + prefix log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (item) + (register db item) + (report)) + items))))))) -- cgit v1.2.3 From bb3b6ccb05550fbfbeb459c68819a752327d6e1e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 23 Sep 2018 23:11:30 +0200 Subject: database: Register each store item only once. Fixes . Reported by Leo Famulari. * guix/store/database.scm (register-items): Check whether TO-REGISTER is in DB by calling 'path-id', and skip the reset-timestamps, registration, and deduplication phases when it is. --- guix/store/database.scm | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 5d094faaf3..341276bc30 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -290,18 +290,22 @@ Write a progress report to LOG-PORT." (define real-file-name (string-append store-dir "/" (basename (store-info-item item)))) - (let-values (((hash nar-size) (nar-sha256 real-file-name))) + ;; When TO-REGISTER is already registered, skip it. This makes a + ;; significant differences when 'register-closures' is called + ;; consecutively for overlapping closures such as 'system' and 'bootcfg'. + (unless (path-id db to-register) (when reset-timestamps? (reset-timestamps real-file-name)) - (sqlite-register db #:path to-register - #:references (store-info-references item) - #:deriver (store-info-deriver item) - #:hash (string-append "sha256:" - (bytevector->base16-string hash)) - #:nar-size nar-size - #:time registration-time) - (when deduplicate? - (deduplicate real-file-name hash #:store store-dir)))) + (let-values (((hash nar-size) (nar-sha256 real-file-name))) + (sqlite-register db #:path to-register + #:references (store-info-references item) + #:deriver (store-info-deriver item) + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size + #:time registration-time) + (when deduplicate? + (deduplicate real-file-name hash #:store store-dir))))) (mkdir-p db-dir) (parameterize ((sql-schema schema)) -- cgit v1.2.3 From 2e3a6250f8b1232c7f49f84ee7320bcd9869508a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 24 Sep 2018 14:16:13 +0200 Subject: gnupg: Change default keyserver. * guix/gnupg.scm (%openpgp-key-server): Change default to "pool.sks-keyservers.net". --- guix/gnupg.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gnupg.scm b/guix/gnupg.scm index b30ce461b4..40feb44561 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -57,7 +57,7 @@ (define %openpgp-key-server ;; The default key server. Note that keys.gnupg.net appears to be ;; unreliable. - (make-parameter "pgp.mit.edu")) + (make-parameter "pool.sks-keyservers.net")) (define* (gnupg-verify sig file #:optional (keyring (current-keyring))) -- cgit v1.2.3 From cfe19684ea21feaee97d5c31e248b5a69921f784 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 25 Sep 2018 10:22:59 +0200 Subject: progress: 'progress-reporter-report!' takes any number of arguments. * guix/progress.scm (progress-reporter-report!): Accept an arbitrary number of arguments and pass them to REPORT. --- guix/progress.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/progress.scm b/guix/progress.scm index c9c3cd12a0..53aea1c56d 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -70,11 +70,11 @@ stopped." (($ start report stop) (start)))) -(define (progress-reporter-report! reporter) +(define (progress-reporter-report! reporter . args) "Low-level procedure to lead REPORTER to emit a report." (match reporter (($ start report stop) - (report)))) + (apply report args)))) (define (stop-progress-reporter! reporter) "Low-level procedure to stop REPORTER." -- cgit v1.2.3 From f85dbc4f3bcdc9f11cea9cca4feffee2e57a4412 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 25 Sep 2018 12:28:55 +0200 Subject: substitute: Progress port really closes underlying port. * guix/scripts/substitute.scm (progress-report-port): Use 'close-port' instead of 'close-connection'. Move 'stop' call first. --- guix/scripts/substitute.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 6d31dfdaa4..50c6a22064 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -837,8 +837,8 @@ REPORTER, which should be a object." (make-custom-binary-input-port "progress-port-proc" read! #f #f (lambda () - (close-connection port) - (stop))))))) + (stop) + (close-port port))))))) (define-syntax with-networking (syntax-rules () -- cgit v1.2.3 From 88268a34bc76c88c5c5e4ecc244924f3c8503d16 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 25 Sep 2018 18:44:38 +0200 Subject: pull: Try harder to use the host's X.509 certificates. * guix/scripts/pull.scm (honor-x509-certificates): Use commonly-found certificate bundles. --- guix/scripts/pull.scm | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 10e1a99e54..39aebb18e2 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -180,9 +180,25 @@ Download and deploy the latest version of Guix.\n")) (define (honor-x509-certificates store) "Use the right X.509 certificates for Git checkouts over HTTPS." - (let ((file (getenv "SSL_CERT_FILE")) + ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of + ;; files (instead of all the certificates) among which "ca-bundle.crt". On + ;; other distros /etc/ssl/certs usually contains the whole set of + ;; certificates along with "ca-certificates.crt". Try to choose the right + ;; one. + (let ((file (letrec-syntax ((choose + (syntax-rules () + ((_ file rest ...) + (let ((f file)) + (if (and f (file-exists? f)) + f + (choose rest ...)))) + ((_) + #f)))) + (choose (getenv "SSL_CERT_FILE") + "/etc/ssl/certs/ca-certificates.crt" + "/etc/ssl/certs/ca-bundle.crt"))) (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) - (if (or (and file (file-exists? file)) + (if (or file (and=> (stat directory #f) (lambda (st) (> (stat:nlink st) 2)))) -- cgit v1.2.3 From 280fc8351230a8fea086d9bbce919ba8395f312c Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sat, 15 Sep 2018 11:53:40 +0200 Subject: git-download: Don't assume the working directory is the parent of ".git". This makes it do the right thing w.r.t. git worktrees. * guix/git-download.scm (git-file-list): Use REPOSITORY-WORKING-DIRECTORY to locate checkout. Rename from "top" to "workdir". --- guix/git-download.scm | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index 24cf11be5e..fa94fad8f8 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -156,22 +156,23 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." The result is similar to that of the 'git ls-files' command, except that it also includes directories, not just regular files. The returned file names are relative to DIRECTORY, which is not necessarily the root of the checkout." - (let* ((directory (canonicalize-path directory)) + (let* (;; 'repository-working-directory' always returns a trailing "/", + ;; so add one here to ease the comparisons below. + (directory (string-append (canonicalize-path directory) "/")) (dot-git (repository-discover directory)) - (top (dirname dot-git)) (repository (repository-open dot-git)) + ;; XXX: This procedure is mistakenly private in Guile-Git 0.1.0. + (workdir ((@@ (git repository) repository-working-directory) + repository)) (head (repository-head repository)) (oid (reference-target head)) (commit (commit-lookup repository oid)) (tree (commit-tree commit)) (files (tree-list tree))) (repository-close! repository) - (if (string=? top directory) + (if (string=? workdir directory) files - (let ((relative (string-append - (string-drop directory - (+ 1 (string-length top))) - "/"))) + (let ((relative (string-drop directory (string-length workdir)))) (filter-map (lambda (file) (and (string-prefix? relative file) (string-drop file (string-length relative)))) -- cgit v1.2.3