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