;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix ui)
#:use-module (guix config)
#:use-module (guix modules)
+ #:use-module (guix build-system gnu)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
;;; available at this point.
;;;
-(define %dependency-variables
- ;; (guix config) variables corresponding to dependencies.
- '(%libgcrypt %libz %xz %gzip %bzip2))
-
(define %persona-variables
;; (guix config) variables that define Guix's persona.
'(%guix-package-name
(variables rest ...))))))
(variables %localstatedir %storedir %sysconfdir %system)))
-(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
+(define* (make-config.scm #:key gzip xz bzip2
(package-name "GNU Guix")
(package-version "0")
(bug-report-address "bug-guix@gnu.org")
- (home-page-url "https://gnu.org/s/guix"))
+ (home-page-url "https://guix.gnu.org"))
;; Hack so that Geiser is not confused.
(define defmod 'define-module)
%state-directory
%store-database-directory
%config-directory
- %libgcrypt
%libz
%gzip
%bzip2
(define %state-directory
;; This must match `NIX_STATE_DIR' as defined in
;; `nix/local.mk'.
- (or (getenv "NIX_STATE_DIR")
+ (or (getenv "GUIX_STATE_DIRECTORY")
(string-append %localstatedir "/guix")))
(define %store-database-directory
- (or (getenv "NIX_DB_DIR")
+ (or (getenv "GUIX_DATABASE_DIRECTORY")
(string-append %state-directory "/db")))
(define %config-directory
(define %bzip2
#+(and bzip2 (file-append bzip2 "/bin/bzip2")))
(define %xz
- #+(and xz (file-append xz "/bin/xz")))
-
- (define %libgcrypt
- #+(and libgcrypt
- (file-append libgcrypt "/lib/libgcrypt")))
- (define %libz
- #+(and zlib
- (file-append zlib "/lib/libz")))))))
+ #+(and xz (file-append xz "/bin/xz")))))))
\f
;;;
;; XXX: Replace with a Git commit id.
(date->string (current-date 0) "~Y~m~d.~H"))
+(define guile-gcrypt
+ ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
+ ;; August 2018. If it has it, it's at least version 0.1.0, which is good
+ ;; enough. If it doesn't, specify our own package because the target Guix
+ ;; requires it.
+ (match (find-best-packages-by-name "guile-gcrypt" #f)
+ (()
+ (package
+ (name "guile-gcrypt")
+ (version "0.1.0")
+ (home-page "https://notabug.org/cwebber/guile-gcrypt")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append home-page "/archive/v" version ".tar.gz"))
+ (sha256
+ (base32
+ "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
+ (file-name (string-append name "-" version ".tar.gz"))))
+ (build-system gnu-build-system)
+ (arguments
+ ;; The 'bootstrap' phase appeared in 'core-updates', which was merged
+ ;; into 'master' ca. June 2018.
+ '(#:phases (modify-phases %standard-phases
+ (delete 'bootstrap)
+ (add-before 'configure 'bootstrap
+ (lambda _
+ (unless (zero? (system* "autoreconf" "-vfi"))
+ (error "autoreconf failed"))
+ #t)))))
+ (native-inputs
+ `(("pkg-config" ,(specification->package "pkg-config"))
+ ("autoconf" ,(specification->package "autoconf"))
+ ("automake" ,(specification->package "automake"))
+ ("texinfo" ,(specification->package "texinfo"))))
+ (inputs
+ `(("guile" ,(specification->package "guile"))
+ ("libgcrypt" ,(specification->package "libgcrypt"))))
+ (synopsis "Cryptography library for Guile using Libgcrypt")
+ (description
+ "Guile-Gcrypt provides a Guile 2.x interface to a subset of the
+GNU Libgcrypt crytographic library. It provides modules for cryptographic
+hash functions, message authentication codes (MAC), public-key cryptography,
+strong randomness, and more. It is implemented using the foreign function
+interface (FFI) of Guile.")
+ (license #f))) ;license:gpl3+
+ ((package . _)
+ package)))
+
(define* (build-program source version
#:optional (guile-version (effective-version))
- #:key (pull-version 0))
+ #:key (pull-version 0) (channel-metadata #f))
"Return a program that computes the derivation to build Guix from SOURCE."
(define select?
;; Select every module but (guix config) and non-Guix modules.
+ ;; Also exclude (guix channels): it is autoloaded by (guix describe), but
+ ;; only for peripheral functionality.
(match-lambda
(('guix 'config) #f)
+ (('guix 'channels) #f)
+ (('guix 'build 'download) #f) ;autoloaded by (guix download)
(('guix _ ...) #t)
(('gnu _ ...) #t)
(_ #f)))
+ (define fake-gcrypt-hash
+ ;; Fake (gcrypt hash) module; see below.
+ (scheme-file "hash.scm"
+ #~(define-module (gcrypt hash)
+ #:export (sha1 sha256))))
+
+ (define fake-git
+ (scheme-file "git.scm" #~(define-module (git))))
+
(with-imported-modules `(((guix config)
- => ,(make-config.scm
- #:libgcrypt
- (specification->package "libgcrypt")))
+ => ,(make-config.scm))
+
+ ;; To avoid relying on 'with-extensions', which was
+ ;; introduced in 0.15.0, provide a fake (gcrypt
+ ;; hash) just so that we can build modules, and
+ ;; adjust %LOAD-PATH later on.
+ ((gcrypt hash) => ,fake-gcrypt-hash)
+
+ ;; (guix git-download) depends on (git) but only
+ ;; for peripheral functionality. Provide a dummy
+ ;; (git) to placate it.
+ ((git) => ,fake-git)
+
,@(source-module-closure `((guix store)
(guix self)
(guix derivations)
(use-modules (ice-9 match))
(eval-when (expand load eval)
- ;; Don't augment '%load-path'.
- (unsetenv "GUIX_PACKAGE_PATH")
-
;; (gnu packages …) modules are going to be looked up
;; under SOURCE. (guix config) is looked up in FRONT.
(match (command-line)
(match %load-path
((front _ ...)
(unless (string=? front source) ;already done?
- (set! %load-path (list source front)))))))
-
- ;; Only load our own modules or those of Guile.
- (match %load-compiled-path
- ((front _ ... sys1 sys2)
- (set! %load-compiled-path
- (list front sys1 sys2)))))
+ (set! %load-path
+ (list source
+ (string-append #$guile-gcrypt
+ "/share/guile/site/"
+ (effective-version))
+ front)))))))
+
+ ;; Only load Guile-Gcrypt, our own modules, or those
+ ;; of Guile.
+ (set! %load-compiled-path
+ (cons (string-append #$guile-gcrypt "/lib/guile/"
+ (effective-version)
+ "/site-ccache")
+ %load-compiled-path))
+
+ ;; Disable position recording to save time and space
+ ;; when loading the package modules.
+ (read-disable 'positions))
(use-modules (guix store)
(guix self)
(guix derivations)
(srfi srfi-1))
- (define (spin system)
- (define spin
- (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
-
- (format (current-error-port)
- "Computing Guix derivation for '~a'... "
- system)
- (let loop ((spin spin))
- (display (string-append "\b" (car spin))
- (current-error-port))
- (force-output (current-error-port))
- (sleep 1)
- (loop (cdr spin))))
-
(match (command-line)
- ((_ source system version)
- (with-store store
- (call-with-new-thread
- (lambda ()
- (spin system)))
+ ((_ source system version protocol-version
+ build-output)
+ ;; The current input port normally wraps a file
+ ;; descriptor connected to the daemon, or it is
+ ;; connected to /dev/null. In the former case, reuse
+ ;; the connection such that we inherit build options
+ ;; such as substitute URLs and so on; in the latter
+ ;; case, attempt to open a new connection.
+ (let* ((proto (string->number protocol-version))
+ (store (if (integer? proto)
+ (port->connection (duplicate-port
+ (current-input-port)
+ "w+0")
+ #:version proto)
+ (open-connection)))
+ (sock (socket AF_UNIX SOCK_STREAM 0)))
+ ;; Connect to BUILD-OUTPUT and send it the raw
+ ;; build output.
+ (connect sock AF_UNIX build-output)
(display
(and=>
- (run-with-store store
- (guix-derivation source version
- #$guile-version
- #:pull-version
- #$pull-version)
- #:system system)
+ ;; Silence autoload warnings and the likes.
+ (parameterize ((current-warning-port
+ (%make-void-port "w"))
+ (current-build-output-port sock))
+ (run-with-store store
+ (guix-derivation source version
+ #$guile-version
+ #:channel-metadata
+ '#$channel-metadata
+ #:pull-version
+ #$pull-version)
+ #:system system))
derivation-file-name))))))
#:module-path (list source))))
+(define (proxy input output)
+ "Dump the contents of INPUT to OUTPUT until EOF is reached on INPUT.
+Display a spinner when nothing happens."
+ (define spin
+ (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
+
+ (setvbuf input 'block 16384)
+ (let loop ((spin spin))
+ (match (select (list input) '() '() 1)
+ ((() () ())
+ (when (isatty? (current-error-port))
+ (display (string-append "\b" (car spin))
+ (current-error-port))
+ (force-output (current-error-port)))
+ (loop (cdr spin)))
+ (((_) () ())
+ ;; Read from INPUT as much as can be read without blocking.
+ (let ((bv (get-bytevector-some input)))
+ (unless (eof-object? bv)
+ (put-bytevector output bv)
+ (loop spin)))))))
+
+(define (call-with-clean-environment thunk)
+ (let ((env (environ)))
+ (dynamic-wind
+ (lambda ()
+ (environ '()))
+ thunk
+ (lambda ()
+ (environ env)))))
+
+(define-syntax-rule (with-clean-environment exp ...)
+ "Evaluate EXP in a context where zero environment variables are defined."
+ (call-with-clean-environment (lambda () exp ...)))
+
;; The procedure below is our return value.
(define* (build source
- #:key verbose? (version (date-version-string)) system
- (guile-version (match ((@ (guile) version))
- ("2.2.2" "2.2.2")
- (_ (effective-version))))
+ #:key verbose?
+ (version (date-version-string)) channel-metadata
+ system
(pull-version 0)
+
+ ;; For the standalone Guix, default to Guile 3.0. For old
+ ;; versions of 'guix pull' (pre-0.15.0), we have to use the
+ ;; same Guile as the current one.
+ (guile-version (if (> pull-version 0)
+ "3.0"
+ (effective-version)))
+
#:allow-other-keys
#:rest rest)
"Return a derivation that unpacks SOURCE into STORE and compiles Scheme
;; Build the build program and then use it as a trampoline to build from
;; SOURCE.
(mlet %store-monad ((build (build-program source version guile-version
+ #:channel-metadata channel-metadata
#:pull-version pull-version))
- (system (if system (return system) (current-system))))
+ (system (if system (return system) (current-system)))
+ (home -> (getenv "HOME"))
+
+ ;; Note: Use the deprecated names here because the
+ ;; caller might be Guix <= 0.16.0.
+ (port ((store-lift nix-server-socket)))
+ (major ((store-lift nix-server-major-version)))
+ (minor ((store-lift nix-server-minor-version))))
(mbegin %store-monad
- (show-what-to-build* (list build))
+ ;; Before 'with-build-handler' was implemented and used, we had to
+ ;; explicitly call 'show-what-to-build*'.
+ (munless (module-defined? (resolve-module '(guix store))
+ 'with-build-handler)
+ (show-what-to-build* (list build)))
(built-derivations (list build))
- (let* ((pipe (begin
- (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
- (open-pipe* OPEN_READ
- (derivation->output-path build)
- source system version)))
- (str (get-string-all pipe))
- (status (close-pipe pipe)))
- (match str
- ((? eof-object?)
- (error "build program failed" (list build status)))
- ((? derivation-path? drv)
- (mbegin %store-monad
- (return (newline (current-output-port)))
- ((store-lift add-temp-root) drv)
- (return (read-derivation-from-file drv))))
- ("#f"
- ;; Unsupported PULL-VERSION.
- (return #f))
- ((? string? str)
- (error "invalid build result" (list build str))))))))
+
+ ;; Use the port beneath the current store as the stdin of BUILD. This
+ ;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is
+ ;; not a file port (e.g., it's an SSH channel), then the subprocess's
+ ;; stdin will actually be /dev/null.
+ (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
+ (node (let ((file (string-append (or (getenv "TMPDIR") "/tmp")
+ "/guix-build-output-"
+ (number->string (getpid)))))
+ (bind sock AF_UNIX file)
+ (listen sock 1)
+ file))
+ (pipe (with-input-from-port port
+ (lambda ()
+ ;; Make sure BUILD is not influenced by
+ ;; $GUILE_LOAD_PATH & co.
+ (with-clean-environment
+ (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
+ (setenv "COLUMNS" "120") ;show wider backtraces
+ (when home
+ ;; Inherit HOME so that 'xdg-directory' works.
+ (setenv "HOME" home))
+ (open-pipe* OPEN_READ
+ (derivation->output-path build)
+ source system version
+ (if (file-port? port)
+ (number->string
+ (logior major minor))
+ "none")
+ node))))))
+ (format (current-error-port) "Computing Guix derivation for '~a'... "
+ system)
+
+ ;; Wait for a connection on SOCK and proxy build output so it can be
+ ;; processed according to the settings currently in effect (build
+ ;; traces, verbosity level, and so on).
+ (match (accept sock)
+ ((port . _)
+ (close-port sock)
+ (delete-file node)
+ (proxy port (current-build-output-port))))
+
+ ;; Now that the build output connection was closed, read the result, a
+ ;; derivation file name, from PIPE.
+ (let ((str (get-string-all pipe))
+ (status (close-pipe pipe)))
+ (match str
+ ((? eof-object?)
+ (error "build program failed" (list build status)))
+ ((? derivation-path? drv)
+ (mbegin %store-monad
+ (return (newline (current-error-port)))
+ ((store-lift add-temp-root) drv)
+ (return (read-derivation-from-file drv))))
+ ("#f"
+ ;; Unsupported PULL-VERSION.
+ (return #f))
+ ((? string? str)
+ (raise (condition
+ (&message
+ (message (format #f "You found a bug: the program '~a'
+failed to compute the derivation for Guix (version: ~s; system: ~s;
+host version: ~s; pull-version: ~s).
+Please report it by email to <~a>.~%"
+ (derivation->output-path build)
+ version system %guix-version pull-version
+ %guix-bug-report-address))))))))))))
;; This file is loaded by 'guix pull'; return it the build procedure.
build