| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2014, 2016, 2017, 2018, 2019, 2020 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)) |
| 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 | (match-lambda |
| 249 | (('guix 'config) #f) |
| 250 | (('guix _ ...) #t) |
| 251 | (('gnu _ ...) #t) |
| 252 | (_ #f))) |
| 253 | |
| 254 | (define fake-gcrypt-hash |
| 255 | ;; Fake (gcrypt hash) module; see below. |
| 256 | (scheme-file "hash.scm" |
| 257 | #~(define-module (gcrypt hash) |
| 258 | #:export (sha1 sha256)))) |
| 259 | |
| 260 | (define fake-git |
| 261 | (scheme-file "git.scm" #~(define-module (git)))) |
| 262 | |
| 263 | (with-imported-modules `(((guix config) |
| 264 | => ,(make-config.scm)) |
| 265 | |
| 266 | ;; To avoid relying on 'with-extensions', which was |
| 267 | ;; introduced in 0.15.0, provide a fake (gcrypt |
| 268 | ;; hash) just so that we can build modules, and |
| 269 | ;; adjust %LOAD-PATH later on. |
| 270 | ((gcrypt hash) => ,fake-gcrypt-hash) |
| 271 | |
| 272 | ;; (guix git-download) depends on (git) but only |
| 273 | ;; for peripheral functionality. Provide a dummy |
| 274 | ;; (git) to placate it. |
| 275 | ((git) => ,fake-git) |
| 276 | |
| 277 | ,@(source-module-closure `((guix store) |
| 278 | (guix self) |
| 279 | (guix derivations) |
| 280 | (gnu packages bootstrap)) |
| 281 | (list source) |
| 282 | #:select? select?)) |
| 283 | (gexp->script "compute-guix-derivation" |
| 284 | #~(begin |
| 285 | (use-modules (ice-9 match) |
| 286 | (ice-9 threads)) |
| 287 | |
| 288 | (eval-when (expand load eval) |
| 289 | ;; (gnu packages …) modules are going to be looked up |
| 290 | ;; under SOURCE. (guix config) is looked up in FRONT. |
| 291 | (match (command-line) |
| 292 | ((_ source _ ...) |
| 293 | (match %load-path |
| 294 | ((front _ ...) |
| 295 | (unless (string=? front source) ;already done? |
| 296 | (set! %load-path |
| 297 | (list source |
| 298 | (string-append #$guile-gcrypt |
| 299 | "/share/guile/site/" |
| 300 | (effective-version)) |
| 301 | front))))))) |
| 302 | |
| 303 | ;; Only load Guile-Gcrypt, our own modules, or those |
| 304 | ;; of Guile. |
| 305 | (set! %load-compiled-path |
| 306 | (cons (string-append #$guile-gcrypt "/lib/guile/" |
| 307 | (effective-version) |
| 308 | "/site-ccache") |
| 309 | %load-compiled-path)) |
| 310 | |
| 311 | ;; Disable position recording to save time and space |
| 312 | ;; when loading the package modules. |
| 313 | (read-disable 'positions)) |
| 314 | |
| 315 | (use-modules (guix store) |
| 316 | (guix self) |
| 317 | (guix derivations) |
| 318 | (srfi srfi-1)) |
| 319 | |
| 320 | (define (spin system) |
| 321 | (define spin |
| 322 | (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/")) |
| 323 | |
| 324 | (format (current-error-port) |
| 325 | "Computing Guix derivation for '~a'... " |
| 326 | system) |
| 327 | (when (isatty? (current-error-port)) |
| 328 | (let loop ((spin spin)) |
| 329 | (display (string-append "\b" (car spin)) |
| 330 | (current-error-port)) |
| 331 | (force-output (current-error-port)) |
| 332 | (sleep 1) |
| 333 | (loop (cdr spin))))) |
| 334 | |
| 335 | (match (command-line) |
| 336 | ((_ source system version protocol-version) |
| 337 | ;; The current input port normally wraps a file |
| 338 | ;; descriptor connected to the daemon, or it is |
| 339 | ;; connected to /dev/null. In the former case, reuse |
| 340 | ;; the connection such that we inherit build options |
| 341 | ;; such as substitute URLs and so on; in the latter |
| 342 | ;; case, attempt to open a new connection. |
| 343 | (let* ((proto (string->number protocol-version)) |
| 344 | (store (if (integer? proto) |
| 345 | (port->connection (duplicate-port |
| 346 | (current-input-port) |
| 347 | "w+0") |
| 348 | #:version proto) |
| 349 | (open-connection)))) |
| 350 | (call-with-new-thread |
| 351 | (lambda () |
| 352 | (spin system))) |
| 353 | |
| 354 | (display |
| 355 | (and=> |
| 356 | (run-with-store store |
| 357 | (guix-derivation source version |
| 358 | #$guile-version |
| 359 | #:pull-version |
| 360 | #$pull-version) |
| 361 | #:system system) |
| 362 | derivation-file-name)))))) |
| 363 | #:module-path (list source)))) |
| 364 | |
| 365 | (define (call-with-clean-environment thunk) |
| 366 | (let ((env (environ))) |
| 367 | (dynamic-wind |
| 368 | (lambda () |
| 369 | (environ '())) |
| 370 | thunk |
| 371 | (lambda () |
| 372 | (environ env))))) |
| 373 | |
| 374 | (define-syntax-rule (with-clean-environment exp ...) |
| 375 | "Evaluate EXP in a context where zero environment variables are defined." |
| 376 | (call-with-clean-environment (lambda () exp ...))) |
| 377 | |
| 378 | ;; The procedure below is our return value. |
| 379 | (define* (build source |
| 380 | #:key verbose? (version (date-version-string)) system |
| 381 | (pull-version 0) |
| 382 | |
| 383 | ;; For the standalone Guix, default to Guile 3.0. For old |
| 384 | ;; versions of 'guix pull' (pre-0.15.0), we have to use the |
| 385 | ;; same Guile as the current one. |
| 386 | (guile-version (if (> pull-version 0) |
| 387 | "3.0" |
| 388 | (effective-version))) |
| 389 | |
| 390 | #:allow-other-keys |
| 391 | #:rest rest) |
| 392 | "Return a derivation that unpacks SOURCE into STORE and compiles Scheme |
| 393 | files." |
| 394 | ;; Build the build program and then use it as a trampoline to build from |
| 395 | ;; SOURCE. |
| 396 | (mlet %store-monad ((build (build-program source version guile-version |
| 397 | #:pull-version pull-version)) |
| 398 | (system (if system (return system) (current-system))) |
| 399 | (home -> (getenv "HOME")) |
| 400 | |
| 401 | ;; Note: Use the deprecated names here because the |
| 402 | ;; caller might be Guix <= 0.16.0. |
| 403 | (port ((store-lift nix-server-socket))) |
| 404 | (major ((store-lift nix-server-major-version))) |
| 405 | (minor ((store-lift nix-server-minor-version)))) |
| 406 | (mbegin %store-monad |
| 407 | ;; Before 'with-build-handler' was implemented and used, we had to |
| 408 | ;; explicitly call 'show-what-to-build*'. |
| 409 | (munless (module-defined? (resolve-module '(guix store)) |
| 410 | 'with-build-handler) |
| 411 | (show-what-to-build* (list build))) |
| 412 | (built-derivations (list build)) |
| 413 | |
| 414 | ;; Use the port beneath the current store as the stdin of BUILD. This |
| 415 | ;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is |
| 416 | ;; not a file port (e.g., it's an SSH channel), then the subprocess's |
| 417 | ;; stdin will actually be /dev/null. |
| 418 | (let* ((pipe (with-input-from-port port |
| 419 | (lambda () |
| 420 | ;; Make sure BUILD is not influenced by |
| 421 | ;; $GUILE_LOAD_PATH & co. |
| 422 | (with-clean-environment |
| 423 | (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive |
| 424 | (setenv "COLUMNS" "120") ;show wider backtraces |
| 425 | (when home |
| 426 | ;; Inherit HOME so that 'xdg-directory' works. |
| 427 | (setenv "HOME" home)) |
| 428 | (open-pipe* OPEN_READ |
| 429 | (derivation->output-path build) |
| 430 | source system version |
| 431 | (if (file-port? port) |
| 432 | (number->string |
| 433 | (logior major minor)) |
| 434 | "none")))))) |
| 435 | (str (get-string-all pipe)) |
| 436 | (status (close-pipe pipe))) |
| 437 | (match str |
| 438 | ((? eof-object?) |
| 439 | (error "build program failed" (list build status))) |
| 440 | ((? derivation-path? drv) |
| 441 | (mbegin %store-monad |
| 442 | (return (newline (current-error-port))) |
| 443 | ((store-lift add-temp-root) drv) |
| 444 | (return (read-derivation-from-file drv)))) |
| 445 | ("#f" |
| 446 | ;; Unsupported PULL-VERSION. |
| 447 | (return #f)) |
| 448 | ((? string? str) |
| 449 | (raise (condition |
| 450 | (&message |
| 451 | (message (format #f "You found a bug: the program '~a' |
| 452 | failed to compute the derivation for Guix (version: ~s; system: ~s; |
| 453 | host version: ~s; pull-version: ~s). |
| 454 | Please report it by email to <~a>.~%" |
| 455 | (derivation->output-path build) |
| 456 | version system %guix-version pull-version |
| 457 | %guix-bug-report-address))))))))))) |
| 458 | |
| 459 | ;; This file is loaded by 'guix pull'; return it the build procedure. |
| 460 | build |
| 461 | |
| 462 | ;; Local Variables: |
| 463 | ;; eval: (put 'with-load-path 'scheme-indent-function 1) |
| 464 | ;; End: |
| 465 | |
| 466 | ;;; build-self.scm ends here |