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       ("gnutls"     (ref '(gnu packages tls) 'gnutls))
  87       ("libgcrypt"  (ref '(gnu packages gnupg) 'libgcrypt))
  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                         (libgcrypt (specification->package "libgcrypt"))
 458                         (zlib (specification->package "zlib"))
 459                         (gzip (specification->package "gzip"))
 460                         (bzip2 (specification->package "bzip2"))
 461                         (xz (specification->package "xz"))
 462                         (guix (specification->package "guix")))
 463   "Return a file-like object that contains a compiled Guix."
 464   (define guile-json
 465     (package-for-guile guile-version
 466                        "guile-json"
 467                        "guile2.0-json"))
 468
 469   (define guile-ssh
 470     (package-for-guile guile-version
 471                        "guile-ssh"
 472                        "guile2.0-ssh"))
 473
 474   (define guile-git
 475     (package-for-guile guile-version
 476                        "guile-git"
 477                        "guile2.0-git"))
 478
 479   (define guile-sqlite3
 480     (package-for-guile guile-version
 481                        "guile-sqlite3"
 482                        "guile2.0-sqlite3"))
 483
 484   (define gnutls
 485     (package-for-guile guile-version
 486                        "gnutls" "guile2.0-gnutls"))
 487
 488   (define dependencies
 489     (match (append-map (lambda (package)
 490                          (cons (list "x" package)
 491                                (package-transitive-propagated-inputs package)))
 492                        (list gnutls guile-git guile-json
 493                              guile-ssh guile-sqlite3))
 494       (((labels packages _ ...) ...)
 495        packages)))
 496
 497   (define *core-modules*
 498     (scheme-node "guix-core"
 499                  '((guix)
 500                    (guix monad-repl)
 501                    (guix packages)
 502                    (guix download)
 503                    (guix discovery)
 504                    (guix profiles)
 505                    (guix build-system gnu)
 506                    (guix build-system trivial)
 507                    (guix build profiles)
 508                    (guix build gnu-build-system))
 509
 510                  ;; Provide a dummy (guix config) with the default version
 511                  ;; number, storedir, etc.  This is so that "guix-core" is the
 512                  ;; same across all installations and doesn't need to be
 513                  ;; rebuilt when the version changes, which in turn means we
 514                  ;; can have substitutes for it.
 515                  #:extra-modules
 516                  `(((guix config)
 517                     => ,(make-config.scm #:libgcrypt
 518                                          (specification->package
 519                                           "libgcrypt"))))
 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                  #:guile-for-build guile-for-build))
 530
 531   (define *extra-modules*
 532     (scheme-node "guix-extra"
 533                  (filter-map (match-lambda
 534                                (('guix 'scripts _ ..1) #f)
 535                                (('guix 'man-db) #f)
 536                                (name name))
 537                              (scheme-modules* source "guix"))
 538                  (list *core-modules*)
 539                  #:extensions dependencies
 540                  #:guile-for-build guile-for-build))
 541
 542   (define *core-package-modules*
 543     (scheme-node "guix-packages-base"
 544                  `((gnu packages)
 545                    (gnu packages base))
 546                  (list *core-modules* *extra-modules*)
 547                  #:extensions dependencies
 548
 549                  ;; Add all the non-Scheme files here.  We must do it here so
 550                  ;; that 'search-patches' & co. can find them.  Ideally we'd
 551                  ;; keep them next to the .scm files that use them but it's
 552                  ;; difficult to do (XXX).
 553                  #:extra-files
 554                  (file-imports source "gnu/packages"
 555                                (lambda (file stat)
 556                                  (and (eq? 'regular (stat:type stat))
 557                                       (not (string-suffix? ".scm" file))
 558                                       (not (string-suffix? ".go" file))
 559                                       (not (string-prefix? ".#" file))
 560                                       (not (string-suffix? "~" file)))))
 561                  #:guile-for-build guile-for-build))
 562
 563   (define *package-modules*
 564     (scheme-node "guix-packages"
 565                  (scheme-modules* source "gnu/packages")
 566                  (list *core-modules* *extra-modules* *core-package-modules*)
 567                  #:extensions dependencies
 568                  #:guile-for-build guile-for-build))
 569
 570   (define *system-modules*
 571     (scheme-node "guix-system"
 572                  `((gnu system)
 573                    (gnu services)
 574                    ,@(scheme-modules* source "gnu/system")
 575                    ,@(scheme-modules* source "gnu/services"))
 576                  (list *core-package-modules* *package-modules*
 577                        *extra-modules* *core-modules*)
 578                  #:extensions dependencies
 579                  #:extra-files
 580                  (append (file-imports source "gnu/system/examples"
 581                                        (const #t))
 582
 583                          ;; Build-side code that we don't build.  Some of
 584                          ;; these depend on guile-rsvg, the Shepherd, etc.
 585                          (file-imports source "gnu/build" (const #t)))
 586                  #:guile-for-build
 587                  guile-for-build))
 588
 589   (define *cli-modules*
 590     (scheme-node "guix-cli"
 591                  (scheme-modules* source "/guix/scripts")
 592                  (list *core-modules* *extra-modules*
 593                        *core-package-modules* *package-modules*
 594                        *system-modules*)
 595                  #:extensions dependencies
 596                  #:guile-for-build guile-for-build))
 597
 598   (define *config*
 599     (scheme-node "guix-config"
 600                  '()
 601                  #:extra-modules
 602                  `(((guix config)
 603                     => ,(make-config.scm #:libgcrypt libgcrypt
 604                                          #: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   '(%libgcrypt %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 libgcrypt 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                                %libgcrypt
 727                                %libz
 728                                %gzip
 729                                %bzip2
 730                                %xz))
 731
 732                    #$@(map (match-lambda
 733                              ((name . value)
 734                               #~(define-public #$name #$value)))
 735                            %config-variables)
 736
 737                    (define %store-directory
 738                      (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
 739                          %storedir))
 740
 741                    (define %state-directory
 742                      ;; This must match `NIX_STATE_DIR' as defined in
 743                      ;; `nix/local.mk'.
 744                      (or (getenv "NIX_STATE_DIR")
 745                          (string-append %localstatedir "/guix")))
 746
 747                    (define %store-database-directory
 748                      (or (getenv "NIX_DB_DIR")
 749                          (string-append %state-directory "/db")))
 750
 751                    (define %config-directory
 752                      ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
 753                      ;; defined in `nix/local.mk'.
 754                      (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
 755                          (string-append %sysconfdir "/guix")))
 756
 757                    (define %guix-package-name #$package-name)
 758                    (define %guix-version #$package-version)
 759                    (define %guix-bug-report-address #$bug-report-address)
 760                    (define %guix-home-page-url #$home-page-url)
 761
 762                    (define %gzip
 763                      #+(and gzip (file-append gzip "/bin/gzip")))
 764                    (define %bzip2
 765                      #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
 766                    (define %xz
 767                      #+(and xz (file-append xz "/bin/xz")))
 768
 769                    (define %libgcrypt
 770                      #+(and libgcrypt
 771                             (file-append libgcrypt "/lib/libgcrypt")))
 772                    (define %libz
 773                      #+(and zlib
 774                             (file-append zlib "/lib/libz"))))
 775
 776                ;; Guile 2.0 *requires* the 'define-module' to be at the
 777                ;; top-level or the 'toplevel-ref' in the resulting .go file are
 778                ;; made relative to a nonexistent anonymous module.
 779                #:splice? #t))
 780
 781
 782 \f
 783 ;;;
 784 ;;; Building.
 785 ;;;
 786
 787 (define* (compiled-modules name module-tree module-files
 788                            #:optional
 789                            (dependencies '())
 790                            (dependencies-compiled '())
 791                            #:key
 792                            (extensions '())       ;full-blown Guile packages
 793                            parallel?
 794                            guile-for-build)
 795   "Build all the MODULE-FILES from MODULE-TREE.  MODULE-FILES must be a list
 796 like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory
 797 containing MODULE-FILES and possibly other files as well."
 798   ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix
 799   ;; gexp).
 800   (define build
 801     (with-imported-modules (source-module-closure
 802                             '((guix build compile)
 803                               (guix build utils)))
 804       #~(begin
 805           (use-modules (srfi srfi-26)
 806                        (ice-9 match)
 807                        (ice-9 format)
 808                        (ice-9 threads)
 809                        (guix build compile)
 810                        (guix build utils))
 811
 812           (define (regular? file)
 813             (not (member file '("." ".."))))
 814
 815           (define (report-load file total completed)
 816             (display #\cr)
 817             (format #t
 818                     "loading...\t~5,1f% of ~d files" ;FIXME: i18n
 819                     (* 100. (/ completed total)) total)
 820             (force-output))
 821
 822           (define (report-compilation file total completed)
 823             (display #\cr)
 824             (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
 825                     (* 100. (/ completed total)) total)
 826             (force-output))
 827
 828           (define (process-directory directory files output)
 829             ;; Hide compilation warnings.
 830             (parameterize ((current-warning-port (%make-void-port "w")))
 831               (compile-files directory #$output files
 832                              #:workers (parallel-job-count)
 833                              #:report-load report-load
 834                              #:report-compilation report-compilation)))
 835
 836           (setvbuf (current-output-port) _IONBF)
 837           (setvbuf (current-error-port) _IONBF)
 838
 839           (set! %load-path (cons #+module-tree %load-path))
 840           (set! %load-path
 841             (append '#+dependencies
 842                     (map (lambda (extension)
 843                            (string-append extension "/share/guile/site/"
 844                                           (effective-version)))
 845                          '#+extensions)
 846                     %load-path))
 847
 848           (set! %load-compiled-path
 849             (append '#+dependencies-compiled
 850                     (map (lambda (extension)
 851                            (string-append extension "/lib/guile/"
 852                                           (effective-version)
 853                                           "/site-ccache"))
 854                          '#+extensions)
 855                     %load-compiled-path))
 856
 857           ;; Load the compiler modules upfront.
 858           (compile #f)
 859
 860           (mkdir #$output)
 861           (chdir #+module-tree)
 862           (process-directory "." '#+module-files #$output)
 863           (newline))))
 864
 865   (computed-file name build
 866                  #:guile guile-for-build
 867                  #:options
 868                  `(#:local-build? #f              ;allow substitutes
 869
 870                    ;; Don't annoy people about _IONBF deprecation.
 871                    ;; Initialize 'terminal-width' in (system repl debug)
 872                    ;; to a large-enough value to make backtrace more
 873                    ;; verbose.
 874                    #:env-vars (("GUILE_WARN_DEPRECATED" . "no")
 875                                ("COLUMNS" . "200")))))
 876
 877 \f
 878 ;;;
 879 ;;; Building.
 880 ;;;
 881
 882 (define (guile-for-build version)
 883   "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
 884 running Guile."
 885   (define canonical-package                       ;soft reference
 886     (module-ref (resolve-interface '(gnu packages base))
 887                 'canonical-package))
 888
 889   (match version
 890     ("2.2"
 891      (canonical-package (module-ref (resolve-interface '(gnu packages guile))
 892                                     'guile-2.2)))
 893     ("2.0"
 894      (module-ref (resolve-interface '(gnu packages guile))
 895                  'guile-2.0))))
 896
 897 (define* (guix-derivation source version
 898                           #:optional (guile-version (effective-version))
 899                           #:key (pull-version 0))
 900   "Return, as a monadic value, the derivation to build the Guix from SOURCE
 901 for GUILE-VERSION.  Use VERSION as the version string.  PULL-VERSION specifies
 902 the version of the 'guix pull' protocol.  Return #f if this PULL-VERSION value
 903 is not supported."
 904   (define (shorten version)
 905     (if (and (string-every char-set:hex-digit version)
 906              (> (string-length version) 9))
 907         (string-take version 9)                   ;Git commit
 908         version))
 909
 910   (define guile
 911     (guile-for-build guile-version))
 912
 913   (mbegin %store-monad
 914     (set-guile-for-build guile)
 915     (let ((guix (compiled-guix source
 916                                #:version version
 917                                #:name (string-append "guix-"
 918                                                      (shorten version))
 919                                #:pull-version pull-version
 920                                #:guile-version guile-version
 921                                #:guile-for-build guile)))
 922       (if guix
 923           (lower-object guix)
 924           (return #f)))))