guix/self.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2018 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 ((guix build compile) #:select (%lightweight-optimizations))
  32   #:use-module (srfi srfi-1)
  33   #:use-module (srfi srfi-9)
  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             reload-guix))
  40
  41 \f
  42 ;;;
  43 ;;; Dependency handling.
  44 ;;;
  45
  46 (define* (false-if-wrong-guile package
  47                                #:optional (guile-version (effective-version)))
  48   "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g.,
  49 2.0 instead of 2.2), otherwise return PACKAGE."
  50   (let ((guile (any (match-lambda
  51                       ((label (? package? dep) _ ...)
  52                        (and (string=? (package-name dep) "guile")
  53                             dep)))
  54                     (package-direct-inputs package))))
  55     (and (or (not guile)
  56              (string-prefix? guile-version
  57                              (package-version guile)))
  58          package)))
  59
  60 (define (package-for-guile guile-version . names)
  61   "Return the package with one of the given NAMES that depends on
  62 GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
  63   (let loop ((names names))
  64     (match names
  65       (()
  66        #f)
  67       ((name rest ...)
  68        (match (specification->package name)
  69          (#f
  70           (loop rest))
  71          ((? package? package)
  72           (or (false-if-wrong-guile package guile-version)
  73               (loop rest))))))))
  74
  75 (define specification->package
  76   ;; Use our own variant of that procedure because that of (gnu packages)
  77   ;; would traverse all the .scm files, which is wasteful.
  78   (let ((ref (lambda (module variable)
  79                (module-ref (resolve-interface module) variable))))
  80     (match-lambda
  81       ("guile"      (ref '(gnu packages commencement) 'guile-final))
  82       ("guile-json" (ref '(gnu packages guile) 'guile-json))
  83       ("guile-ssh"  (ref '(gnu packages ssh)   'guile-ssh))
  84       ("guile-git"  (ref '(gnu packages guile) 'guile-git))
  85       ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
  86       ("guile-gcrypt"  (ref '(gnu packages gnupg) 'guile-gcrypt))
  87       ("gnutls"     (ref '(gnu packages tls) 'gnutls))
  88       ("zlib"       (ref '(gnu packages compression) 'zlib))
  89       ("gzip"       (ref '(gnu packages compression) 'gzip))
  90       ("bzip2"      (ref '(gnu packages compression) 'bzip2))
  91       ("xz"         (ref '(gnu packages compression) 'xz))
  92       ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json))
  93       ("guile2.0-ssh"  (ref '(gnu packages ssh) 'guile2.0-ssh))
  94       ("guile2.0-git"  (ref '(gnu packages guile) 'guile2.0-git))
  95       ;; XXX: No "guile2.0-sqlite3".
  96       ("guile2.0-gnutls" (ref '(gnu packages tls) 'gnutls/guile-2.0))
  97       (_               #f))))                     ;no such package
  98
  99 \f
 100 ;;;
 101 ;;; Derivations.
 102 ;;;
 103
 104 ;; Node in a DAG of build tasks.  Each node maps to a derivation, but it's
 105 ;; easier to express things this way.
 106 (define-record-type <node>
 107   (node name modules source dependencies compiled)
 108   node?
 109   (name          node-name)                       ;string
 110   (modules       node-modules)                    ;list of module names
 111   (source        node-source)                     ;list of source files
 112   (dependencies  node-dependencies)               ;list of nodes
 113   (compiled      node-compiled))                  ;node -> lowerable object
 114
 115 ;; File mappings are essentially an alist as passed to 'imported-files'.
 116 (define-record-type <file-mapping>
 117   (file-mapping name alist)
 118   file-mapping?
 119   (name  file-mapping-name)
 120   (alist file-mapping-alist))
 121
 122 (define-gexp-compiler (file-mapping-compiler (mapping <file-mapping>)
 123                                              system target)
 124   ;; Here we use 'imported-files', which can arrange to directly import all
 125   ;; the files instead of creating a derivation, when possible.
 126   (imported-files (map (match-lambda
 127                          ((destination (? local-file? file))
 128                           (cons destination
 129                                 (local-file-absolute-file-name file)))
 130                          ((destination source)
 131                           (cons destination source))) ;silliness
 132                        (file-mapping-alist mapping))
 133                   #:name (file-mapping-name mapping)
 134                   #:system system))
 135
 136 (define (node-fold proc init nodes)
 137   (let loop ((nodes nodes)
 138              (visited (setq))
 139              (result init))
 140     (match nodes
 141       (() result)
 142       ((head tail ...)
 143        (if (set-contains? visited head)
 144            (loop tail visited result)
 145            (loop tail (set-insert head visited)
 146                  (proc head result)))))))
 147
 148 (define (node-modules/recursive nodes)
 149   (node-fold (lambda (node modules)
 150                (append (node-modules node) modules))
 151              '()
 152              nodes))
 153
 154 (define* (closure modules #:optional (except '()))
 155   (source-module-closure modules
 156                          #:select?
 157                          (match-lambda
 158                            (('guix 'config)
 159                             #f)
 160                            ((and module
 161                                  (or ('guix _ ...) ('gnu _ ...)))
 162                             (not (member module except)))
 163                            (rest #f))))
 164
 165 (define module->import
 166   ;; Return a file-name/file-like object pair for the specified module and
 167   ;; suitable for 'imported-files'.
 168   (match-lambda
 169     ((module '=> thing)
 170      (let ((file (module-name->file-name module)))
 171        (list file thing)))
 172     (module
 173         (let ((file (module-name->file-name module)))
 174           (list file
 175                 (local-file (search-path %load-path file)))))))
 176
 177 (define* (scheme-node name modules #:optional (dependencies '())
 178                       #:key (extra-modules '()) (extra-files '())
 179                       (extensions '())
 180                       parallel? guile-for-build)
 181   "Return a node that builds the given Scheme MODULES, and depends on
 182 DEPENDENCIES (a list of nodes).  EXTRA-MODULES is a list of additional modules
 183 added to the source, and EXTRA-FILES is a list of additional files.
 184 EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that
 185 must be present in the search path."
 186   (let* ((modules (append extra-modules
 187                           (closure modules
 188                                    (node-modules/recursive dependencies))))
 189          (module-files (map module->import modules))
 190          (source (file-mapping (string-append name "-source")
 191                                (append module-files extra-files))))
 192     (node name modules source dependencies
 193           (compiled-modules name source
 194                             (map car module-files)
 195                             (map node-source dependencies)
 196                             (map node-compiled dependencies)
 197                             #:extensions extensions
 198                             #:parallel? parallel?
 199                             #:guile-for-build guile-for-build))))
 200
 201 (define (file-imports directory sub-directory pred)
 202   "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY.  Return a
 203 list of file-name/file-like objects suitable as inputs to 'imported-files'."
 204   (map (lambda (file)
 205          (list (string-drop file (+ 1 (string-length directory)))
 206                (local-file file #:recursive? #t)))
 207        (find-files (string-append directory "/" sub-directory) pred)))
 208
 209 (define* (sub-directory item sub-directory)
 210   "Return SUB-DIRECTORY within ITEM, which may be a file name or a file-like
 211 object."
 212   (match item
 213     ((? string?)
 214      ;; This is the optimal case: we return a new "source".  Thus, a
 215      ;; derivation that depends on this sub-directory does not depend on ITEM
 216      ;; itself.
 217      (local-file (string-append item "/" sub-directory)
 218                  #:recursive? #t))
 219     ;; TODO: Add 'local-file?' case.
 220     (_
 221      ;; In this case, anything that refers to the result also depends on ITEM,
 222      ;; which isn't great.
 223      (file-append item "/" sub-directory))))
 224
 225 (define* (locale-data source domain
 226                       #:optional (directory domain))
 227   "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to
 228 DOMAIN, a gettext domain."
 229   (define gettext
 230     (module-ref (resolve-interface '(gnu packages gettext))
 231                 'gettext-minimal))
 232
 233   (define build
 234     (with-imported-modules '((guix build utils))
 235       #~(begin
 236           (use-modules (guix build utils)
 237                        (srfi srfi-26)
 238                        (ice-9 match) (ice-9 ftw))
 239
 240           (define po-directory
 241             #+(sub-directory source (string-append "po/" directory)))
 242
 243           (define (compile language)
 244             (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/"
 245                                       #$domain ".mo")))
 246               (mkdir-p (dirname gmo))
 247               (invoke #+(file-append gettext "/bin/msgfmt")
 248                       "-c" "--statistics" "--verbose"
 249                       "-o" gmo
 250                       (string-append po-directory "/" language ".po"))))
 251
 252           (define (linguas)
 253             ;; Return the list of languages.  Note: don't read 'LINGUAS'
 254             ;; because it contains things like 'en@boldquot' that do not have
 255             ;; a corresponding .po file.
 256             (map (cut basename <> ".po")
 257                  (scandir po-directory
 258                           (cut string-suffix? ".po" <>))))
 259
 260           (for-each compile (linguas)))))
 261
 262   (computed-file (string-append "guix-locale-" domain)
 263                  build))
 264
 265 (define (info-manual source)
 266   "Return the Info manual built from SOURCE."
 267   (define texinfo
 268     (module-ref (resolve-interface '(gnu packages texinfo))
 269                 'texinfo))
 270
 271   (define graphviz
 272     (module-ref (resolve-interface '(gnu packages graphviz))
 273                 'graphviz))
 274
 275   (define documentation
 276     (sub-directory source "doc"))
 277
 278   (define examples
 279     (sub-directory source "gnu/system/examples"))
 280
 281   (define build
 282     (with-imported-modules '((guix build utils))
 283       #~(begin
 284           (use-modules (guix build utils))
 285
 286           (mkdir #$output)
 287
 288           ;; Create 'version.texi'.
 289           ;; XXX: Can we use a more meaningful version string yet one that
 290           ;; doesn't change at each commit?
 291           (call-with-output-file "version.texi"
 292             (lambda (port)
 293               (let ((version "0.0-git)"))
 294                 (format port "
 295 @set UPDATED 1 January 1970
 296 @set UPDATED-MONTH January 1970
 297 @set EDITION ~a
 298 @set VERSION ~a\n" version version))))
 299
 300           ;; Copy configuration templates that the manual includes.
 301           (for-each (lambda (template)
 302                       (copy-file template
 303                                  (string-append
 304                                   "os-config-"
 305                                   (basename template ".tmpl")
 306                                   ".texi")))
 307                     (find-files #$examples "\\.tmpl$"))
 308
 309           ;; Build graphs.
 310           (mkdir-p (string-append #$output "/images"))
 311           (for-each (lambda (dot-file)
 312                       (invoke #+(file-append graphviz "/bin/dot")
 313                               "-Tpng" "-Gratio=.9" "-Gnodesep=.005"
 314                               "-Granksep=.00005" "-Nfontsize=9"
 315                               "-Nheight=.1" "-Nwidth=.1"
 316                               "-o" (string-append #$output "/images/"
 317                                                   (basename dot-file ".dot")
 318                                                   ".png")
 319                               dot-file))
 320                     (find-files (string-append #$documentation "/images")
 321                                 "\\.dot$"))
 322
 323           ;; Copy other PNGs.
 324           (for-each (lambda (png-file)
 325                       (install-file png-file
 326                                     (string-append #$output "/images")))
 327                     (find-files (string-append #$documentation "/images")
 328                                 "\\.png$"))
 329
 330           ;; Finally build the manual.  Copy it the Texinfo files to $PWD and
 331           ;; add a symlink to the 'images' directory so that 'makeinfo' can
 332           ;; see those images and produce image references in the Info output.
 333           (copy-recursively #$documentation "."
 334                             #:log (%make-void-port "w"))
 335           (delete-file-recursively "images")
 336           (symlink (string-append #$output "/images") "images")
 337
 338           (for-each (lambda (texi)
 339                       (unless (string=? "guix.texi" texi)
 340                         ;; Create 'version-LL.texi'.
 341                         (let* ((base (basename texi ".texi"))
 342                                (dot  (string-index base #\.))
 343                                (tag  (string-drop base (+ 1 dot))))
 344                           (symlink "version.texi"
 345                                    (string-append "version-" tag ".texi"))))
 346
 347                       (invoke #+(file-append texinfo "/bin/makeinfo")
 348                               texi "-I" #$documentation
 349                               "-I" "."
 350                               "-o" (string-append #$output "/"
 351                                                   (basename texi ".texi")
 352                                                   ".info")))
 353                     (cons "guix.texi"
 354                           (find-files "." "^guix\\.[a-z]{2}\\.texi$"))))))
 355
 356   (computed-file "guix-manual" build))
 357
 358 (define* (guix-command modules #:optional compiled-modules
 359                        #:key source (dependencies '())
 360                        guile (guile-version (effective-version)))
 361   "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its
 362 load path."
 363   (define source-directories
 364     (map (lambda (package)
 365            (file-append package "/share/guile/site/"
 366                         guile-version))
 367          dependencies))
 368
 369   (define object-directories
 370     (map (lambda (package)
 371            (file-append package "/lib/guile/"
 372                         guile-version "/site-ccache"))
 373          dependencies))
 374
 375   (program-file "guix-command"
 376                 #~(begin
 377                     (set! %load-path
 378                       (append (filter file-exists? '#$source-directories)
 379                               %load-path))
 380
 381                     (set! %load-compiled-path
 382                       (append (filter file-exists? '#$object-directories)
 383                               %load-compiled-path))
 384
 385                     (set! %load-path (cons #$modules %load-path))
 386                     (set! %load-compiled-path
 387                       (cons (or #$compiled-modules #$modules)
 388                             %load-compiled-path))
 389
 390                     (let ((guix-main (module-ref (resolve-interface '(guix ui))
 391                                                  'guix-main)))
 392                       #$(if source
 393                             #~(begin
 394                                 (bindtextdomain "guix"
 395                                                 #$(locale-data source "guix"))
 396                                 (bindtextdomain "guix-packages"
 397                                                 #$(locale-data source
 398                                                                "guix-packages"
 399                                                                "packages")))
 400                             #t)
 401
 402                       ;; XXX: It would be more convenient to change it to:
 403                       ;;   (exit (apply guix-main (command-line)))
 404                       (apply guix-main (command-line))))
 405                 #:guile guile))
 406
 407 (define* (whole-package name modules dependencies
 408                         #:key
 409                         (guile-version (effective-version))
 410                         compiled-modules
 411                         info daemon guile
 412                         (command (guix-command modules
 413                                                #:dependencies dependencies
 414                                                #:guile guile
 415                                                #:guile-version guile-version)))
 416   "Return the whole Guix package NAME that uses MODULES, a derivation of all
 417 the modules, and DEPENDENCIES, a list of packages depended on.  COMMAND is the
 418 'guix' program to use; INFO is the Info manual.  When COMPILED-MODULES is
 419 true, it is linked as 'lib/guile/X.Y/site-ccache'; otherwise, .go files are
 420 assumed to be part of MODULES."
 421   (computed-file name
 422                  (with-imported-modules '((guix build utils))
 423                    #~(begin
 424                        (use-modules (guix build utils))
 425                        (mkdir-p (string-append #$output "/bin"))
 426                        (symlink #$command
 427                                 (string-append #$output "/bin/guix"))
 428
 429                        (when #$daemon
 430                          (symlink (string-append #$daemon "/bin/guix-daemon")
 431                                   (string-append #$output "/bin/guix-daemon")))
 432
 433                        (let ((modules (string-append #$output
 434                                                      "/share/guile/site/"
 435                                                      (effective-version)))
 436                              (info    #$info))
 437                          (mkdir-p (dirname modules))
 438                          (symlink #$modules modules)
 439                          (when info
 440                            (symlink #$info
 441                                     (string-append #$output
 442                                                    "/share/info"))))
 443
 444                        ;; Object files.
 445                        (when #$compiled-modules
 446                          (let ((modules (string-append #$output "/lib/guile/"
 447                                                        (effective-version)
 448                                                        "/site-ccache")))
 449                            (mkdir-p (dirname modules))
 450                            (symlink #$compiled-modules modules)))))))
 451
 452 (define* (compiled-guix source #:key (version %guix-version)
 453                         (pull-version 1)
 454                         (name (string-append "guix-" version))
 455                         (guile-version (effective-version))
 456                         (guile-for-build (guile-for-build guile-version))
 457                         (zlib (specification->package "zlib"))
 458                         (gzip (specification->package "gzip"))
 459                         (bzip2 (specification->package "bzip2"))
 460                         (xz (specification->package "xz"))
 461                         (guix (specification->package "guix")))
 462   "Return a file-like object that contains a compiled Guix."
 463   (define guile-json
 464     (package-for-guile guile-version
 465                        "guile-json"
 466                        "guile2.0-json"))
 467
 468   (define guile-ssh
 469     (package-for-guile guile-version
 470                        "guile-ssh"
 471                        "guile2.0-ssh"))
 472
 473   (define guile-git
 474     (package-for-guile guile-version
 475                        "guile-git"
 476                        "guile2.0-git"))
 477
 478   (define guile-sqlite3
 479     (package-for-guile guile-version
 480                        "guile-sqlite3"
 481                        "guile2.0-sqlite3"))
 482
 483   (define guile-gcrypt
 484     (package-for-guile guile-version
 485                        "guile-gcrypt"))
 486
 487   (define gnutls
 488     (package-for-guile guile-version
 489                        "gnutls" "guile2.0-gnutls"))
 490
 491   (define dependencies
 492     (match (append-map (lambda (package)
 493                          (cons (list "x" package)
 494                                (package-transitive-propagated-inputs package)))
 495                        (list guile-gcrypt gnutls guile-git guile-json
 496                              guile-ssh guile-sqlite3))
 497       (((labels packages _ ...) ...)
 498        packages)))
 499
 500   (define *core-modules*
 501     (scheme-node "guix-core"
 502                  '((guix)
 503                    (guix monad-repl)
 504                    (guix packages)
 505                    (guix download)
 506                    (guix discovery)
 507                    (guix profiles)
 508                    (guix build-system gnu)
 509                    (guix build-system trivial)
 510                    (guix build profiles)
 511                    (guix build gnu-build-system))
 512
 513                  ;; Provide a dummy (guix config) with the default version
 514                  ;; number, storedir, etc.  This is so that "guix-core" is the
 515                  ;; same across all installations and doesn't need to be
 516                  ;; rebuilt when the version changes, which in turn means we
 517                  ;; can have substitutes for it.
 518                  #:extra-modules
 519                  `(((guix config) => ,(make-config.scm)))
 520
 521                  ;; (guix man-db) is needed at build-time by (guix profiles)
 522                  ;; but we don't need to compile it; not compiling it allows
 523                  ;; us to avoid an extra dependency on guile-gdbm-ffi.
 524                  #:extra-files
 525                  `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm"))
 526                    ("guix/store/schema.sql"
 527                     ,(local-file "../guix/store/schema.sql")))
 528
 529                  #:extensions (list guile-gcrypt)
 530                  #:guile-for-build guile-for-build))
 531
 532   (define *extra-modules*
 533     (scheme-node "guix-extra"
 534                  (filter-map (match-lambda
 535                                (('guix 'scripts _ ..1) #f)
 536                                (('guix 'man-db) #f)
 537                                (name name))
 538                              (scheme-modules* source "guix"))
 539                  (list *core-modules*)
 540                  #:extensions dependencies
 541                  #:guile-for-build guile-for-build))
 542
 543   (define *core-package-modules*
 544     (scheme-node "guix-packages-base"
 545                  `((gnu packages)
 546                    (gnu packages base))
 547                  (list *core-modules* *extra-modules*)
 548                  #:extensions dependencies
 549
 550                  ;; Add all the non-Scheme files here.  We must do it here so
 551                  ;; that 'search-patches' & co. can find them.  Ideally we'd
 552                  ;; keep them next to the .scm files that use them but it's
 553                  ;; difficult to do (XXX).
 554                  #:extra-files
 555                  (file-imports source "gnu/packages"
 556                                (lambda (file stat)
 557                                  (and (eq? 'regular (stat:type stat))
 558                                       (not (string-suffix? ".scm" file))
 559                                       (not (string-suffix? ".go" file))
 560                                       (not (string-prefix? ".#" file))
 561                                       (not (string-suffix? "~" file)))))
 562                  #:guile-for-build guile-for-build))
 563
 564   (define *package-modules*
 565     (scheme-node "guix-packages"
 566                  (scheme-modules* source "gnu/packages")
 567                  (list *core-modules* *extra-modules* *core-package-modules*)
 568                  #:extensions dependencies
 569                  #:guile-for-build guile-for-build))
 570
 571   (define *system-modules*
 572     (scheme-node "guix-system"
 573                  `((gnu system)
 574                    (gnu services)
 575                    ,@(scheme-modules* source "gnu/system")
 576                    ,@(scheme-modules* source "gnu/services"))
 577                  (list *core-package-modules* *package-modules*
 578                        *extra-modules* *core-modules*)
 579                  #:extensions dependencies
 580                  #:extra-files
 581                  (append (file-imports source "gnu/system/examples"
 582                                        (const #t))
 583
 584                          ;; Build-side code that we don't build.  Some of
 585                          ;; these depend on guile-rsvg, the Shepherd, etc.
 586                          (file-imports source "gnu/build" (const #t)))
 587                  #:guile-for-build
 588                  guile-for-build))
 589
 590   (define *cli-modules*
 591     (scheme-node "guix-cli"
 592                  (scheme-modules* source "/guix/scripts")
 593                  (list *core-modules* *extra-modules*
 594                        *core-package-modules* *package-modules*
 595                        *system-modules*)
 596                  #:extensions dependencies
 597                  #:guile-for-build guile-for-build))
 598
 599   (define *config*
 600     (scheme-node "guix-config"
 601                  '()
 602                  #:extra-modules
 603                  `(((guix config)
 604                     => ,(make-config.scm #:zlib zlib
 605                                          #:gzip gzip
 606                                          #:bzip2 bzip2
 607                                          #:xz xz
 608                                          #:package-name
 609                                          %guix-package-name
 610                                          #:package-version
 611                                          version
 612                                          #:bug-report-address
 613                                          %guix-bug-report-address
 614                                          #:home-page-url
 615                                          %guix-home-page-url)))
 616                  #:guile-for-build guile-for-build))
 617
 618   (define (built-modules node-subset)
 619     (directory-union (string-append name "-modules")
 620                      (append-map node-subset
 621
 622                                  ;; Note: *CONFIG* comes first so that it
 623                                  ;; overrides the (guix config) module that
 624                                  ;; comes with *CORE-MODULES*.
 625                                  (list *config*
 626                                        *cli-modules*
 627                                        *system-modules*
 628                                        *package-modules*
 629                                        *core-package-modules*
 630                                        *extra-modules*
 631                                        *core-modules*))
 632
 633                      ;; Silently choose the first entry upon collision so that
 634                      ;; we choose *CONFIG*.
 635                      #:resolve-collision 'first
 636
 637                      ;; When we do (add-to-store "utils.scm"), "utils.scm" must
 638                      ;; be a regular file, not a symlink.  Thus, arrange so that
 639                      ;; regular files appear as regular files in the final
 640                      ;; output.
 641                      #:copy? #t
 642                      #:quiet? #t))
 643
 644   ;; Version 0 of 'guix pull' meant we'd just return Scheme modules.
 645   ;; Version 1 is when we return the full package.
 646   (cond ((= 1 pull-version)
 647          ;; The whole package, with a standard file hierarchy.
 648          (let* ((modules  (built-modules (compose list node-source)))
 649                 (compiled (built-modules (compose list node-compiled)))
 650                 (command  (guix-command modules compiled
 651                                         #:source source
 652                                         #:dependencies dependencies
 653                                         #:guile guile-for-build
 654                                         #:guile-version guile-version)))
 655            (whole-package name modules dependencies
 656                           #:compiled-modules compiled
 657                           #:command command
 658                           #:guile guile-for-build
 659
 660                           ;; Include 'guix-daemon'.  XXX: Here we inject an
 661                           ;; older snapshot of guix-daemon, but that's a good
 662                           ;; enough approximation for now.
 663                           #:daemon (module-ref (resolve-interface
 664                                                 '(gnu packages
 665                                                       package-management))
 666                                                'guix-daemon)
 667
 668                           #:info (info-manual source)
 669                           #:guile-version guile-version)))
 670         ((= 0 pull-version)
 671          ;; Legacy 'guix pull': return the .scm and .go files as one
 672          ;; directory.
 673          (built-modules (lambda (node)
 674                           (list (node-source node)
 675                                 (node-compiled node)))))
 676         (else
 677          ;; Unsupported 'guix pull' version.
 678          #f)))
 679
 680 \f
 681 ;;;
 682 ;;; Generating (guix config).
 683 ;;;
 684
 685 (define %dependency-variables
 686   ;; (guix config) variables corresponding to dependencies.
 687   '(%libz %xz %gzip %bzip2))
 688
 689 (define %persona-variables
 690   ;; (guix config) variables that define Guix's persona.
 691   '(%guix-package-name
 692     %guix-version
 693     %guix-bug-report-address
 694     %guix-home-page-url))
 695
 696 (define %config-variables
 697   ;; (guix config) variables corresponding to Guix configuration.
 698   (letrec-syntax ((variables (syntax-rules ()
 699                                ((_)
 700                                 '())
 701                                ((_ variable rest ...)
 702                                 (cons `(variable . ,variable)
 703                                       (variables rest ...))))))
 704     (variables %localstatedir %storedir %sysconfdir %system)))
 705
 706 (define* (make-config.scm #:key zlib gzip xz bzip2
 707                           (package-name "GNU Guix")
 708                           (package-version "0")
 709                           (bug-report-address "bug-guix@gnu.org")
 710                           (home-page-url "https://gnu.org/s/guix"))
 711
 712   ;; Hack so that Geiser is not confused.
 713   (define defmod 'define-module)
 714
 715   (scheme-file "config.scm"
 716                #~(;; The following expressions get spliced.
 717                    (#$defmod (guix config)
 718                      #:export (%guix-package-name
 719                                %guix-version
 720                                %guix-bug-report-address
 721                                %guix-home-page-url
 722                                %store-directory
 723                                %state-directory
 724                                %store-database-directory
 725                                %config-directory
 726                                %libz
 727                                %gzip
 728                                %bzip2
 729                                %xz))
 730
 731                    #$@(map (match-lambda
 732                              ((name . value)
 733                               #~(define-public #$name #$value)))
 734                            %config-variables)
 735
 736                    (define %store-directory
 737                      (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
 738                          %storedir))
 739
 740                    (define %state-directory
 741                      ;; This must match `NIX_STATE_DIR' as defined in
 742                      ;; `nix/local.mk'.
 743                      (or (getenv "NIX_STATE_DIR")
 744                          (string-append %localstatedir "/guix")))
 745
 746                    (define %store-database-directory
 747                      (or (getenv "NIX_DB_DIR")
 748                          (string-append %state-directory "/db")))
 749
 750                    (define %config-directory
 751                      ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
 752                      ;; defined in `nix/local.mk'.
 753                      (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
 754                          (string-append %sysconfdir "/guix")))
 755
 756                    (define %guix-package-name #$package-name)
 757                    (define %guix-version #$package-version)
 758                    (define %guix-bug-report-address #$bug-report-address)
 759                    (define %guix-home-page-url #$home-page-url)
 760
 761                    (define %gzip
 762                      #+(and gzip (file-append gzip "/bin/gzip")))
 763                    (define %bzip2
 764                      #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
 765                    (define %xz
 766                      #+(and xz (file-append xz "/bin/xz")))
 767
 768                    (define %libz
 769                      #+(and zlib
 770                             (file-append zlib "/lib/libz"))))
 771
 772                ;; Guile 2.0 *requires* the 'define-module' to be at the
 773                ;; top-level or the 'toplevel-ref' in the resulting .go file are
 774                ;; made relative to a nonexistent anonymous module.
 775                #:splice? #t))
 776
 777
 778 \f
 779 ;;;
 780 ;;; Building.
 781 ;;;
 782
 783 (define* (compiled-modules name module-tree module-files
 784                            #:optional
 785                            (dependencies '())
 786                            (dependencies-compiled '())
 787                            #:key
 788                            (extensions '())       ;full-blown Guile packages
 789                            parallel?
 790                            guile-for-build)
 791   "Build all the MODULE-FILES from MODULE-TREE.  MODULE-FILES must be a list
 792 like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory
 793 containing MODULE-FILES and possibly other files as well."
 794   ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix
 795   ;; gexp).
 796   (define build
 797     (with-imported-modules (source-module-closure
 798                             '((guix build compile)
 799                               (guix build utils)))
 800       #~(begin
 801           (use-modules (srfi srfi-26)
 802                        (ice-9 match)
 803                        (ice-9 format)
 804                        (ice-9 threads)
 805                        (guix build compile)
 806                        (guix build utils))
 807
 808           (define (regular? file)
 809             (not (member file '("." ".."))))
 810
 811           (define (report-load file total completed)
 812             (display #\cr)
 813             (format #t
 814                     "loading...\t~5,1f% of ~d files" ;FIXME: i18n
 815                     (* 100. (/ completed total)) total)
 816             (force-output))
 817
 818           (define (report-compilation file total completed)
 819             (display #\cr)
 820             (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
 821                     (* 100. (/ completed total)) total)
 822             (force-output))
 823
 824           (define (process-directory directory files output)
 825             ;; Hide compilation warnings.
 826             (parameterize ((current-warning-port (%make-void-port "w")))
 827               (compile-files directory #$output files
 828                              #:workers (parallel-job-count)
 829                              #:report-load report-load
 830                              #:report-compilation report-compilation)))
 831
 832           (setvbuf (current-output-port) _IONBF)
 833           (setvbuf (current-error-port) _IONBF)
 834
 835           (set! %load-path (cons #+module-tree %load-path))
 836           (set! %load-path
 837             (append '#+dependencies
 838                     (map (lambda (extension)
 839                            (string-append extension "/share/guile/site/"
 840                                           (effective-version)))
 841                          '#+extensions)
 842                     %load-path))
 843
 844           (set! %load-compiled-path
 845             (append '#+dependencies-compiled
 846                     (map (lambda (extension)
 847                            (string-append extension "/lib/guile/"
 848                                           (effective-version)
 849                                           "/site-ccache"))
 850                          '#+extensions)
 851                     %load-compiled-path))
 852
 853           ;; Load the compiler modules upfront.
 854           (compile #f)
 855
 856           (mkdir #$output)
 857           (chdir #+module-tree)
 858           (process-directory "." '#+module-files #$output)
 859           (newline))))
 860
 861   (computed-file name build
 862                  #:guile guile-for-build
 863                  #:options
 864                  `(#:local-build? #f              ;allow substitutes
 865
 866                    ;; Don't annoy people about _IONBF deprecation.
 867                    ;; Initialize 'terminal-width' in (system repl debug)
 868                    ;; to a large-enough value to make backtrace more
 869                    ;; verbose.
 870                    #:env-vars (("GUILE_WARN_DEPRECATED" . "no")
 871                                ("COLUMNS" . "200")))))
 872
 873 \f
 874 ;;;
 875 ;;; Building.
 876 ;;;
 877
 878 (define (guile-for-build version)
 879   "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
 880 running Guile."
 881   (define canonical-package                       ;soft reference
 882     (module-ref (resolve-interface '(gnu packages base))
 883                 'canonical-package))
 884
 885   (match version
 886     ("2.2.2"
 887      ;; Gross hack to avoid ABI incompatibilities (see
 888      ;; <https://bugs.gnu.org/29570>.)
 889      (module-ref (resolve-interface '(gnu packages guile))
 890                  'guile-2.2.2))
 891     ("2.2"
 892      ;; Use the latest version, which has fixes for
 893      ;; <https://bugs.gnu.org/30602> and VM stack-marking issues.
 894      (canonical-package (module-ref (resolve-interface '(gnu packages guile))
 895                                     'guile-2.2.4)))
 896     ("2.0"
 897      (module-ref (resolve-interface '(gnu packages guile))
 898                  'guile-2.0))))
 899
 900 (define* (guix-derivation source version
 901                           #:optional (guile-version (effective-version))
 902                           #:key (pull-version 0))
 903   "Return, as a monadic value, the derivation to build the Guix from SOURCE
 904 for GUILE-VERSION.  Use VERSION as the version string.  PULL-VERSION specifies
 905 the version of the 'guix pull' protocol.  Return #f if this PULL-VERSION value
 906 is not supported."
 907   (define (shorten version)
 908     (if (and (string-every char-set:hex-digit version)
 909              (> (string-length version) 9))
 910         (string-take version 9)                   ;Git commit
 911         version))
 912
 913   (define guile
 914     ;; When PULL-VERSION >= 1, produce a self-contained Guix and use Guile 2.2
 915     ;; unconditionally.
 916     (guile-for-build (if (>= pull-version 1)
 917                          "2.2"
 918                          guile-version)))
 919
 920   (mbegin %store-monad
 921     (set-guile-for-build guile)
 922     (let ((guix (compiled-guix source
 923                                #:version version
 924                                #:name (string-append "guix-"
 925                                                      (shorten version))
 926                                #:pull-version pull-version
 927                                #:guile-version (if (>= pull-version 1)
 928                                                    "2.2"
 929                                                    (match guile-version
 930                                                      ("2.2.2" "2.2")
 931                                                      (version version)))
 932                                #:guile-for-build guile)))
 933       (if guix
 934           (lower-object guix)
 935           (return #f)))))