;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (guix self) #:use-module (guix config) #:use-module (guix i18n) #:use-module (guix modules) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix discovery) #:use-module (guix packages) #:use-module (guix sets) #:use-module (guix utils) #:use-module (guix modules) #:use-module (guix build utils) #:use-module ((guix build compile) #:select (%lightweight-optimizations)) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:export (compiled-guix guix-derivation reload-guix)) ;;; ;;; Dependency handling. ;;; (define* (false-if-wrong-guile package #:optional (guile-version (effective-version))) "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., 2.0 instead of 2.2), otherwise return PACKAGE." (let ((guile (any (match-lambda ((label (? package? dep) _ ...) (and (string=? (package-name dep) "guile") dep))) (package-direct-inputs package)))) (and (or (not guile) (string-prefix? guile-version (package-version guile))) package))) (define (package-for-guile guile-version . names) "Return the package with one of the given NAMES that depends on GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." (let loop ((names names)) (match names (() #f) ((name rest ...) (match (specification->package name) (#f (loop rest)) ((? package? package) (or (false-if-wrong-guile package) (loop rest)))))))) ;;; ;;; Derivations. ;;; ;; Node in a DAG of build tasks. Each node maps to a derivation, but it's ;; easier to express things this way. (define-record-type (node name modules source dependencies compiled) node? (name node-name) ;string (modules node-modules) ;list of module names (source node-source) ;list of source files (dependencies node-dependencies) ;list of nodes (compiled node-compiled)) ;node -> lowerable object (define (node-fold proc init nodes) (let loop ((nodes nodes) (visited (setq)) (result init)) (match nodes (() result) ((head tail ...) (if (set-contains? visited head) (loop tail visited result) (loop tail (set-insert head visited) (proc head result))))))) (define (node-modules/recursive nodes) (node-fold (lambda (node modules) (append (node-modules node) modules)) '() nodes)) (define* (closure modules #:optional (except '())) (source-module-closure modules #:select? (match-lambda (('guix 'config) #f) ((and module (or ('guix _ ...) ('gnu _ ...))) (not (member module except))) (rest #f)))) (define module->import ;; Return a file-name/file-like object pair for the specified module and ;; suitable for 'imported-files'. (match-lambda ((module '=> thing) (let ((file (module-name->file-name module))) (list file thing))) (module (let ((file (module-name->file-name module))) (list file (local-file (search-path %load-path file))))))) (define* (scheme-node name modules #:optional (dependencies '()) #:key (extra-modules '()) (extra-files '()) (extensions '()) parallel? guile-for-build) "Return a node that builds the given Scheme MODULES, and depends on DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules added to the source, and EXTRA-FILES is a list of additional files. EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that must be present in the search path." (let* ((modules (append extra-modules (closure modules (node-modules/recursive dependencies)))) (module-files (map module->import modules)) (source (imported-files (string-append name "-source") (append module-files extra-files)))) (node name modules source dependencies (compiled-modules name source modules (map node-source dependencies) (map node-compiled dependencies) #:extensions extensions #:parallel? parallel? #:guile-for-build guile-for-build)))) (define (file-imports directory sub-directory pred) "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a list of file-name/file-like objects suitable as inputs to 'imported-files'." (map (lambda (file) (list (string-drop file (+ 1 (string-length directory))) (local-file file #:recursive? #t))) (find-files (string-append directory "/" sub-directory) pred))) (define (scheme-modules* directory sub-directory) "Return the list of module names found under SUB-DIRECTORY in DIRECTORY." (let ((prefix (string-length directory))) (map (lambda (file) (file-name->module-name (string-drop file prefix))) (scheme-files (string-append directory "/" sub-directory))))) (define* (compiled-guix source #:key (version %guix-version) (guile-version (effective-version)) (guile-for-build (guile-for-build guile-version)) (libgcrypt (specification->package "libgcrypt")) (zlib (specification->package "zlib")) (gzip (specification->package "gzip")) (bzip2 (specification->package "bzip2")) (xz (specification->package "xz"))) "Return a file-like object that contains a compiled Guix." (define guile-json (package-for-guile guile-version "guile-json" "guile2.2-json" "guile2.0-json")) (define guile-ssh (package-for-guile guile-version "guile-ssh" "guile2.2-ssh" "guile2.0-ssh")) (define guile-git (package-for-guile guile-version "guile-git" "guile2.0-git")) (define dependencies (match (append-map (lambda (package) (cons (list "x" package) (package-transitive-inputs package))) (list guile-git guile-json guile-ssh)) (((labels packages _ ...) ...) packages))) (define *core-modules* (scheme-node "guix-core" '((guix) (guix monad-repl) (guix packages) (guix download) (guix discovery) (guix profiles) (guix build-system gnu) (guix build-system trivial) (guix build profiles) (guix build gnu-build-system)) ;; Provide a dummy (guix config) with the default version ;; number, storedir, etc. This is so that "guix-core" is the ;; same across all installations and doesn't need to be ;; rebuilt when the version changes, which in turn means we ;; can have substitutes for it. #:extra-modules `(((guix config) => ,(make-config.scm #:libgcrypt (specification->package "libgcrypt")))) #:guile-for-build guile-for-build)) (define *extra-modules* (scheme-node "guix-extra" (filter-map (match-lambda (('guix 'scripts _ ..1) #f) (name name)) (scheme-modules* source "guix")) (list *core-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) (define *package-modules* (scheme-node "guix-packages" `((gnu packages) ,@(scheme-modules* source "gnu/packages")) (list *core-modules* *extra-modules*) #:extra-files ;all the non-Scheme files (file-imports source "gnu/packages" (lambda (file stat) (and (eq? 'regular (stat:type stat)) (not (string-suffix? ".scm" file)) (not (string-suffix? ".go" file)) (not (string-prefix? ".#" file)) (not (string-suffix? "~" file))))) #:guile-for-build guile-for-build)) (define *system-modules* (scheme-node "guix-system" `((gnu system) (gnu services) ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services")) (list *package-modules* *extra-modules* *core-modules*) #:extra-files (file-imports source "gnu/system/examples" (const #t)) #:guile-for-build guile-for-build)) (define *cli-modules* (scheme-node "guix-cli" (scheme-modules* source "/guix/scripts") (list *core-modules* *extra-modules* *package-modules* *system-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) (define *config* (scheme-node "guix-config" '() #:extra-modules `(((guix config) => ,(make-config.scm #:libgcrypt libgcrypt #:zlib zlib #:gzip gzip #:bzip2 bzip2 #:xz xz #:package-name %guix-package-name #:package-version version #:bug-report-address %guix-bug-report-address #:home-page-url %guix-home-page-url))) #:guile-for-build guile-for-build)) (directory-union (string-append "guix-" version) (append-map (lambda (node) (list (node-source node) (node-compiled node))) ;; Note: *CONFIG* comes first so that it ;; overrides the (guix config) module that ;; comes with *CORE-MODULES*. (list *config* *cli-modules* *system-modules* *package-modules* *extra-modules* *core-modules*)) ;; When we do (add-to-store "utils.scm"), "utils.scm" must ;; be a regular file, not a symlink. Thus, arrange so that ;; regular files appear as regular files in the final ;; output. #:copy? #t #:quiet? #t)) ;;; ;;; (guix config) generation. ;;; (define %dependency-variables ;; (guix config) variables corresponding to dependencies. '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate)) (define %persona-variables ;; (guix config) variables that define Guix's persona. '(%guix-package-name %guix-version %guix-bug-report-address %guix-home-page-url)) (define %config-variables ;; (guix config) variables corresponding to Guix configuration (storedir, ;; localstatedir, etc.) (sort (filter pair? (module-map (lambda (name var) (and (not (memq name %dependency-variables)) (not (memq name %persona-variables)) (cons name (variable-ref var)))) (resolve-interface '(guix config)))) (lambda (name+value1 name+value2) (stringstring (car name+value1)) (symbol->string (car name+value2)))))) (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") (home-page-url "https://gnu.org/s/guix")) ;; Hack so that Geiser is not confused. (define defmod 'define-module) (scheme-file "config.scm" #~(begin (#$defmod (guix config) #:export (%guix-package-name %guix-version %guix-bug-report-address %guix-home-page-url %libgcrypt %libz %gzip %bzip2 %xz %nix-instantiate)) ;; XXX: Work around . (eval-when (expand load eval) #$@(map (match-lambda ((name . value) #~(define-public #$name #$value))) %config-variables) (define %guix-package-name #$package-name) (define %guix-version #$package-version) (define %guix-bug-report-address #$bug-report-address) (define %guix-home-page-url #$home-page-url) (define %gzip #+(and gzip (file-append gzip "/bin/gzip"))) (define %bzip2 #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) (define %xz #+(and xz (file-append xz "/bin/xz"))) (define %libgcrypt #+(and libgcrypt (file-append libgcrypt "/lib/libgcrypt"))) (define %libz #+(and zlib (file-append zlib "/lib/libz"))) (define %nix-instantiate ;for (guix import snix) "nix-instantiate"))))) ;;; ;;; Building. ;;; (define (imported-files name files) ;; This is a non-monadic, simplified version of 'imported-files' from (guix ;; gexp). (define build (with-imported-modules (source-module-closure '((guix build utils))) #~(begin (use-modules (ice-9 match) (guix build utils)) (mkdir (ungexp output)) (chdir (ungexp output)) (for-each (match-lambda ((final-path store-path) (mkdir-p (dirname final-path)) ;; Note: We need regular files to be regular files, not ;; symlinks, as this makes a difference for ;; 'add-to-store'. (copy-file store-path final-path))) '#$files)))) (computed-file name build)) (define* (compiled-modules name module-tree modules #:optional (dependencies '()) (dependencies-compiled '()) #:key (extensions '()) ;full-blown Guile packages parallel? guile-for-build) ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix ;; gexp). (define build (with-imported-modules (source-module-closure '((guix build compile) (guix build utils))) #~(begin (use-modules (srfi srfi-26) (ice-9 match) (ice-9 format) (ice-9 threads) (guix build compile) (guix build utils)) (define (regular? file) (not (member file '("." "..")))) (define (report-load file total completed) (display #\cr) (format #t "loading...\t~5,1f% of ~d files" ;FIXME: i18n (* 100. (/ completed total)) total) (force-output)) (define (report-compilation file total completed) (display #\cr) (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n (* 100. (/ completed total)) total) (force-output)) (define (process-directory directory output) (let ((files (find-files directory "\\.scm$")) (prefix (+ 1 (string-length directory)))) ;; Hide compilation warnings. (parameterize ((current-warning-port (%make-void-port "w"))) (compile-files directory #$output (map (cut string-drop <> prefix) files) #:workers (parallel-job-count) #:report-load report-load #:report-compilation report-compilation)))) (setvbuf (current-output-port) _IONBF) (setvbuf (current-error-port) _IONBF) (set! %load-path (cons #+module-tree %load-path)) (set! %load-path (append '#+dependencies (map (lambda (extension) (string-append extension "/share/guile/site/" (effective-version))) '#+extensions) %load-path)) (set! %load-compiled-path (append '#+dependencies-compiled (map (lambda (extension) (string-append extension "/lib/guile/" (effective-version) "/site-ccache")) '#+extensions) %load-compiled-path)) ;; Load the compiler modules upfront. (compile #f) (mkdir #$output) (chdir #+module-tree) (process-directory "." #$output)))) (computed-file name build #:guile guile-for-build #:options `(#:local-build? #f ;allow substitutes ;; Don't annoy people about _IONBF deprecation. #:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) ;;; ;;; Live patching. ;;; (define (recursive-submodules module) "Return the list of submodules of MODULE." (let loop ((module module) (result '())) (let ((submodules (hash-map->list (lambda (name module) module) (module-submodules module)))) (fold loop (append submodules result) submodules)))) (define (remove-submodule! module names) (let loop ((module module) (names names)) (match names (() #t) ((head tail ...) (match (nested-ref-module module tail) (#f #t) ((? module? submodule) (hashq-remove! (module-submodules module) head) (loop submodule tail))))))) (define (unload-module-tree! module) (define (strip-prefix prefix lst) (let loop ((prefix prefix) (lst lst)) (match prefix (() lst) ((_ prefix ...) (match lst ((_ lst ...) (loop prefix lst))))))) (let ((submodules (hash-map->list (lambda (name module) module) (module-submodules module)))) (let loop ((root module) (submodules submodules)) (match submodules (() #t) ((head tail ...) (unload-module-tree! head) (remove-submodule! root (strip-prefix (module-name root) (module-name head))) (match (module-name head) ((parents ... leaf) ;; Remove MODULE from the AUTOLOADS-DONE list. Note: We don't use ;; 'module-filename' because it could be an absolute file name. (set-autoloaded! (string-join (map symbol->string parents) "/" 'suffix) (symbol->string leaf) #f))) (loop root tail)))))) (define* (reload-guix #:optional (log-port (current-error-port))) "Reload all the Guix and GNU modules currently loaded." ;; Caveat! Until we've reloaded all the guix and gnu modules, we cannot rely ;; on bindings coming from guix/gnu modules, except for (guix self), because ;; the other modules might be outdated. (let* ((guix (resolve-module '(guix) #f #f #:ensure #f)) (gnu (resolve-module '(gnu) #f #f #:ensure #f)) (guix-submodules (recursive-submodules guix)) (gnu-submodules (recursive-submodules gnu))) (define (reload module) ;; Reload MODULE, unless it's already been reloaded indirectly in the ;; meantime. (unless (resolve-module (module-name module) #f #f #:ensure #f) (match (module-filename module) (#f #f) ((? string? file) (primitive-load (search-path %load-path file)))))) ;; First, we need to nuke all the (guix) and (gnu) submodules so we don't ;; end up with a mixture of old and new modules when we reload (which ;; wouldn't work, because we'd have two different record types, ;; for instance.) (format log-port (G_ "Unloading current modules...~%")) (unload-module-tree! gnu) (unload-module-tree! guix) ;; When reloading, we compile the core modules and interpret the rest. ;; This appears to be the most efficient approach. (format log-port (G_ "Loading new modules...~%")) (set! %auto-compilation-options %lightweight-optimizations) (reload (resolve-module '(guix packages))) (set! %load-should-auto-compile #f) (for-each reload (append guix-submodules (list guix))) (for-each reload (append gnu-submodules (list gnu))) (format log-port (G_ "New modules successfully loaded.~%")))) ;;; ;;; Building. ;;; (define (guile-for-build version) "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently running Guile." (define canonical-package ;soft reference (module-ref (resolve-interface '(gnu packages base)) 'canonical-package)) (match version ("2.2" ;; Use the same 2.2 variant for everyone so that people can get ;; substitutes, and also to avoid ABI incompatibilities (see ;; .) (canonical-package (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.2/fixed))) ("2.0" (canonical-package (specification->package "guile@2.0"))))) (define* (guix-derivation source version #:optional (guile-version (effective-version))) "Return, as a monadic value, the derivation to build the Guix from SOURCE for GUILE-VERSION. Use VERSION as the version string." (define max-version-length 9) (define (shorten version) ;; TODO: VERSION is a commit id, but we'd rather use something like what ;; 'git describe' provides. (if (> (string-length version) max-version-length) (string-take version max-version-length) version)) (mbegin %store-monad (set-guile-for-build (guile-for-build guile-version)) (lower-object (compiled-guix source #:version (shorten version) #:guile-version guile-version))))