[jackhill/guix/guix.git] / build-aux / build-self.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(define-module (build-self)
  #:use-module (gnu)
  #:use-module (guix)
  #:use-module (guix ui)
  #:use-module (guix config)
  #:use-module (guix modules)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:export (build))

;;; Commentary:
;;;
;;; When loaded, this module returns a monadic procedure of at least one
;;; argument: the source tree to build.  It returns a derivation that
;;; builds it.
;;;
;;; This file uses modules provided by the already-installed Guix.  Those
;;; modules may be arbitrarily old compared to the version we want to
;;; build.  Because of that, it must rely on the smallest set of features
;;; that are likely to be provided by the (guix) and (gnu) modules, and by
;;; Guile itself, forever and ever.
;;;
;;; Code:

\f
;;;
;;; Generating (guix config).
;;;
;;; This is copied from (guix self) because we cannot assume (guix self) is
;;; available at this point.
;;;

(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)
          (string<? (symbol->string (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 <http://bugs.gnu.org/15602>.
                   (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")))))

\f
;;;
;;; 'gexp->script'.
;;;
;;; This is our own variant of 'gexp->script' with an extra #:module-path
;;; parameter, which was unavailable in (guix gexp) until commit
;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
;;;

(define (load-path-expression modules path)
  "Return as a monadic value a gexp that sets '%load-path' and
'%load-compiled-path' to point to MODULES, a list of module names.  MODULES
are searched for in PATH."
  (mlet %store-monad ((modules  (imported-modules modules
                                                  #:module-path path))
                      (compiled (compiled-modules modules
                                                  #:module-path path)))
    (return (gexp (eval-when (expand load eval)
                    (set! %load-path
                      (cons (ungexp modules) %load-path))
                    (set! %load-compiled-path
                      (cons (ungexp compiled)
                            %load-compiled-path)))))))

(define* (gexp->script name exp
                       #:key (guile (default-guile))
                       (module-path %load-path))
  "Return an executable script NAME that runs EXP using GUILE, with EXP's
imported modules in its search path."
  (mlet %store-monad ((set-load-path
                       (load-path-expression (gexp-modules exp)
                                             module-path)))
    (gexp->derivation name
                      (gexp
                       (call-with-output-file (ungexp output)
                         (lambda (port)
                           ;; Note: that makes a long shebang.  When the store
                           ;; is /gnu/store, that fits within the 128-byte
                           ;; limit imposed by Linux, but that may go beyond
                           ;; when running tests.
                           (format port
                                   "#!~a/bin/guile --no-auto-compile~%!#~%"
                                   (ungexp guile))

                           (write '(ungexp set-load-path) port)
                           (write '(ungexp exp) port)
                           (chmod port #o555))))
                      #:module-path module-path)))

\f
(define (date-version-string)
  "Return the current date and hour in UTC timezone, for use as a poor
person's version identifier."
  ;; XXX: Replace with a Git commit id.
  (date->string (current-date 0) "~Y~m~d.~H"))

(define* (build-program source version
                        #:optional (guile-version (effective-version)))
  "Return a program that computes the derivation to build Guix from SOURCE."
  (define select?
    ;; Select every module but (guix config) and non-Guix modules.
    (match-lambda
      (('guix 'config) #f)
      (('guix _ ...)   #t)
      (('gnu _ ...)    #t)
      (_               #f)))

  (with-imported-modules `(((guix config)
                            => ,(make-config.scm
                                 #:libgcrypt
                                 (specification->package "libgcrypt")))
                           ,@(source-module-closure `((guix store)
                                                      (guix self)
                                                      (guix derivations)
                                                      (gnu packages bootstrap))
                                                    (list source)
                                                    #:select? select?))
    (gexp->script "compute-guix-derivation"
                  #~(begin
                      (use-modules (ice-9 match))

                      (eval-when (expand load eval)
                        ;; Don't augment '%load-path'.
                        (unsetenv "GUIX_PACKAGE_PATH")

                        ;; (gnu packages …) modules are going to be looked up
                        ;; under SOURCE.  (guix config) is looked up in FRONT.
                        (match %load-path
                          ((#$source _ ...)
                           #t)                    ;already done
                          ((front _ ...)
                           (set! %load-path (list #$source front))))

                        ;; Only load our own modules or those of Guile.
                        (match %load-compiled-path
                          ((front _ ... sys1 sys2)
                           (set! %load-compiled-path
                             (list front sys1 sys2)))))

                      (use-modules (guix store)
                                   (guix self)
                                   (guix derivations)
                                   (srfi srfi-1))

                      (define (spin system)
                        (define spin
                          (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))

                        (format (current-error-port)
                                "Computing Guix derivation for '~a'...  "
                                system)
                        (let loop ((spin spin))
                          (display (string-append "\b" (car spin))
                                   (current-error-port))
                          (force-output (current-error-port))
                          (sleep 1)
                          (loop (cdr spin))))

                      (match (command-line)
                        ((_ _ system)
                         (with-store store
                           (call-with-new-thread
                            (lambda ()
                              (spin system)))

                           (display
                            (derivation-file-name
                             (run-with-store store
                               (guix-derivation #$source #$version
                                                #$guile-version)
                               #:system system)))))))
                  #:module-path (list source))))

;; The procedure below is our return value.
(define* (build source
                #:key verbose? (version (date-version-string)) system
                (guile-version (match ((@ (guile) version))
                                 ("2.2.2" "2.2.2")
                                 (_       (effective-version))))
                #:allow-other-keys
                #:rest rest)
  "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
files."
  ;; Build the build program and then use it as a trampoline to build from
  ;; SOURCE.
  (mlet %store-monad ((build  (build-program source version guile-version))
                      (system (if system (return system) (current-system))))
    (mbegin %store-monad
      (show-what-to-build* (list build))
      (built-derivations (list build))
      (let* ((pipe   (begin
                       (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
                       (open-pipe* OPEN_READ
                                   (derivation->output-path build)
                                   source system)))
             (str    (get-string-all pipe))
             (status (close-pipe pipe)))
        (match str
          ((? eof-object?)
           (error "build program failed" (list build status)))
          ((? derivation-path? drv)
           (mbegin %store-monad
             (return (newline (current-output-port)))
             ((store-lift add-temp-root) drv)
             (return (read-derivation-from-file drv))))
          ((? string? str)
           (error "invalid build result" (list build str))))))))

;; This file is loaded by 'guix pull'; return it the build procedure.
build

;; Local Variables:
;; eval: (put 'with-load-path 'scheme-indent-function 1)
;; End:

;;; build-self.scm ends here
Commit	Line	Data
f81ac34d	1	;;; GNU Guix --- Functional package management for GNU
f0527ce3	2	;;; Copyright © 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
f81ac34d LC	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 (build-self)
cd295fbe LC	20	#:use-module (gnu)
cd295fbe LC	21	#:use-module (guix)
f0527ce3	22	#:use-module (guix ui)
cd295fbe	23	#:use-module (guix config)
f0527ce3	24	#:use-module (guix modules)
f81ac34d	25	#:use-module (srfi srfi-1)
b006ba50	26	#:use-module (srfi srfi-19)
f0527ce3	27	#:use-module (rnrs io ports)
838ba73d	28	#:use-module (ice-9 match)
f0527ce3	29	#:use-module (ice-9 popen)
f81ac34d LC	30	#:export (build))
	31
	32	;;; Commentary:
	33	;;;
	34	;;; When loaded, this module returns a monadic procedure of at least one
	35	;;; argument: the source tree to build. It returns a derivation that
	36	;;; builds it.
	37	;;;
cd295fbe LC	38	;;; This file uses modules provided by the already-installed Guix. Those
	39	;;; modules may be arbitrarily old compared to the version we want to
	40	;;; build. Because of that, it must rely on the smallest set of features
	41	;;; that are likely to be provided by the (guix) and (gnu) modules, and by
	42	;;; Guile itself, forever and ever.
	43	;;;
f81ac34d LC	44	;;; Code:
f81ac34d LC	45
cd295fbe	46	\f
f0527ce3 LC	47	;;;
	48	;;; Generating (guix config).
	49	;;;
	50	;;; This is copied from (guix self) because we cannot assume (guix self) is
	51	;;; available at this point.
	52	;;;
	53
	54	(define %dependency-variables
	55	;; (guix config) variables corresponding to dependencies.
	56	'(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate))
	57
	58	(define %persona-variables
	59	;; (guix config) variables that define Guix's persona.
	60	'(%guix-package-name
	61	%guix-version
	62	%guix-bug-report-address
	63	%guix-home-page-url))
	64
	65	(define %config-variables
	66	;; (guix config) variables corresponding to Guix configuration (storedir,
	67	;; localstatedir, etc.)
	68	(sort (filter pair?
	69	(module-map (lambda (name var)
	70	(and (not (memq name %dependency-variables))
	71	(not (memq name %persona-variables))
	72	(cons name (variable-ref var))))
	73	(resolve-interface '(guix config))))
	74	(lambda (name+value1 name+value2)
	75	(string<? (symbol->string (car name+value1))
	76	(symbol->string (car name+value2))))))
	77
	78	(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
	79	(package-name "GNU Guix")
	80	(package-version "0")
	81	(bug-report-address "bug-guix@gnu.org")
	82	(home-page-url "https://gnu.org/s/guix"))
	83
	84	;; Hack so that Geiser is not confused.
	85	(define defmod 'define-module)
	86
	87	(scheme-file "config.scm"
	88	#~(begin
	89	(#$defmod (guix config)
	90	#:export (%guix-package-name
	91	%guix-version
	92	%guix-bug-report-address
	93	%guix-home-page-url
	94	%libgcrypt
	95	%libz
	96	%gzip
	97	%bzip2
	98	%xz
	99	%nix-instantiate))
	100
	101	;; XXX: Work around <http://bugs.gnu.org/15602>.
	102	(eval-when (expand load eval)
	103	#$@(map (match-lambda
	104	((name . value)
	105	#~(define-public #$name #$value)))
	106	%config-variables)
	107
	108	(define %guix-package-name #$package-name)
	109	(define %guix-version #$package-version)
	110	(define %guix-bug-report-address #$bug-report-address)
111	(define %guix-home-page-url #$home-page-url)
112
113	(define %gzip
114	#+(and gzip (file-append gzip "/bin/gzip")))
115	(define %bzip2
116	#+(and bzip2 (file-append bzip2 "/bin/bzip2")))
117	(define %xz
118	#+(and xz (file-append xz "/bin/xz")))
119
120	(define %libgcrypt
121	#+(and libgcrypt
122	(file-append libgcrypt "/lib/libgcrypt")))
123	(define %libz
124	#+(and zlib
125	(file-append zlib "/lib/libz")))
126
127	(define %nix-instantiate ;for (guix import snix)
128	"nix-instantiate")))))
cd295fbe	129
f0527ce3 LC	130	\f
	131	;;;
	132	;;; 'gexp->script'.
	133	;;;
	134	;;; This is our own variant of 'gexp->script' with an extra #:module-path
	135	;;; parameter, which was unavailable in (guix gexp) until commit
	136	;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
	137	;;;
cd295fbe	138
f0527ce3 LC	139	(define (load-path-expression modules path)
	140	"Return as a monadic value a gexp that sets '%load-path' and
	141	'%load-compiled-path' to point to MODULES, a list of module names. MODULES
	142	are searched for in PATH."
	143	(mlet %store-monad ((modules (imported-modules modules
	144	#:module-path path))
	145	(compiled (compiled-modules modules
	146	#:module-path path)))
	147	(return (gexp (eval-when (expand load eval)
	148	(set! %load-path
	149	(cons (ungexp modules) %load-path))
	150	(set! %load-compiled-path
	151	(cons (ungexp compiled)
	152	%load-compiled-path)))))))
	153
	154	(define* (gexp->script name exp
	155	#:key (guile (default-guile))
	156	(module-path %load-path))
	157	"Return an executable script NAME that runs EXP using GUILE, with EXP's
	158	imported modules in its search path."
	159	(mlet %store-monad ((set-load-path
	160	(load-path-expression (gexp-modules exp)
	161	module-path)))
	162	(gexp->derivation name
	163	(gexp
	164	(call-with-output-file (ungexp output)
	165	(lambda (port)
	166	;; Note: that makes a long shebang. When the store
	167	;; is /gnu/store, that fits within the 128-byte
	168	;; limit imposed by Linux, but that may go beyond
	169	;; when running tests.
	170	(format port
	171	"#!~a/bin/guile --no-auto-compile~%!#~%"
	172	(ungexp guile))
	173
	174	(write '(ungexp set-load-path) port)
	175	(write '(ungexp exp) port)
	176	(chmod port #o555))))
	177	#:module-path module-path)))
b006ba50	178
f0527ce3	179	\f
b006ba50 LC	180	(define (date-version-string)
	181	"Return the current date and hour in UTC timezone, for use as a poor
	182	person's version identifier."
cd295fbe	183	;; XXX: Replace with a Git commit id.
b006ba50 LC	184	(date->string (current-date 0) "~Y~m~d.~H"))
b006ba50 LC	185
f0527ce3 LC	186	(define* (build-program source version
	187	#:optional (guile-version (effective-version)))
	188	"Return a program that computes the derivation to build Guix from SOURCE."
	189	(define select?
	190	;; Select every module but (guix config) and non-Guix modules.
	191	(match-lambda
	192	(('guix 'config) #f)
	193	(('guix _ ...) #t)
	194	(('gnu _ ...) #t)
	195	(_ #f)))
	196
	197	(with-imported-modules `(((guix config)
	198	=> ,(make-config.scm
	199	#:libgcrypt
	200	(specification->package "libgcrypt")))
	201	,@(source-module-closure `((guix store)
	202	(guix self)
	203	(guix derivations)
	204	(gnu packages bootstrap))
	205	(list source)
	206	#:select? select?))
	207	(gexp->script "compute-guix-derivation"
	208	#~(begin
	209	(use-modules (ice-9 match))
	210
	211	(eval-when (expand load eval)
	212	;; Don't augment '%load-path'.
	213	(unsetenv "GUIX_PACKAGE_PATH")
	214
	215	;; (gnu packages …) modules are going to be looked up
	216	;; under SOURCE. (guix config) is looked up in FRONT.
	217	(match %load-path
	218	((#$source _ ...)
	219	#t) ;already done
	220	((front _ ...)
	221	(set! %load-path (list #$source front))))
	222
	223	;; Only load our own modules or those of Guile.
	224	(match %load-compiled-path
	225	((front _ ... sys1 sys2)
	226	(set! %load-compiled-path
	227	(list front sys1 sys2)))))
	228
	229	(use-modules (guix store)
	230	(guix self)
	231	(guix derivations)
	232	(srfi srfi-1))
	233
	234	(define (spin system)
	235	(define spin
	236	(circular-list "-" "\\" "\|" "/" "-" "\\" "\|" "/"))
	237
	238	(format (current-error-port)
	239	"Computing Guix derivation for '~a'... "
	240	system)
	241	(let loop ((spin spin))
	242	(display (string-append "\b" (car spin))
	243	(current-error-port))
	244	(force-output (current-error-port))
	245	(sleep 1)
	246	(loop (cdr spin))))
	247
	248	(match (command-line)
	249	((_ _ system)
250	(with-store store
251	(call-with-new-thread
252	(lambda ()
253	(spin system)))
254
255	(display
256	(derivation-file-name
257	(run-with-store store
258	(guix-derivation #$source #$version
259	#$guile-version)
260	#:system system)))))))
261	#:module-path (list source))))
838ba73d	262
f81ac34d	263	;; The procedure below is our return value.
b006ba50	264	(define* (build source
f0527ce3 LC	265	#:key verbose? (version (date-version-string)) system
	266	(guile-version (match ((@ (guile) version))
	267	("2.2.2" "2.2.2")
	268	(_ (effective-version))))
f81ac34d LC	269	#:allow-other-keys
	270	#:rest rest)
	271	"Return a derivation that unpacks SOURCE into STORE and compiles Scheme
	272	files."
f0527ce3 LC	273	;; Build the build program and then use it as a trampoline to build from
	274	;; SOURCE.
	275	(mlet %store-monad ((build (build-program source version guile-version))
	276	(system (if system (return system) (current-system))))
	277	(mbegin %store-monad
	278	(show-what-to-build* (list build))
	279	(built-derivations (list build))
f27a7128 LC	280	(let* ((pipe (begin
	281	(setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
	282	(open-pipe* OPEN_READ
	283	(derivation->output-path build)
	284	source system)))
	285	(str (get-string-all pipe))
	286	(status (close-pipe pipe)))
	287	(match str
f0527ce3	288	((? eof-object?)
f27a7128	289	(error "build program failed" (list build status)))
f0527ce3 LC	290	((? derivation-path? drv)
	291	(mbegin %store-monad
	292	(return (newline (current-output-port)))
	293	((store-lift add-temp-root) drv)
	294	(return (read-derivation-from-file drv))))
	295	((? string? str)
	296	(error "invalid build result" (list build str))))))))
f81ac34d LC	297
	298	;; This file is loaded by 'guix pull'; return it the build procedure.
	299	build
	300
cd295fbe LC	301	;; Local Variables:
	302	;; eval: (put 'with-load-path 'scheme-indent-function 1)
	303	;; End:
	304
f81ac34d	305	;;; build-self.scm ends here