guix/self.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix self)
  21   #:use-module (guix config)
  22   #:use-module (guix i18n)
  23   #:use-module (guix modules)
  24   #:use-module (guix gexp)
  25   #:use-module (guix store)
  26   #:use-module (guix monads)
  27   #:use-module (guix discovery)
  28   #:use-module (guix packages)
  29   #:use-module (guix sets)
  30   #:use-module (guix modules)
  31   #:use-module ((guix utils) #:select (version-major+minor))
  32   #:use-module ((guix build utils) #:select (find-files))
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-9)
  35   #:use-module (srfi srfi-35)
  36   #:use-module (ice-9 match)
  37   #:export (make-config.scm
  38             whole-package                     ;for internal use in 'guix pull'
  39             compiled-guix
  40             guix-derivation))
  41
  42 \f
  43 ;;;
  44 ;;; Dependency handling.
  45 ;;;
  46
  47 (define specification->package
  48   ;; Use our own variant of that procedure because that of (gnu packages)
  49   ;; would traverse all the .scm files, which is wasteful.
  50   (let ((ref (lambda (module variable)
  51                (module-ref (resolve-interface module) variable))))
  52     (match-lambda
  53       ("guile"      (ref '(gnu packages guile) 'guile-3.0-latest))
  54       ("guile-avahi" (ref '(gnu packages guile-xyz) 'guile-avahi))
  55       ("guile-json" (ref '(gnu packages guile) 'guile-json-4))
  56       ("guile-ssh"  (ref '(gnu packages ssh)   'guile-ssh))
  57       ("guile-git"  (ref '(gnu packages guile) 'guile-git))
  58       ("guile-semver"  (ref '(gnu packages guile-xyz) 'guile-semver))
  59       ("guile-lib"  (ref '(gnu packages guile-xyz) 'guile-lib))
  60       ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
  61       ("guile-zlib" (ref '(gnu packages guile) 'guile-zlib))
  62       ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib))
  63       ("guile-zstd" (ref '(gnu packages guile) 'guile-zstd))
  64       ("guile-gcrypt"  (ref '(gnu packages gnupg) 'guile-gcrypt))
  65       ("gnutls"     (ref '(gnu packages tls) 'gnutls))
  66       ("disarchive" (ref '(gnu packages backup) 'disarchive))
  67       ("gzip"       (ref '(gnu packages compression) 'gzip))
  68       ("bzip2"      (ref '(gnu packages compression) 'bzip2))
  69       ("xz"         (ref '(gnu packages compression) 'xz))
  70       ("po4a"       (ref '(gnu packages gettext) 'po4a))
  71       ("gettext"       (ref '(gnu packages gettext) 'gettext-minimal))
  72       ("gcc-toolchain" (ref '(gnu packages commencement) 'gcc-toolchain))
  73       (_            #f))))                        ;no such package
  74
  75 \f
  76 ;;;
  77 ;;; Derivations.
  78 ;;;
  79
  80 ;; Node in a DAG of build tasks.  Each node maps to a derivation, but it's
  81 ;; easier to express things this way.
  82 (define-record-type <node>
  83   (node name modules source dependencies compiled)
  84   node?
  85   (name          node-name)                       ;string
  86   (modules       node-modules)                    ;list of module names
  87   (source        node-source)                     ;list of source files
  88   (dependencies  node-dependencies)               ;list of nodes
  89   (compiled      node-compiled))                  ;node -> lowerable object
  90
  91 ;; File mappings are essentially an alist as passed to 'imported-files'.
  92 (define-record-type <file-mapping>
  93   (file-mapping name alist)
  94   file-mapping?
  95   (name  file-mapping-name)
  96   (alist file-mapping-alist))
  97
  98 (define-gexp-compiler (file-mapping-compiler (mapping <file-mapping>)
  99                                              system target)
 100   ;; Here we use 'imported-files', which can arrange to directly import all
 101   ;; the files instead of creating a derivation, when possible.
 102   (imported-files (map (match-lambda
 103                          ((destination (? local-file? file))
 104                           (cons destination
 105                                 (local-file-absolute-file-name file)))
 106                          ((destination source)
 107                           (cons destination source))) ;silliness
 108                        (file-mapping-alist mapping))
 109                   #:name (file-mapping-name mapping)
 110                   #:system system))
 111
 112 (define (node-source+compiled node)
 113   "Return a \"bundle\" containing both the source code and object files for
 114 NODE's modules, under their FHS directories: share/guile/site and lib/guile."
 115   (define build
 116     (with-imported-modules '((guix build utils))
 117       #~(begin
 118           (use-modules (guix build utils))
 119
 120           (define source
 121             (string-append #$output "/share/guile/site/"
 122                            (effective-version)))
 123
 124           (define object
 125             (string-append #$output "/lib/guile/" (effective-version)
 126                            "/site-ccache"))
 127
 128           (mkdir-p (dirname source))
 129           (symlink #$(node-source node) source)
 130           (mkdir-p (dirname object))
 131           (symlink #$(node-compiled node) object))))
 132
 133   (computed-file (string-append (node-name node) "-modules")
 134                  build
 135                  #:options '(#:local-build? #t
 136
 137                              ;; "Building" it locally is faster.
 138                              #:substitutable? #f)))
 139
 140 (define (node-fold proc init nodes)
 141   (let loop ((nodes nodes)
 142              (visited (setq))
 143              (result init))
 144     (match nodes
 145       (() result)
 146       ((head tail ...)
 147        (if (set-contains? visited head)
 148            (loop tail visited result)
 149            (loop tail (set-insert head visited)
 150                  (proc head result)))))))
 151
 152 (define (node-modules/recursive nodes)
 153   (node-fold (lambda (node modules)
 154                (append (node-modules node) modules))
 155              '()
 156              nodes))
 157
 158 (define* (closure modules #:optional (except '()))
 159   (source-module-closure modules
 160                          #:select?
 161                          (match-lambda
 162                            (('guix 'config)
 163                             #f)
 164                            ((and module
 165                                  (or ('guix _ ...) ('gnu _ ...)))
 166                             (not (member module except)))
 167                            (rest #f))))
 168
 169 (define module->import
 170   ;; Return a file-name/file-like object pair for the specified module and
 171   ;; suitable for 'imported-files'.
 172   (match-lambda
 173     ((module '=> thing)
 174      (let ((file (module-name->file-name module)))
 175        (list file thing)))
 176     (module
 177         (let ((file (module-name->file-name module)))
 178           (list file
 179                 (local-file (search-path %load-path file)))))))
 180
 181 (define* (scheme-node name modules #:optional (dependencies '())
 182                       #:key (extra-modules '()) (extra-files '())
 183                       (extensions '())
 184                       parallel? guile-for-build)
 185   "Return a node that builds the given Scheme MODULES, and depends on
 186 DEPENDENCIES (a list of nodes).  EXTRA-MODULES is a list of additional modules
 187 added to the source, and EXTRA-FILES is a list of additional files.
 188 EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that
 189 must be present in the search path."
 190   (let* ((modules (append extra-modules
 191                           (closure modules
 192                                    (node-modules/recursive dependencies))))
 193          (module-files (map module->import modules))
 194          (source (file-mapping (string-append name "-source")
 195                                (append module-files extra-files))))
 196     (node name modules source dependencies
 197           (compiled-modules name source
 198                             (map car module-files)
 199                             (map node-source dependencies)
 200                             (map node-compiled dependencies)
 201                             #:extensions extensions
 202                             #:parallel? parallel?
 203                             #:guile-for-build guile-for-build))))
 204
 205 (define (file-imports directory sub-directory pred)
 206   "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY.  Return a
 207 list of file-name/file-like objects suitable as inputs to 'imported-files'."
 208   (map (lambda (file)
 209          (list (string-drop file (+ 1 (string-length directory)))
 210                (local-file file #:recursive? #t)))
 211        (find-files (string-append directory "/" sub-directory) pred)))
 212
 213 (define* (file-append* item file #:key (recursive? #t))
 214   "Return FILE within ITEM, which may be a file name or a file-like object.
 215 When ITEM is a plain file name (a string), simply return a 'local-file'
 216 record with the new file name."
 217   (match item
 218     ((? string?)
 219      ;; This is the optimal case: we return a new "source".  Thus, a
 220      ;; derivation that depends on this sub-directory does not depend on ITEM
 221      ;; itself.
 222      (local-file (string-append item "/" file)
 223                  #:recursive? recursive?))
 224     ((? local-file? base)
 225      ;; Likewise, but with a <local-file>.
 226      (if (local-file-recursive? base)
 227          (local-file (string-append (local-file-absolute-file-name base)
 228                                     "/" file)
 229                      (basename file)
 230                      #:recursive? recursive?
 231                      #:select? (local-file-select? base))
 232          (file-append base file)))
 233     (_
 234      ;; In this case, anything that refers to the result also depends on ITEM,
 235      ;; which isn't great.
 236      (file-append item "/" file))))
 237
 238 (define* (locale-data source domain
 239                       #:optional (directory domain))
 240   "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to
 241 DOMAIN, a gettext domain."
 242   (define gettext
 243     (module-ref (resolve-interface '(gnu packages gettext))
 244                 'gettext-minimal))
 245
 246   (define build
 247     (with-imported-modules '((guix build utils))
 248       #~(begin
 249           (use-modules (guix build utils)
 250                        (srfi srfi-26)
 251                        (ice-9 match) (ice-9 ftw))
 252
 253           (define po-directory
 254             #+(file-append* source (string-append "po/" directory)))
 255
 256           (define (compile language)
 257             (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/"
 258                                       #$domain ".mo")))
 259               (mkdir-p (dirname gmo))
 260               (invoke #+(file-append gettext "/bin/msgfmt")
 261                       "-c" "--statistics" "--verbose"
 262                       "-o" gmo
 263                       (string-append po-directory "/" language ".po"))))
 264
 265           (define (linguas)
 266             ;; Return the list of languages.  Note: don't read 'LINGUAS'
 267             ;; because it contains things like 'en@boldquot' that do not have
 268             ;; a corresponding .po file.
 269             (map (cut basename <> ".po")
 270                  (scandir po-directory
 271                           (cut string-suffix? ".po" <>))))
 272
 273           (for-each compile (linguas)))))
 274
 275   (computed-file (string-append "guix-locale-" domain)
 276                  build))
 277
 278 (define (translate-texi-manuals source)
 279   "Return the translated texinfo manuals built from SOURCE."
 280   (define po4a
 281     (specification->package "po4a"))
 282
 283   (define gettext
 284     (specification->package "gettext"))
 285
 286   (define glibc-utf8-locales
 287     (module-ref (resolve-interface '(gnu packages base))
 288                 'glibc-utf8-locales))
 289
 290   (define documentation
 291     (file-append* source "doc"))
 292
 293   (define documentation-po
 294     (file-append* source "po/doc"))
 295
 296   (define build
 297     (with-imported-modules '((guix build utils) (guix build po))
 298       #~(begin
 299           (use-modules (guix build utils) (guix build po)
 300                        (ice-9 match) (ice-9 regex) (ice-9 textual-ports)
 301                        (ice-9 vlist) (ice-9 threads)
 302                        (srfi srfi-1))
 303
 304           (define (translate-tmp-texi po source output)
 305             "Translate Texinfo file SOURCE using messages from PO, and write
 306 the result to OUTPUT."
 307             (invoke #+(file-append po4a "/bin/po4a-translate")
 308               "-M" "UTF-8" "-L" "UTF-8" "-k" "0" "-f" "texinfo"
 309               "-m" source "-p" po "-l" output))
 310
 311           (define (canonicalize-whitespace str)
 312             ;; Change whitespace (newlines, etc.) in STR to #\space.
 313             (string-map (lambda (chr)
 314                           (if (char-set-contains? char-set:whitespace chr)
 315                               #\space
 316                               chr))
 317                         str))
 318
 319           (define xref-regexp
 320             ;; Texinfo cross-reference regexp.
 321             (make-regexp "@(px|x)?ref\\{([^,}]+)"))
 322
 323           (define (translate-cross-references texi translations)
 324             ;; Translate the cross-references that appear in TEXI, a Texinfo
 325             ;; file, using the msgid/msgstr pairs from TRANSLATIONS.
 326             (define content
 327               (call-with-input-file texi get-string-all))
 328
 329             (define matches
 330               (list-matches xref-regexp content))
 331
 332             (define translation-map
 333               (fold (match-lambda*
 334                       (((msgid . str) result)
 335                        (vhash-cons msgid str result)))
 336                     vlist-null
 337                     translations))
 338
 339             (define translated
 340               ;; Iterate over MATCHES and replace cross-references with their
 341               ;; translation found in TRANSLATION-MAP.  (We can't use
 342               ;; 'substitute*' because matches can span multiple lines.)
 343               (let loop ((matches matches)
 344                          (offset 0)
 345                          (result '()))
 346                 (match matches
 347                   (()
 348                    (string-concatenate-reverse
 349                     (cons (string-drop content offset) result)))
 350                   ((head . tail)
 351                    (let ((prefix (match:substring head 1))
 352                          (ref    (canonicalize-whitespace (match:substring head 2))))
 353                      (define translated
 354                        (string-append "@" (or prefix "")
 355                                       "ref{"
 356                                       (match (vhash-assoc ref translation-map)
 357                                         (#f ref)
 358                                         ((_ . str) str))))
 359
 360                      (loop tail
 361                            (match:end head)
 362                            (append (list translated
 363                                          (string-take
 364                                           (string-drop content offset)
 365                                           (- (match:start head) offset)))
 366                                    result)))))))
 367
 368             (format (current-error-port)
 369                     "translated ~a cross-references in '~a'~%"
 370                     (length matches) texi)
 371             (call-with-output-file texi
 372               (lambda (port)
 373                 (display translated port))))
 374
 375           (define* (translate-texi prefix po lang
 376                                    #:key (extras '()))
 377             "Translate the manual for one language LANG using the PO file.
 378 PREFIX must be the prefix of the manual, 'guix' or 'guix-cookbook'.  EXTRAS is
 379 a list of extra files, such as '(\"contributing\")."
 380             (let ((translations (call-with-input-file po read-po-file)))
 381               (for-each (lambda (file)
 382                           (translate-tmp-texi po (string-append file ".texi")
 383                                               (string-append file "." lang
 384                                                              ".texi.tmp")))
 385                         (cons prefix extras))
 386
 387               (for-each (lambda (file)
 388                           (let* ((texi (string-append file "." lang ".texi"))
 389                                  (tmp  (string-append texi ".tmp")))
 390                             (copy-file tmp texi)
 391                             (translate-cross-references texi
 392                                                         translations)))
 393                         (cons prefix extras))))
 394
 395           (define (available-translations directory domain)
 396             ;; Return the list of available translations under DIRECTORY for
 397             ;; DOMAIN, a gettext domain such as "guix-manual".  The result is
 398             ;; a list of language/PO file pairs.
 399             (filter-map (lambda (po)
 400                           (let ((base (basename po)))
 401                             (and (string-prefix? (string-append domain ".")
 402                                                  base)
 403                                  (match (string-split base #\.)
 404                                    ((_ ... lang "po")
 405                                     (cons lang po))))))
 406                         (find-files directory
 407                                     "\\.[a-z]{2}(_[A-Z]{2})?\\.po$")))
 408
 409           (define parallel-jobs
 410             ;; Limit thread creation by 'n-par-for-each'.  Going beyond can
 411             ;; lead libgc 8.0.4 to abort with:
 412             ;; mmap(PROT_NONE) failed
 413             (min (parallel-job-count) 4))
 414
 415           (mkdir #$output)
 416           (copy-recursively #$documentation "."
 417                             #:log (%make-void-port "w"))
 418
 419           (for-each
 420             (lambda (file)
 421               (copy-file file (basename file)))
 422             (find-files #$documentation-po ".*.po$"))
 423
 424           (setenv "GUIX_LOCPATH"
 425                   #+(file-append glibc-utf8-locales "/lib/locale"))
 426           (setenv "PATH" #+(file-append gettext "/bin"))
 427           (setenv "LC_ALL" "en_US.UTF-8")
 428           (setlocale LC_ALL "en_US.UTF-8")
 429
 430           (n-par-for-each parallel-jobs
 431                           (match-lambda
 432                             ((language . po)
 433                              (translate-texi "guix" po language
 434                                              #:extras '("contributing"))))
 435                           (available-translations "." "guix-manual"))
 436
 437           (n-par-for-each parallel-jobs
 438                           (match-lambda
 439                             ((language . po)
 440                              (translate-texi "guix-cookbook" po language)))
 441                           (available-translations "." "guix-cookbook"))
 442
 443           (for-each (lambda (file)
 444                       (install-file file #$output))
 445                     (append
 446                      (find-files "." "contributing\\..*\\.texi$")
 447                      (find-files "." "guix\\..*\\.texi$")
 448                      (find-files "." "guix-cookbook\\..*\\.texi$"))))))
 449
 450   (computed-file "guix-translated-texinfo" build))
 451
 452 (define (info-manual source)
 453   "Return the Info manual built from SOURCE."
 454   (define texinfo
 455     (module-ref (resolve-interface '(gnu packages texinfo))
 456                 'texinfo))
 457
 458   (define graphviz
 459     (module-ref (resolve-interface '(gnu packages graphviz))
 460                 'graphviz))
 461
 462   (define glibc-utf8-locales
 463     (module-ref (resolve-interface '(gnu packages base))
 464                 'glibc-utf8-locales))
 465
 466   (define documentation
 467     (file-append* source "doc"))
 468
 469   (define examples
 470     (file-append* source "gnu/system/examples"))
 471
 472   (define build
 473     (with-imported-modules '((guix build utils))
 474       #~(begin
 475           (use-modules (guix build utils)
 476                        (ice-9 match))
 477
 478           (mkdir #$output)
 479
 480           ;; Create 'version.texi'.
 481           ;; XXX: Can we use a more meaningful version string yet one that
 482           ;; doesn't change at each commit?
 483           (call-with-output-file "version.texi"
 484             (lambda (port)
 485               (let ((version "0.0-git"))
 486                 (format port "
 487 @set UPDATED 1 January 1970
 488 @set UPDATED-MONTH January 1970
 489 @set EDITION ~a
 490 @set VERSION ~a\n" version version))))
 491
 492           ;; Copy configuration templates that the manual includes.
 493           (for-each (lambda (template)
 494                       (copy-file template
 495                                  (string-append
 496                                   "os-config-"
 497                                   (basename template ".tmpl")
 498                                   ".texi")))
 499                     (find-files #$examples "\\.tmpl$"))
 500
 501           ;; Build graphs.
 502           (mkdir-p (string-append #$output "/images"))
 503           (for-each (lambda (dot-file)
 504                       (invoke #+(file-append graphviz "/bin/dot")
 505                               "-Tpng" "-Gratio=.9" "-Gnodesep=.005"
 506                               "-Granksep=.00005" "-Nfontsize=9"
 507                               "-Nheight=.1" "-Nwidth=.1"
 508                               "-o" (string-append #$output "/images/"
 509                                                   (basename dot-file ".dot")
 510                                                   ".png")
 511                               dot-file))
 512                     (find-files (string-append #$documentation "/images")
 513                                 "\\.dot$"))
 514
 515           ;; Copy other PNGs.
 516           (for-each (lambda (png-file)
 517                       (install-file png-file
 518                                     (string-append #$output "/images")))
 519                     (find-files (string-append #$documentation "/images")
 520                                 "\\.png$"))
 521
 522           ;; Finally build the manual.  Copy it the Texinfo files to $PWD and
 523           ;; add a symlink to the 'images' directory so that 'makeinfo' can
 524           ;; see those images and produce image references in the Info output.
 525           (copy-recursively #$documentation "."
 526                             #:log (%make-void-port "w"))
 527           (copy-recursively #+(translate-texi-manuals source) "."
 528                             #:log (%make-void-port "w"))
 529           (delete-file-recursively "images")
 530           (symlink (string-append #$output "/images") "images")
 531
 532           ;; Provide UTF-8 locales needed by the 'xspara.c' code in makeinfo.
 533           (setenv "GUIX_LOCPATH"
 534                   #+(file-append glibc-utf8-locales "/lib/locale"))
 535
 536           (for-each (lambda (texi)
 537                       (match (string-split (basename texi) #\.)
 538                         (("guix" language "texi")
 539                          ;; Create 'version-LL.texi'.
 540                          (symlink "version.texi"
 541                                   (string-append "version-" language
 542                                                  ".texi")))
 543                         (_ #f))
 544
 545                       (invoke #+(file-append texinfo "/bin/makeinfo")
 546                               texi "-I" #$documentation
 547                               "-I" "."
 548                               "-o" (string-append #$output "/"
 549                                                   (basename texi ".texi")
 550                                                   ".info")))
 551                     (cons "guix.texi"
 552                           (append (find-files "."
 553                                               "^guix\\.[a-z]{2}(_[A-Z]{2})?\\.texi$")
 554                                   (find-files "."
 555                                               "^guix-cookbook.*\\.texi$"))))
 556
 557           ;; Compress Info files.
 558           (setenv "PATH"
 559                   #+(file-append (specification->package "gzip") "/bin"))
 560           (for-each (lambda (file)
 561                       (invoke "gzip" "-9n" file))
 562                     (find-files #$output "\\.info(-[0-9]+)?$")))))
 563
 564   (computed-file "guix-manual" build))
 565
 566 (define-syntax-rule (prevent-inlining! identifier ...)
 567   (begin (set! identifier identifier) ...))
 568
 569 ;; XXX: These procedures are actually used by 'doc/build.scm'.  Protect them
 570 ;; from inlining on Guile 3.
 571 (prevent-inlining! file-append* translate-texi-manuals info-manual)
 572
 573 (define* (guile-module-union things #:key (name "guix-module-union"))
 574   "Return the union of the subset of THINGS (packages, computed files, etc.)
 575 that provide Guile modules."
 576   (define build
 577     (with-imported-modules '((guix build union))
 578       #~(begin
 579           (use-modules (guix build union))
 580
 581           (define (modules directory)
 582             (string-append directory "/share/guile/site"))
 583
 584           (define (objects directory)
 585             (string-append directory "/lib/guile"))
 586
 587           (union-build #$output
 588                        (filter (lambda (directory)
 589                                  (or (file-exists? (modules directory))
 590                                      (file-exists? (objects directory))))
 591                                '#$things)
 592
 593                        #:log-port (%make-void-port "w")))))
 594
 595   (computed-file name build))
 596
 597 (define (quiet-guile guile)
 598   "Return a wrapper that does the same as the 'guile' executable of GUILE,
 599 except that it does not complain about locales and falls back to 'en_US.utf8'
 600 instead of 'C'."
 601   (define gcc
 602     (specification->package "gcc-toolchain"))
 603
 604   (define source
 605     (search-path %load-path
 606                  "gnu/packages/aux-files/guile-launcher.c"))
 607
 608   (define effective
 609     (version-major+minor (package-version guile)))
 610
 611   (define build
 612     ;; XXX: Reuse <c-compiler> from (guix scripts pack) instead?
 613     (with-imported-modules '((guix build utils))
 614       #~(begin
 615           (use-modules (guix build utils)
 616                        (srfi srfi-26))
 617
 618           (mkdir-p (string-append #$output "/bin"))
 619
 620           (setenv "PATH" #$(file-append gcc "/bin"))
 621           (setenv "C_INCLUDE_PATH"
 622                   (string-join
 623                    (map (cut string-append <> "/include")
 624                         '#$(match (bag-transitive-build-inputs
 625                                    (package->bag guile))
 626                              (((labels packages . _) ...)
 627                               (filter package? packages))))
 628                    ":"))
 629           (setenv "LIBRARY_PATH" #$(file-append gcc "/lib"))
 630
 631           (invoke "gcc" #$(local-file source) "-Wall" "-g0" "-O2"
 632                   "-I" #$(file-append guile "/include/guile/" effective)
 633                   "-L" #$(file-append guile "/lib")
 634                   #$(string-append "-lguile-" effective)
 635                   "-o" (string-append #$output "/bin/guile")))))
 636
 637   (computed-file "guile-wrapper" build))
 638
 639 (define* (guix-command modules
 640                        #:key source (dependencies '())
 641                        guile (guile-version (effective-version)))
 642   "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its
 643 load path."
 644   (define glibc-utf8-locales
 645     (module-ref (resolve-interface '(gnu packages base))
 646                 'glibc-utf8-locales))
 647
 648   (define module-directory
 649     ;; To minimize the number of 'stat' calls needed to locate a module,
 650     ;; create the union of all the module directories.
 651     (guile-module-union (cons modules dependencies)))
 652
 653   (program-file "guix-command"
 654                 #~(begin
 655                     ;; Remove the empty extension from the search path.
 656                     (set! %load-extensions '(".scm"))
 657
 658                     (set! %load-path
 659                       (append (list (string-append #$module-directory
 660                                                    "/share/guile/site/"
 661                                                    (effective-version))
 662                                     (string-append #$guile "/share/guile/"
 663                                                    (effective-version)))
 664                               %load-path))
 665
 666                     (set! %load-compiled-path
 667                       (append (list (string-append #$module-directory
 668                                                    "/lib/guile/"
 669                                                    (effective-version)
 670                                                    "/site-ccache")
 671                                     (string-append #$guile "/lib/guile/"
 672                                                    (effective-version)
 673                                                    "/ccache"))
 674                               %load-compiled-path))
 675
 676                     ;; To maximize the chances that locales are set up right
 677                     ;; out-of-the-box, bundle "common" UTF-8 locales.
 678                     (let ((locpath (getenv "GUIX_LOCPATH")))
 679                       (setenv "GUIX_LOCPATH"
 680                               (string-append (if locpath
 681                                                  (string-append locpath ":")
 682                                                  "")
 683                                              #$(file-append glibc-utf8-locales
 684                                                             "/lib/locale"))))
 685
 686                     (let ((guix-main (module-ref (resolve-interface '(guix ui))
 687                                                  'guix-main)))
 688                       #$(if source
 689                             #~(begin
 690                                 (bindtextdomain "guix"
 691                                                 #$(locale-data source "guix"))
 692                                 (bindtextdomain "guix-packages"
 693                                                 #$(locale-data source
 694                                                                "guix-packages"
 695                                                                "packages")))
 696                             #t)
 697
 698                       ;; XXX: It would be more convenient to change it to:
 699                       ;;   (exit (apply guix-main (command-line)))
 700                       (apply guix-main (command-line))))
 701
 702                 ;; Use a 'guile' variant that doesn't complain about locales.
 703                 #:guile (quiet-guile guile)))
 704
 705 (define (miscellaneous-files source)
 706   "Return data files taken from SOURCE."
 707   (file-mapping "guix-misc"
 708                 `(("etc/bash_completion.d/guix"
 709                    ,(file-append* source "/etc/completion/bash/guix"))
 710                   ("etc/bash_completion.d/guix-daemon"
 711                    ,(file-append* source "/etc/completion/bash/guix-daemon"))
 712                   ("share/zsh/site-functions/_guix"
 713                    ,(file-append* source "/etc/completion/zsh/_guix"))
 714                   ("share/fish/vendor_completions.d/guix.fish"
 715                    ,(file-append* source "/etc/completion/fish/guix.fish"))
 716                   ("share/guix/berlin.guix.gnu.org.pub"
 717                    ,(file-append* source
 718                                   "/etc/substitutes/berlin.guix.gnu.org.pub"))
 719                   ("share/guix/ci.guix.gnu.org.pub"  ;alias
 720                    ,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub"))
 721                   ("share/guix/ci.guix.info.pub"  ;alias
 722                    ,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub"))
 723                   ("share/guix/bordeaux.guix.gnu.org.pub"
 724                    ,(file-append* source "/etc/substitutes/bordeaux.guix.gnu.org.pub")))))
 725
 726 (define* (whole-package name modules dependencies
 727                         #:key
 728                         (guile-version (effective-version))
 729                         info daemon miscellany
 730                         guile
 731                         (command (guix-command modules
 732                                                #:dependencies dependencies
 733                                                #:guile guile
 734                                                #:guile-version guile-version)))
 735   "Return the whole Guix package NAME that uses MODULES, a derivation of all
 736 the modules (under share/guile/site and lib/guile), and DEPENDENCIES, a list
 737 of packages depended on.  COMMAND is the 'guix' program to use; INFO is the
 738 Info manual."
 739   (define (wrap daemon)
 740     (program-file "guix-daemon"
 741                   #~(begin
 742                       ;; Refer to the right 'guix' command for 'guix
 743                       ;; substitute' & co.
 744                       (setenv "GUIX" #$command)
 745
 746                       ;; Honor the user's settings rather than those hardcoded
 747                       ;; in the 'guix-daemon' package.
 748                       (unless (getenv "GUIX_STATE_DIRECTORY")
 749                         (setenv "GUIX_STATE_DIRECTORY"
 750                                 #$(string-append %localstatedir "/guix")))
 751                       (unless (getenv "GUIX_CONFIGURATION_DIRECTORY")
 752                         (setenv "GUIX_CONFIGURATION_DIRECTORY"
 753                                 #$(string-append %sysconfdir "/guix")))
 754                       (unless (getenv "NIX_STORE_DIR")
 755                         (setenv "NIX_STORE_DIR" #$%storedir))
 756
 757                       (apply execl #$(file-append daemon "/bin/guix-daemon")
 758                              "guix-daemon" (cdr (command-line))))))
 759
 760   (computed-file name
 761                  (with-imported-modules '((guix build utils))
 762                    #~(begin
 763                        (use-modules (guix build utils))
 764
 765                        (define daemon
 766                          #$(and daemon (wrap daemon)))
 767
 768                        (mkdir-p (string-append #$output "/bin"))
 769                        (symlink #$command
 770                                 (string-append #$output "/bin/guix"))
 771
 772                        (when daemon
 773                          (symlink daemon
 774                                   (string-append #$output "/bin/guix-daemon")))
 775
 776                        (let ((share (string-append #$output "/share"))
 777                              (lib   (string-append #$output "/lib"))
 778                              (info  #$info))
 779                          (mkdir-p share)
 780                          (symlink #$(file-append modules "/share/guile")
 781                                   (string-append share "/guile"))
 782                          (when info
 783                            (symlink #$info (string-append share "/info")))
 784
 785                          (mkdir-p lib)
 786                          (symlink #$(file-append modules "/lib/guile")
 787                                   (string-append lib "/guile")))
 788
 789                        (when #$miscellany
 790                          (copy-recursively #$miscellany #$output
 791                                            #:log (%make-void-port "w")))))))
 792
 793 (define (transitive-package-dependencies package)
 794   "Return the list of packages propagated by PACKAGE, including PACKAGE
 795 itself."
 796   (match (package-transitive-propagated-inputs package)
 797     (((labels packages _ ...) ...)
 798      (cons package packages))))
 799
 800 (define* (compiled-guix source #:key
 801                         (version %guix-version)
 802                         (channel-metadata #f)
 803                         (pull-version 1)
 804                         (name (string-append "guix-" version))
 805                         (guile-version (effective-version))
 806                         (guile-for-build (default-guile))
 807                         (gzip (specification->package "gzip"))
 808                         (bzip2 (specification->package "bzip2"))
 809                         (xz (specification->package "xz"))
 810                         (guix (specification->package "guix")))
 811   "Return a file-like object that contains a compiled Guix."
 812   (define guile-avahi
 813     (specification->package "guile-avahi"))
 814
 815   (define guile-json
 816     (specification->package "guile-json"))
 817
 818   (define guile-ssh
 819     (specification->package "guile-ssh"))
 820
 821   (define guile-lib
 822     (specification->package "guile-lib"))
 823
 824   (define guile-git
 825     (specification->package "guile-git"))
 826
 827   (define guile-sqlite3
 828     (specification->package "guile-sqlite3"))
 829
 830   (define guile-zlib
 831     (specification->package "guile-zlib"))
 832
 833   (define guile-lzlib
 834     (specification->package "guile-lzlib"))
 835
 836   (define guile-zstd
 837     (specification->package "guile-zstd"))
 838
 839   (define guile-gcrypt
 840     (specification->package "guile-gcrypt"))
 841
 842   (define guile-semver
 843     (specification->package "guile-semver"))
 844
 845   (define gnutls
 846     (specification->package "gnutls"))
 847
 848   (define disarchive
 849     (specification->package "disarchive"))
 850
 851   (define dependencies
 852     (append-map transitive-package-dependencies
 853                 (list guile-gcrypt gnutls guile-git guile-avahi
 854                       guile-json guile-semver guile-ssh guile-sqlite3
 855                       guile-lib guile-zlib guile-lzlib guile-zstd)))
 856
 857   (define *core-modules*
 858     (scheme-node "guix-core"
 859                  '((guix)
 860                    (guix monad-repl)
 861                    (guix packages)
 862                    (guix download)
 863                    (guix discovery)
 864                    (guix profiles)
 865                    (guix build-system gnu)
 866                    (guix build-system trivial)
 867                    (guix build profiles)
 868                    (guix build gnu-build-system))
 869
 870                  ;; Provide a dummy (guix config) with the default version
 871                  ;; number, storedir, etc.  This is so that "guix-core" is the
 872                  ;; same across all installations and doesn't need to be
 873                  ;; rebuilt when the version changes, which in turn means we
 874                  ;; can have substitutes for it.
 875                  #:extra-modules
 876                  `(((guix config) => ,(make-config.scm)))
 877
 878                  ;; (guix man-db) is needed at build-time by (guix profiles)
 879                  ;; but we don't need to compile it; not compiling it allows
 880                  ;; us to avoid an extra dependency on guile-gdbm-ffi.
 881                  #:extra-files
 882                  `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm"))
 883                    ("guix/build/po.scm" ,(local-file "../guix/build/po.scm"))
 884                    ("guix/store/schema.sql"
 885                     ,(local-file "../guix/store/schema.sql")))
 886
 887                  #:extensions (list guile-gcrypt
 888                                     guile-json)   ;for (guix swh)
 889                  #:guile-for-build guile-for-build))
 890
 891   (define *extra-modules*
 892     (scheme-node "guix-extra"
 893                  (filter-map (match-lambda
 894                                (('guix 'scripts _ ..1) #f)
 895                                (('guix 'man-db) #f)
 896                                (('guix 'tests _ ...) #f)
 897                                (name name))
 898                              (scheme-modules* source "guix"))
 899                  (list *core-modules*)
 900
 901                  #:extra-files
 902                  `(("guix/graph.js" ,(local-file "../guix/graph.js"))
 903                    ("guix/d3.v3.js" ,(local-file "../guix/d3.v3.js")))
 904
 905                  #:extensions dependencies
 906                  #:guile-for-build guile-for-build))
 907
 908   (define *core-package-modules*
 909     (scheme-node "guix-packages-base"
 910                  `((gnu packages)
 911                    (gnu packages base))
 912                  (list *core-modules* *extra-modules*)
 913                  #:extensions dependencies
 914
 915                  ;; Add all the non-Scheme files here.  We must do it here so
 916                  ;; that 'search-patches' & co. can find them.  Ideally we'd
 917                  ;; keep them next to the .scm files that use them but it's
 918                  ;; difficult to do (XXX).
 919                  #:extra-files
 920                  (file-imports source "gnu/packages"
 921                                (lambda (file stat)
 922                                  (and (eq? 'regular (stat:type stat))
 923                                       (not (string-suffix? ".scm" file))
 924                                       (not (string-suffix? ".go" file))
 925                                       (not (string-prefix? ".#" file))
 926                                       (not (string-suffix? "~" file)))))
 927                  #:guile-for-build guile-for-build))
 928
 929   (define *package-modules*
 930     (scheme-node "guix-packages"
 931                  (scheme-modules* source "gnu/packages")
 932                  (list *core-modules* *extra-modules* *core-package-modules*)
 933                  #:extensions dependencies
 934                  #:guile-for-build guile-for-build))
 935
 936   (define *system-modules*
 937     (scheme-node "guix-system"
 938                  `((gnu system)
 939                    (gnu services)
 940                    ,@(scheme-modules* source "gnu/bootloader")
 941                    ,@(scheme-modules* source "gnu/system")
 942                    ,@(scheme-modules* source "gnu/services")
 943                    ,@(scheme-modules* source "gnu/machine"))
 944                  (list *core-package-modules* *package-modules*
 945                        *extra-modules* *core-modules*)
 946                  #:extensions dependencies
 947                  #:extra-files
 948                  (append (file-imports source "gnu/system/examples"
 949                                        (const #t))
 950
 951                          ;; All the installer code is on the build-side.
 952                          (file-imports source "gnu/installer/"
 953                                        (const #t))
 954                          ;; Build-side code that we don't build.  Some of
 955                          ;; these depend on guile-rsvg, the Shepherd, etc.
 956                          (file-imports source "gnu/build" (const #t)))
 957                  #:guile-for-build
 958                  guile-for-build))
 959
 960   (define *cli-modules*
 961     (scheme-node "guix-cli"
 962                  (append (scheme-modules* source "/guix/scripts")
 963                          `((gnu ci)))
 964                  (list *core-modules* *extra-modules*
 965                        *core-package-modules* *package-modules*
 966                        *system-modules*)
 967                  #:extensions dependencies
 968                  #:guile-for-build guile-for-build))
 969
 970   (define *system-test-modules*
 971     ;; Ship these modules mostly so (gnu ci) can discover them.
 972     (scheme-node "guix-system-tests"
 973                  `((gnu tests)
 974                    ,@(scheme-modules* source "gnu/tests"))
 975                  (list *core-package-modules* *package-modules*
 976                        *extra-modules* *system-modules* *core-modules*
 977                        *cli-modules*)           ;for (guix scripts pack), etc.
 978                  #:extensions dependencies
 979                  #:guile-for-build guile-for-build))
 980
 981   (define *config*
 982     (scheme-node "guix-config"
 983                  '()
 984                  #:extra-modules
 985                  `(((guix config)
 986                     => ,(make-config.scm #:gzip gzip
 987                                          #:bzip2 bzip2
 988                                          #:xz xz
 989                                          #:package-name
 990                                          %guix-package-name
 991                                          #:package-version
 992                                          version
 993                                          #:channel-metadata
 994                                          channel-metadata
 995                                          #:bug-report-address
 996                                          %guix-bug-report-address
 997                                          #:home-page-url
 998                                          %guix-home-page-url)))
 999                  #:guile-for-build guile-for-build))
1000
1001   (define (built-modules node-subset)
1002     (directory-union (string-append name "-modules")
1003                      (append-map node-subset
1004
1005                                  ;; Note: *CONFIG* comes first so that it
1006                                  ;; overrides the (guix config) module that
1007                                  ;; comes with *CORE-MODULES*.
1008                                  (list *config*
1009                                        *cli-modules*
1010                                        *system-test-modules*
1011                                        *system-modules*
1012                                        *package-modules*
1013                                        *core-package-modules*
1014                                        *extra-modules*
1015                                        *core-modules*))
1016
1017                      ;; Silently choose the first entry upon collision so that
1018                      ;; we choose *CONFIG*.
1019                      #:resolve-collision 'first
1020
1021                      ;; When we do (add-to-store "utils.scm"), "utils.scm" must
1022                      ;; be a regular file, not a symlink.  Thus, arrange so that
1023                      ;; regular files appear as regular files in the final
1024                      ;; output.
1025                      #:copy? #t
1026                      #:quiet? #t))
1027
1028   ;; Version 0 of 'guix pull' meant we'd just return Scheme modules.
1029   ;; Version 1 is when we return the full package.
1030   (cond ((= 1 pull-version)
1031          ;; The whole package, with a standard file hierarchy.
1032          (let* ((modules  (built-modules (compose list node-source+compiled)))
1033                 (command  (guix-command modules
1034                                         #:source source
1035                                         #:dependencies
1036                                         (cons disarchive dependencies)
1037                                         #:guile guile-for-build
1038                                         #:guile-version guile-version)))
1039            (whole-package name modules dependencies
1040                           #:command command
1041                           #:guile guile-for-build
1042
1043                           ;; Include 'guix-daemon'.  XXX: Here we inject an
1044                           ;; older snapshot of guix-daemon, but that's a good
1045                           ;; enough approximation for now.
1046                           #:daemon (module-ref (resolve-interface
1047                                                 '(gnu packages
1048                                                       package-management))
1049                                                'guix-daemon)
1050
1051                           #:info (info-manual source)
1052                           #:miscellany (miscellaneous-files source)
1053                           #:guile-version guile-version)))
1054         ((= 0 pull-version)
1055          ;; Legacy 'guix pull': return the .scm and .go files as one
1056          ;; directory.
1057          (built-modules (lambda (node)
1058                           (list (node-source node)
1059                                 (node-compiled node)))))
1060         (else
1061          ;; Unsupported 'guix pull' version.
1062          #f)))
1063
1064 \f
1065 ;;;
1066 ;;; Generating (guix config).
1067 ;;;
1068
1069 (define %persona-variables
1070   ;; (guix config) variables that define Guix's persona.
1071   '(%guix-package-name
1072     %guix-version
1073     %guix-bug-report-address
1074     %guix-home-page-url))
1075
1076 (define %config-variables
1077   ;; (guix config) variables corresponding to Guix configuration.
1078   (letrec-syntax ((variables (syntax-rules ()
1079                                ((_)
1080                                 '())
1081                                ((_ variable rest ...)
1082                                 (cons `(variable . ,variable)
1083                                       (variables rest ...))))))
1084     (variables %localstatedir %storedir %sysconfdir)))
1085
1086 (define* (make-config.scm #:key gzip xz bzip2
1087                           (package-name "GNU Guix")
1088                           (package-version "0")
1089                           (channel-metadata #f)
1090                           (bug-report-address "bug-guix@gnu.org")
1091                           (home-page-url "https://guix.gnu.org"))
1092
1093   ;; Hack so that Geiser is not confused.
1094   (define defmod 'define-module)
1095
1096   (scheme-file "config.scm"
1097                #~(;; The following expressions get spliced.
1098                    (#$defmod (guix config)
1099                      #:export (%guix-package-name
1100                                %guix-version
1101                                %guix-bug-report-address
1102                                %guix-home-page-url
1103                                %channel-metadata
1104                                %system
1105                                %store-directory
1106                                %state-directory
1107                                %store-database-directory
1108                                %config-directory
1109                                %gzip
1110                                %bzip2
1111                                %xz))
1112
1113                    (define %system
1114                      #$(%current-system))
1115
1116                    #$@(map (match-lambda
1117                              ((name . value)
1118                               #~(define-public #$name #$value)))
1119                            %config-variables)
1120
1121                    (define %store-directory
1122                      (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
1123                          %storedir))
1124
1125                    (define %state-directory
1126                      ;; This must match `NIX_STATE_DIR' as defined in
1127                      ;; `nix/local.mk'.
1128                      (or (getenv "GUIX_STATE_DIRECTORY")
1129                          (string-append %localstatedir "/guix")))
1130
1131                    (define %store-database-directory
1132                      (or (getenv "GUIX_DATABASE_DIRECTORY")
1133                          (string-append %state-directory "/db")))
1134
1135                    (define %config-directory
1136                      ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
1137                      ;; defined in `nix/local.mk'.
1138                      (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
1139                          (string-append %sysconfdir "/guix")))
1140
1141                    (define %guix-package-name #$package-name)
1142                    (define %guix-version #$package-version)
1143                    (define %guix-bug-report-address #$bug-report-address)
1144                    (define %guix-home-page-url #$home-page-url)
1145
1146                    (define %channel-metadata
1147                      ;; Metadata for the 'guix' channel in use.  This
1148                      ;; information is used by (guix describe).
1149                      '#$channel-metadata)
1150
1151                    (define %gzip
1152                      #+(and gzip (file-append gzip "/bin/gzip")))
1153                    (define %bzip2
1154                      #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
1155                    (define %xz
1156                      #+(and xz (file-append xz "/bin/xz"))))
1157
1158                ;; Guile 2.0 *requires* the 'define-module' to be at the
1159                ;; top-level or the 'toplevel-ref' in the resulting .go file are
1160                ;; made relative to a nonexistent anonymous module.
1161                #:splice? #t))
1162
1163 \f
1164 ;;;
1165 ;;; Building.
1166 ;;;
1167
1168 (define* (compiled-modules name module-tree module-files
1169                            #:optional
1170                            (dependencies '())
1171                            (dependencies-compiled '())
1172                            #:key
1173                            (extensions '())       ;full-blown Guile packages
1174                            parallel?
1175                            guile-for-build)
1176   "Build all the MODULE-FILES from MODULE-TREE.  MODULE-FILES must be a list
1177 like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory
1178 containing MODULE-FILES and possibly other files as well."
1179   ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix
1180   ;; gexp).
1181   (define build
1182     (with-imported-modules (source-module-closure
1183                             '((guix build compile)
1184                               (guix build utils)))
1185       #~(begin
1186           (use-modules (srfi srfi-26)
1187                        (ice-9 match)
1188                        (ice-9 format)
1189                        (ice-9 threads)
1190                        (guix build compile)
1191                        (guix build utils))
1192
1193           (define (regular? file)
1194             (not (member file '("." ".."))))
1195
1196           (define (report-load file total completed)
1197             (display #\cr)
1198             (format #t
1199                     "[~3@a/~3@a] loading...\t~5,1f% of ~d files"
1200
1201                     ;; Note: Multiply TOTAL by two to account for the
1202                     ;; compilation phase that follows.
1203                     completed (* total 2)
1204
1205                     (* 100. (/ completed total)) total)
1206             (force-output))
1207
1208           (define (report-compilation file total completed)
1209             (display #\cr)
1210             (format #t "[~3@a/~3@a] compiling...\t~5,1f% of ~d files"
1211
1212                     ;; Add TOTAL to account for the load phase that came
1213                     ;; before.
1214                     (+ total completed) (* total 2)
1215
1216                     (* 100. (/ completed total)) total)
1217             (force-output))
1218
1219           (define (process-directory directory files output)
1220             ;; Hide compilation warnings.
1221             (parameterize ((current-warning-port (%make-void-port "w")))
1222               (compile-files directory #$output files
1223                              #:workers (parallel-job-count)
1224                              #:report-load report-load
1225                              #:report-compilation report-compilation)))
1226
1227           (setvbuf (current-output-port) 'line)
1228           (setvbuf (current-error-port) 'line)
1229
1230           (set! %load-path (cons #+module-tree %load-path))
1231           (set! %load-path
1232             (append '#+dependencies
1233                     (map (lambda (extension)
1234                            (string-append extension "/share/guile/site/"
1235                                           (effective-version)))
1236                          '#+extensions)
1237                     %load-path))
1238
1239           (set! %load-compiled-path
1240             (append '#+dependencies-compiled
1241                     (map (lambda (extension)
1242                            (string-append extension "/lib/guile/"
1243                                           (effective-version)
1244                                           "/site-ccache"))
1245                          '#+extensions)
1246                     %load-compiled-path))
1247
1248           ;; Load the compiler modules upfront.
1249           (compile #f)
1250
1251           (mkdir #$output)
1252           (chdir #+module-tree)
1253           (process-directory "." '#+module-files #$output)
1254           (newline))))
1255
1256   (computed-file name build
1257                  #:guile guile-for-build
1258                  #:options
1259                  `(#:local-build? #f              ;allow substitutes
1260
1261                    ;; Don't annoy people about _IONBF deprecation.
1262                    ;; Initialize 'terminal-width' in (system repl debug)
1263                    ;; to a large-enough value to make backtrace more
1264                    ;; verbose.
1265                    #:env-vars (("GUILE_WARN_DEPRECATED" . "no")
1266                                ("COLUMNS" . "200")))))
1267
1268 \f
1269 ;;;
1270 ;;; Building.
1271 ;;;
1272
1273 (define* (guix-derivation source version
1274                           #:optional (guile-version (effective-version))
1275                           #:key (pull-version 0)
1276                           channel-metadata)
1277   "Return, as a monadic value, the derivation to build the Guix from SOURCE
1278 for GUILE-VERSION.  Use VERSION as the version string.  Use CHANNEL-METADATA
1279 as the channel metadata sexp to include in (guix config).
1280
1281 PULL-VERSION specifies the version of the 'guix pull' protocol.  Return #f if
1282 this PULL-VERSION value is not supported."
1283   (define (shorten version)
1284     (if (and (string-every char-set:hex-digit version)
1285              (> (string-length version) 9))
1286         (string-take version 9)                   ;Git commit
1287         version))
1288
1289   (define guile
1290     ;; When PULL-VERSION >= 1, produce a self-contained Guix and use the
1291     ;; current Guile unconditionally.
1292     (specification->package "guile"))
1293
1294   (when (and (< pull-version 1)
1295              (not (string=? (package-version guile) guile-version)))
1296     ;; Guix < 0.15.0 has PULL-VERSION = 0, where the host Guile is reused and
1297     ;; can be any version.  When that happens and Guile is not current (e.g.,
1298     ;; it's Guile 2.0), just bail out.
1299     (raise (condition
1300             (&message
1301              (message "Guix is too old and cannot be upgraded")))))
1302
1303   (mbegin %store-monad
1304     (set-guile-for-build guile)
1305     (let ((guix (compiled-guix source
1306                                #:version version
1307                                #:channel-metadata channel-metadata
1308                                #:name (string-append "guix-"
1309                                                      (shorten version))
1310                                #:pull-version pull-version
1311                                #:guile-version (if (>= pull-version 1)
1312                                                    "3.0" guile-version)
1313                                #:guile-for-build guile)))
1314       (if guix
1315           (lower-object guix)
1316           (return #f)))))