guix/self.scm

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