guix - Wojtek's customized Guix

about summary refs log tree commit diff

;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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 <http://www.gnu.org/licenses/>. (define-module (build-self) #:use-module (gnu) #:use-module (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) #:export (build)) ;;; Commentary: ;;; ;;; When loaded, this module returns a monadic procedure of at least one ;;; argument: the source tree to build. It returns a derivation that ;;; builds it. ;;; ;;; This file uses modules provided by the already-installed Guix. Those ;;; modules may be arbitrarily old compared to the version we want to ;;; build. Because of that, it must rely on the smallest set of features ;;; that are likely to be provided by the (guix) and (gnu) modules, and by ;;; Guile itself, forever and ever. ;;; ;;; Code: ;;; ;;; Generating (guix config). ;;; ;;; This is copied from (guix self) because we cannot assume (guix self) is ;;; available at this point. ;;; (define %persona-variables ;; (guix config) variables that define Guix's persona. '(%guix-package-name %guix-version %guix-bug-report-address %guix-home-page-url)) (define %config-variables ;; (guix config) variables corresponding to Guix configuration. (letrec-syntax ((variables (syntax-rules () ((_) '()) ((_ variable rest ...) (cons `(variable . ,variable) (variables rest ...)))))) (variables %localstatedir %storedir %sysconfdir %system))) (define* (make-config.scm #:key gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") (home-page-url "https://guix.gnu.org")) ;; Hack so that Geiser is not confused. (define defmod 'define-module) (scheme-file "config.scm" #~(begin (#$defmod (guix config) #:export (%guix-package-name %guix-version %guix-bug-report-address %guix-home-page-url %store-directory %state-directory %store-database-directory %config-directory %libz %gzip %bzip2 %xz)) ;; XXX: Work around <http://bugs.gnu.org/15602>. (eval-when (expand load eval) #$@(map (match-lambda ((name . value) #~(define-public #$name #$value))) %config-variables) (define %store-directory (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) %storedir)) (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in ;; `nix/local.mk'. (or (getenv "GUIX_STATE_DIRECTORY") (string-append %localstatedir "/guix"))) (define %store-database-directory (or (getenv "GUIX_DATABASE_DIRECTORY") (string-append %state-directory "/db"))) (define %config-directory ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as ;; defined in `nix/local.mk'. (or (getenv "GUIX_CONFIGURATION_DIRECTORY") (string-append %sysconfdir "/guix"))) (define %guix-package-name #$package-name) (define %guix-version #$package-version) (define %guix-bug-report-address #$bug-report-address) (define %guix-home-page-url #$home-page-url) (define %gzip #+(and gzip (file-append gzip "/bin/gzip"))) (define %bzip2 #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) (define %xz #+(and xz (file-append xz "/bin/xz"))))))) ;;; ;;; 'gexp->script'. ;;; ;;; This is our own variant of 'gexp->script' with an extra #:module-path ;;; parameter, which was unavailable in (guix gexp) until commit ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.) ;;; (define (load-path-expression modules path) "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 #:module-path path))) (return (gexp (eval-when (expand load eval) (set! %load-path (cons (ungexp modules) %load-path)) (set! %load-compiled-path (cons (ungexp compiled) %load-compiled-path))))))) (define* (gexp->script name exp #:key (guile (default-guile)) (module-path %load-path)) "Return an executable script NAME that runs EXP using GUILE, with EXP's imported modules in its search path." (mlet %store-monad ((set-load-path (load-path-expression (gexp-modules exp) module-path))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) (lambda (port) ;; Note: that makes a long shebang. When the store ;; is /gnu/store, that fits within the 128-byte ;; limit imposed by Linux, but that may go beyond ;; when running tests. (format port "#!~a/bin/guile --no-auto-compile~%!#~%" (ungexp guile)) (write '(ungexp set-load-path) port) (write '(ungexp exp) port) (chmod port #o555)))) #:module-path module-path))) (define (date-version-string) "Return the current date and hour in UTC timezone, for use as a poor person's version identifier." ;; 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) (channel-metadata #f) built-in-builders) "Return a program that computes the derivation to build Guix from SOURCE. If BUILT-IN-BUILDERS is provided, it should be a list of strings and this will be used instead of the builtin builders provided by the build daemon, from within the generated build program." (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)) ;; 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) (gnu packages bootstrap)) (list source) #:select? select?)) (gexp->script "compute-guix-derivation" #~(begin (use-modules (ice-9 match)) (eval-when (expand load eval) ;; (gnu packages …) modules are going to be looked up ;; under SOURCE. (guix config) is looked up in FRONT. (match (command-line) ((_ source _ ...) (match %load-path ((front _ ...) (unless (string=? front source) ;already done? (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)) (match (command-line) ((_ 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 #:built-in-builders '#$built-in-builders) (open-connection #:built-in-builders '#$built-in-builders))) (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=> ;; 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)) 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))) built-in-builders #:allow-other-keys #:rest rest) "Return a derivation that unpacks SOURCE into STORE and compiles Scheme files." ;; Build the build program and then use it as a trampoline to build from ;; SOURCE. (mlet %store-monad ((build (build-program source version guile-version #:channel-metadata channel-metadata #:pull-version pull-version #:built-in-builders built-in-builders)) (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 ;; 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)) ;; 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 the COMPLETE output above 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 ;; Local Variables: ;; eval: (put 'with-load-path 'scheme-indent-function 1) ;; End: ;;; build-self.scm ends here