build-aux/build-self.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (build-self)
  20   #:use-module (gnu)
  21   #:use-module (guix)
  22   #:use-module (guix ui)
  23   #:use-module (guix config)
  24   #:use-module (guix modules)
  25   #:use-module (guix build-system gnu)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-19)
  28   #:use-module (srfi srfi-34)
  29   #:use-module (srfi srfi-35)
  30   #:use-module (rnrs io ports)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 popen)
  33   #:export (build))
  34
  35 ;;; Commentary:
  36 ;;;
  37 ;;; When loaded, this module returns a monadic procedure of at least one
  38 ;;; argument: the source tree to build.  It returns a derivation that
  39 ;;; builds it.
  40 ;;;
  41 ;;; This file uses modules provided by the already-installed Guix.  Those
  42 ;;; modules may be arbitrarily old compared to the version we want to
  43 ;;; build.  Because of that, it must rely on the smallest set of features
  44 ;;; that are likely to be provided by the (guix) and (gnu) modules, and by
  45 ;;; Guile itself, forever and ever.
  46 ;;;
  47 ;;; Code:
  48
  49 \f
  50 ;;;
  51 ;;; Generating (guix config).
  52 ;;;
  53 ;;; This is copied from (guix self) because we cannot assume (guix self) is
  54 ;;; available at this point.
  55 ;;;
  56
  57 (define %persona-variables
  58   ;; (guix config) variables that define Guix's persona.
  59   '(%guix-package-name
  60     %guix-version
  61     %guix-bug-report-address
  62     %guix-home-page-url))
  63
  64 (define %config-variables
  65   ;; (guix config) variables corresponding to Guix configuration.
  66   (letrec-syntax ((variables (syntax-rules ()
  67                                ((_)
  68                                 '())
  69                                ((_ variable rest ...)
  70                                 (cons `(variable . ,variable)
  71                                       (variables rest ...))))))
  72     (variables %localstatedir %storedir %sysconfdir %system)))
  73
  74 (define* (make-config.scm #:key gzip xz bzip2
  75                           (package-name "GNU Guix")
  76                           (package-version "0")
  77                           (bug-report-address "bug-guix@gnu.org")
  78                           (home-page-url "https://guix.gnu.org"))
  79
  80   ;; Hack so that Geiser is not confused.
  81   (define defmod 'define-module)
  82
  83   (scheme-file "config.scm"
  84                #~(begin
  85                    (#$defmod (guix config)
  86                      #:export (%guix-package-name
  87                                %guix-version
  88                                %guix-bug-report-address
  89                                %guix-home-page-url
  90                                %store-directory
  91                                %state-directory
  92                                %store-database-directory
  93                                %config-directory
  94                                %libz
  95                                %gzip
  96                                %bzip2
  97                                %xz))
  98
  99                    ;; XXX: Work around <http://bugs.gnu.org/15602>.
 100                    (eval-when (expand load eval)
 101                      #$@(map (match-lambda
 102                                ((name . value)
 103                                 #~(define-public #$name #$value)))
 104                              %config-variables)
 105
 106                      (define %store-directory
 107                        (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
 108                            %storedir))
 109
 110                      (define %state-directory
 111                        ;; This must match `NIX_STATE_DIR' as defined in
 112                        ;; `nix/local.mk'.
 113                        (or (getenv "GUIX_STATE_DIRECTORY")
 114                            (string-append %localstatedir "/guix")))
 115
 116                      (define %store-database-directory
 117                        (or (getenv "GUIX_DATABASE_DIRECTORY")
 118                            (string-append %state-directory "/db")))
 119
 120                      (define %config-directory
 121                        ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
 122                        ;; defined in `nix/local.mk'.
 123                        (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
 124                            (string-append %sysconfdir "/guix")))
 125
 126                      (define %guix-package-name #$package-name)
 127                      (define %guix-version #$package-version)
 128                      (define %guix-bug-report-address #$bug-report-address)
 129                      (define %guix-home-page-url #$home-page-url)
 130
 131                      (define %gzip
 132                        #+(and gzip (file-append gzip "/bin/gzip")))
 133                      (define %bzip2
 134                        #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
 135                      (define %xz
 136                        #+(and xz (file-append xz "/bin/xz")))))))
 137
 138 \f
 139 ;;;
 140 ;;; 'gexp->script'.
 141 ;;;
 142 ;;; This is our own variant of 'gexp->script' with an extra #:module-path
 143 ;;; parameter, which was unavailable in (guix gexp) until commit
 144 ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
 145 ;;;
 146
 147 (define (load-path-expression modules path)
 148   "Return as a monadic value a gexp that sets '%load-path' and
 149 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
 150 are searched for in PATH."
 151   (mlet %store-monad ((modules  (imported-modules modules
 152                                                   #:module-path path))
 153                       (compiled (compiled-modules modules
 154                                                   #:module-path path)))
 155     (return (gexp (eval-when (expand load eval)
 156                     (set! %load-path
 157                       (cons (ungexp modules) %load-path))
 158                     (set! %load-compiled-path
 159                       (cons (ungexp compiled)
 160                             %load-compiled-path)))))))
 161
 162 (define* (gexp->script name exp
 163                        #:key (guile (default-guile))
 164                        (module-path %load-path))
 165   "Return an executable script NAME that runs EXP using GUILE, with EXP's
 166 imported modules in its search path."
 167   (mlet %store-monad ((set-load-path
 168                        (load-path-expression (gexp-modules exp)
 169                                              module-path)))
 170     (gexp->derivation name
 171                       (gexp
 172                        (call-with-output-file (ungexp output)
 173                          (lambda (port)
 174                            ;; Note: that makes a long shebang.  When the store
 175                            ;; is /gnu/store, that fits within the 128-byte
 176                            ;; limit imposed by Linux, but that may go beyond
 177                            ;; when running tests.
 178                            (format port
 179                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
 180                                    (ungexp guile))
 181
 182                            (write '(ungexp set-load-path) port)
 183                            (write '(ungexp exp) port)
 184                            (chmod port #o555))))
 185                       #:module-path module-path)))
 186
 187 \f
 188 (define (date-version-string)
 189   "Return the current date and hour in UTC timezone, for use as a poor
 190 person's version identifier."
 191   ;; XXX: Replace with a Git commit id.
 192   (date->string (current-date 0) "~Y~m~d.~H"))
 193
 194 (define guile-gcrypt
 195   ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
 196   ;; August 2018.  If it has it, it's at least version 0.1.0, which is good
 197   ;; enough.  If it doesn't, specify our own package because the target Guix
 198   ;; requires it.
 199   (match (find-best-packages-by-name "guile-gcrypt" #f)
 200     (()
 201      (package
 202        (name "guile-gcrypt")
 203        (version "0.1.0")
 204        (home-page "https://notabug.org/cwebber/guile-gcrypt")
 205        (source (origin
 206                  (method url-fetch)
 207                  (uri (string-append home-page "/archive/v" version ".tar.gz"))
 208                  (sha256
 209                   (base32
 210                    "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
 211                  (file-name (string-append name "-" version ".tar.gz"))))
 212        (build-system gnu-build-system)
 213        (arguments
 214         ;; The 'bootstrap' phase appeared in 'core-updates', which was merged
 215         ;; into 'master' ca. June 2018.
 216         '(#:phases (modify-phases %standard-phases
 217                      (delete 'bootstrap)
 218                      (add-before 'configure 'bootstrap
 219                        (lambda _
 220                          (unless (zero? (system* "autoreconf" "-vfi"))
 221                            (error "autoreconf failed"))
 222                          #t)))))
 223        (native-inputs
 224         `(("pkg-config" ,(specification->package "pkg-config"))
 225           ("autoconf" ,(specification->package "autoconf"))
 226           ("automake" ,(specification->package "automake"))
 227           ("texinfo" ,(specification->package "texinfo"))))
 228        (inputs
 229         `(("guile" ,(specification->package "guile"))
 230           ("libgcrypt" ,(specification->package "libgcrypt"))))
 231        (synopsis "Cryptography library for Guile using Libgcrypt")
 232        (description
 233         "Guile-Gcrypt provides a Guile 2.x interface to a subset of the
 234 GNU Libgcrypt crytographic library.  It provides modules for cryptographic
 235 hash functions, message authentication codes (MAC), public-key cryptography,
 236 strong randomness, and more.  It is implemented using the foreign function
 237 interface (FFI) of Guile.")
 238        (license #f)))                             ;license:gpl3+
 239     ((package . _)
 240      package)))
 241
 242 (define* (build-program source version
 243                         #:optional (guile-version (effective-version))
 244                         #:key (pull-version 0) (channel-metadata #f))
 245   "Return a program that computes the derivation to build Guix from SOURCE."
 246   (define select?
 247     ;; Select every module but (guix config) and non-Guix modules.
 248     ;; Also exclude (guix channels): it is autoloaded by (guix describe), but
 249     ;; only for peripheral functionality.
 250     (match-lambda
 251       (('guix 'config) #f)
 252       (('guix 'channels) #f)
 253       (('guix 'build 'download) #f)             ;autoloaded by (guix download)
 254       (('guix _ ...)   #t)
 255       (('gnu _ ...)    #t)
 256       (_               #f)))
 257
 258   (define fake-gcrypt-hash
 259     ;; Fake (gcrypt hash) module; see below.
 260     (scheme-file "hash.scm"
 261                  #~(define-module (gcrypt hash)
 262                      #:export (sha1 sha256))))
 263
 264   (define fake-git
 265     (scheme-file "git.scm" #~(define-module (git))))
 266
 267   (with-imported-modules `(((guix config)
 268                             => ,(make-config.scm))
 269
 270                            ;; To avoid relying on 'with-extensions', which was
 271                            ;; introduced in 0.15.0, provide a fake (gcrypt
 272                            ;; hash) just so that we can build modules, and
 273                            ;; adjust %LOAD-PATH later on.
 274                            ((gcrypt hash) => ,fake-gcrypt-hash)
 275
 276                            ;; (guix git-download) depends on (git) but only
 277                            ;; for peripheral functionality.  Provide a dummy
 278                            ;; (git) to placate it.
 279                            ((git) => ,fake-git)
 280
 281                            ,@(source-module-closure `((guix store)
 282                                                       (guix self)
 283                                                       (guix derivations)
 284                                                       (gnu packages bootstrap))
 285                                                     (list source)
 286                                                     #:select? select?))
 287     (gexp->script "compute-guix-derivation"
 288                   #~(begin
 289                       (use-modules (ice-9 match))
 290
 291                       (eval-when (expand load eval)
 292                         ;; (gnu packages …) modules are going to be looked up
 293                         ;; under SOURCE.  (guix config) is looked up in FRONT.
 294                         (match (command-line)
 295                           ((_ source _ ...)
 296                            (match %load-path
 297                              ((front _ ...)
 298                               (unless (string=? front source) ;already done?
 299                                 (set! %load-path
 300                                   (list source
 301                                         (string-append #$guile-gcrypt
 302                                                        "/share/guile/site/"
 303                                                        (effective-version))
 304                                         front)))))))
 305
 306                         ;; Only load Guile-Gcrypt, our own modules, or those
 307                         ;; of Guile.
 308                         (set! %load-compiled-path
 309                           (cons (string-append #$guile-gcrypt "/lib/guile/"
 310                                                (effective-version)
 311                                                "/site-ccache")
 312                                 %load-compiled-path))
 313
 314                         ;; Disable position recording to save time and space
 315                         ;; when loading the package modules.
 316                         (read-disable 'positions))
 317
 318                       (use-modules (guix store)
 319                                    (guix self)
 320                                    (guix derivations)
 321                                    (srfi srfi-1))
 322
 323                       (match (command-line)
 324                         ((_ source system version protocol-version
 325                             build-output)
 326                          ;; The current input port normally wraps a file
 327                          ;; descriptor connected to the daemon, or it is
 328                          ;; connected to /dev/null.  In the former case, reuse
 329                          ;; the connection such that we inherit build options
 330                          ;; such as substitute URLs and so on; in the latter
 331                          ;; case, attempt to open a new connection.
 332                          (let* ((proto (string->number protocol-version))
 333                                 (store (if (integer? proto)
 334                                            (port->connection (duplicate-port
 335                                                               (current-input-port)
 336                                                               "w+0")
 337                                                              #:version proto)
 338                                            (open-connection)))
 339                                 (sock  (socket AF_UNIX SOCK_STREAM 0)))
 340                            ;; Connect to BUILD-OUTPUT and send it the raw
 341                            ;; build output.
 342                            (connect sock AF_UNIX build-output)
 343
 344                            (display
 345                             (and=>
 346                              ;; Silence autoload warnings and the likes.
 347                              (parameterize ((current-warning-port
 348                                              (%make-void-port "w"))
 349                                             (current-build-output-port sock))
 350                                (run-with-store store
 351                                  (guix-derivation source version
 352                                                   #$guile-version
 353                                                   #:channel-metadata
 354                                                   '#$channel-metadata
 355                                                   #:pull-version
 356                                                   #$pull-version)
 357                                  #:system system))
 358                              derivation-file-name))))))
 359                   #:module-path (list source))))
 360
 361 (define (proxy input output)
 362   "Dump the contents of INPUT to OUTPUT until EOF is reached on INPUT.
 363 Display a spinner when nothing happens."
 364   (define spin
 365     (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
 366
 367   (setvbuf input 'block 16384)
 368   (let loop ((spin spin))
 369     (match (select (list input) '() '() 1)
 370       ((() () ())
 371        (when (isatty? (current-error-port))
 372          (display (string-append "\b" (car spin))
 373                   (current-error-port))
 374          (force-output (current-error-port)))
 375        (loop (cdr spin)))
 376       (((_) () ())
 377        ;; Read from INPUT as much as can be read without blocking.
 378        (let ((bv (get-bytevector-some input)))
 379          (unless (eof-object? bv)
 380            (put-bytevector output bv)
 381            (loop spin)))))))
 382
 383 (define (call-with-clean-environment thunk)
 384   (let ((env (environ)))
 385     (dynamic-wind
 386       (lambda ()
 387         (environ '()))
 388       thunk
 389       (lambda ()
 390         (environ env)))))
 391
 392 (define-syntax-rule (with-clean-environment exp ...)
 393   "Evaluate EXP in a context where zero environment variables are defined."
 394   (call-with-clean-environment (lambda () exp ...)))
 395
 396 ;; The procedure below is our return value.
 397 (define* (build source
 398                 #:key verbose?
 399                 (version (date-version-string)) channel-metadata
 400                 system
 401                 (pull-version 0)
 402
 403                 ;; For the standalone Guix, default to Guile 3.0.  For old
 404                 ;; versions of 'guix pull' (pre-0.15.0), we have to use the
 405                 ;; same Guile as the current one.
 406                 (guile-version (if (> pull-version 0)
 407                                    "3.0"
 408                                    (effective-version)))
 409
 410                 #:allow-other-keys
 411                 #:rest rest)
 412   "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
 413 files."
 414   ;; Build the build program and then use it as a trampoline to build from
 415   ;; SOURCE.
 416   (mlet %store-monad ((build  (build-program source version guile-version
 417                                              #:channel-metadata channel-metadata
 418                                              #:pull-version pull-version))
 419                       (system (if system (return system) (current-system)))
 420                       (home -> (getenv "HOME"))
 421
 422                       ;; Note: Use the deprecated names here because the
 423                       ;; caller might be Guix <= 0.16.0.
 424                       (port   ((store-lift nix-server-socket)))
 425                       (major  ((store-lift nix-server-major-version)))
 426                       (minor  ((store-lift nix-server-minor-version))))
 427     (mbegin %store-monad
 428       ;; Before 'with-build-handler' was implemented and used, we had to
 429       ;; explicitly call 'show-what-to-build*'.
 430       (munless (module-defined? (resolve-module '(guix store))
 431                                 'with-build-handler)
 432         (show-what-to-build* (list build)))
 433       (built-derivations (list build))
 434
 435       ;; Use the port beneath the current store as the stdin of BUILD.  This
 436       ;; way, we know 'open-pipe*' will not close it on 'exec'.  If PORT is
 437       ;; not a file port (e.g., it's an SSH channel), then the subprocess's
 438       ;; stdin will actually be /dev/null.
 439       (let* ((sock   (socket AF_UNIX SOCK_STREAM 0))
 440              (node   (let ((file (string-append (or (getenv "TMPDIR") "/tmp")
 441                                                 "/guix-build-output-"
 442                                                 (number->string (getpid)))))
 443                        (bind sock AF_UNIX file)
 444                        (listen sock 1)
 445                        file))
 446              (pipe   (with-input-from-port port
 447                        (lambda ()
 448                          ;; Make sure BUILD is not influenced by
 449                          ;; $GUILE_LOAD_PATH & co.
 450                          (with-clean-environment
 451                           (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
 452                           (setenv "COLUMNS" "120") ;show wider backtraces
 453                           (when home
 454                             ;; Inherit HOME so that 'xdg-directory' works.
 455                             (setenv "HOME" home))
 456                           (open-pipe* OPEN_READ
 457                                       (derivation->output-path build)
 458                                       source system version
 459                                       (if (file-port? port)
 460                                           (number->string
 461                                            (logior major minor))
 462                                           "none")
 463                                       node))))))
 464         (format (current-error-port) "Computing Guix derivation for '~a'...  "
 465                 system)
 466
 467         ;; Wait for a connection on SOCK and proxy build output so it can be
 468         ;; processed according to the settings currently in effect (build
 469         ;; traces, verbosity level, and so on).
 470         (match (accept sock)
 471           ((port . _)
 472            (close-port sock)
 473            (delete-file node)
 474            (proxy port (current-build-output-port))))
 475
 476         ;; Now that the build output connection was closed, read the result, a
 477         ;; derivation file name, from PIPE.
 478         (let ((str    (get-string-all pipe))
 479               (status (close-pipe pipe)))
 480           (match str
 481             ((? eof-object?)
 482              (error "build program failed" (list build status)))
 483             ((? derivation-path? drv)
 484              (mbegin %store-monad
 485                (return (newline (current-error-port)))
 486                ((store-lift add-temp-root) drv)
 487                (return (read-derivation-from-file drv))))
 488             ("#f"
 489              ;; Unsupported PULL-VERSION.
 490              (return #f))
 491             ((? string? str)
 492              (raise (condition
 493                      (&message
 494                       (message (format #f "You found a bug: the program '~a'
 495 failed to compute the derivation for Guix (version: ~s; system: ~s;
 496 host version: ~s; pull-version: ~s).
 497 Please report the COMPLETE output above by email to <~a>.~%"
 498                                        (derivation->output-path build)
 499                                        version system %guix-version pull-version
 500                                        %guix-bug-report-address))))))))))))
 501
 502 ;; This file is loaded by 'guix pull'; return it the build procedure.
 503 build
 504
 505 ;; Local Variables:
 506 ;; eval: (put 'with-load-path 'scheme-indent-function 1)
 507 ;; End:
 508
 509 ;;; build-self.scm ends here