;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Chris Marusich ;;; ;;; 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 (gnu build marionette) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-mod
aboutsummaryrefslogtreecommitdiff
;;; 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 spac