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