[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.
  (letrec-syntax ((variables (syntax-rules ()
                               ((_)
                                '())
                               ((_ variable rest ...)
                                (cons `(variable . ,variable)
                                      (variables rest ...))))))
    (variables %config-directory %localstatedir %state-directory
               %store-database-directory %store-directory
               %storedir %sysconfdir %system)))

(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))
                        #:key (pull-version 0))
  "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
                            (and=>
                             (run-with-store store
                               (guix-derivation #$source #$version
                                                #$guile-version
                                                #:pull-version
                                                #$pull-version)
                               #:system system)
                             derivation-file-name))))))
                  #: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))))
                (pull-version 0)
                #: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
                                             #:pull-version pull-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))))
          ("#f"
           ;; Unsupported PULL-VERSION.
           (return #f))
          ((? 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
45779fa6 LC	66	;; (guix config) variables corresponding to Guix configuration.
	67	(letrec-syntax ((variables (syntax-rules ()
	68	((_)
	69	'())
	70	((_ variable rest ...)
	71	(cons `(variable . ,variable)
	72	(variables rest ...))))))
	73	(variables %config-directory %localstatedir %state-directory
	74	%store-database-directory %store-directory
	75	%storedir %sysconfdir %system)))
f0527ce3 LC	76
	77	(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
	78	(package-name "GNU Guix")
	79	(package-version "0")
	80	(bug-report-address "bug-guix@gnu.org")
	81	(home-page-url "https://gnu.org/s/guix"))
	82
	83	;; Hack so that Geiser is not confused.
	84	(define defmod 'define-module)
	85
	86	(scheme-file "config.scm"
	87	#~(begin
	88	(#$defmod (guix config)
	89	#:export (%guix-package-name
	90	%guix-version
	91	%guix-bug-report-address
	92	%guix-home-page-url
	93	%libgcrypt
	94	%libz
	95	%gzip
	96	%bzip2
	97	%xz
	98	%nix-instantiate))
	99
	100	;; XXX: Work around <http://bugs.gnu.org/15602>.
	101	(eval-when (expand load eval)
	102	#$@(map (match-lambda
	103	((name . value)
	104	#~(define-public #$name #$value)))
	105	%config-variables)
	106
	107	(define %guix-package-name #$package-name)
	108	(define %guix-version #$package-version)
	109	(define %guix-bug-report-address #$bug-report-address)
	110	(define %guix-home-page-url #$home-page-url)
	111
	112	(define %gzip
	113	#+(and gzip (file-append gzip "/bin/gzip")))
	114	(define %bzip2
	115	#+(and bzip2 (file-append bzip2 "/bin/bzip2")))
	116	(define %xz
	117	#+(and xz (file-append xz "/bin/xz")))
	118
	119	(define %libgcrypt
	120	#+(and libgcrypt
	121	(file-append libgcrypt "/lib/libgcrypt")))
	122	(define %libz
	123	#+(and zlib
	124	(file-append zlib "/lib/libz")))
	125
	126	(define %nix-instantiate ;for (guix import snix)
	127	"nix-instantiate")))))
cd295fbe	128
f0527ce3 LC	129	\f
	130	;;;
	131	;;; 'gexp->script'.
	132	;;;
	133	;;; This is our own variant of 'gexp->script' with an extra #:module-path
	134	;;; parameter, which was unavailable in (guix gexp) until commit
	135	;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
	136	;;;
cd295fbe	137
f0527ce3 LC	138	(define (load-path-expression modules path)
	139	"Return as a monadic value a gexp that sets '%load-path' and
	140	'%load-compiled-path' to point to MODULES, a list of module names. MODULES
	141	are searched for in PATH."
	142	(mlet %store-monad ((modules (imported-modules modules
	143	#:module-path path))
	144	(compiled (compiled-modules modules
	145	#:module-path path)))
	146	(return (gexp (eval-when (expand load eval)
	147	(set! %load-path
	148	(cons (ungexp modules) %load-path))
	149	(set! %load-compiled-path
	150	(cons (ungexp compiled)
	151	%load-compiled-path)))))))
	152
	153	(define* (gexp->script name exp
	154	#:key (guile (default-guile))
	155	(module-path %load-path))
	156	"Return an executable script NAME that runs EXP using GUILE, with EXP's
	157	imported modules in its search path."
	158	(mlet %store-monad ((set-load-path
	159	(load-path-expression (gexp-modules exp)
	160	module-path)))
	161	(gexp->derivation name
	162	(gexp
	163	(call-with-output-file (ungexp output)
	164	(lambda (port)
	165	;; Note: that makes a long shebang. When the store
	166	;; is /gnu/store, that fits within the 128-byte
	167	;; limit imposed by Linux, but that may go beyond
	168	;; when running tests.
	169	(format port
	170	"#!~a/bin/guile --no-auto-compile~%!#~%"
	171	(ungexp guile))
	172
	173	(write '(ungexp set-load-path) port)
	174	(write '(ungexp exp) port)
	175	(chmod port #o555))))
	176	#:module-path module-path)))
b006ba50	177
f0527ce3	178	\f
b006ba50 LC	179	(define (date-version-string)
	180	"Return the current date and hour in UTC timezone, for use as a poor
	181	person's version identifier."
cd295fbe	182	;; XXX: Replace with a Git commit id.
b006ba50 LC	183	(date->string (current-date 0) "~Y~m~d.~H"))
b006ba50 LC	184
f0527ce3	185	(define* (build-program source version
8a0d9bc8 LC	186	#:optional (guile-version (effective-version))
8a0d9bc8 LC	187	#:key (pull-version 0))
f0527ce3 LC	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
8a0d9bc8	256	(and=>
f0527ce3 LC	257	(run-with-store store
f0527ce3 LC	258	(guix-derivation #$source #$version
8a0d9bc8 LC	259	#$guile-version
	260	#:pull-version
	261	#$pull-version)
	262	#:system system)
	263	derivation-file-name))))))
f0527ce3	264	#:module-path (list source))))
838ba73d	265
f81ac34d	266	;; The procedure below is our return value.
b006ba50	267	(define* (build source
f0527ce3 LC	268	#:key verbose? (version (date-version-string)) system
	269	(guile-version (match ((@ (guile) version))
	270	("2.2.2" "2.2.2")
	271	(_ (effective-version))))
8a0d9bc8	272	(pull-version 0)
f81ac34d LC	273	#:allow-other-keys
	274	#:rest rest)
	275	"Return a derivation that unpacks SOURCE into STORE and compiles Scheme
	276	files."
f0527ce3 LC	277	;; Build the build program and then use it as a trampoline to build from
f0527ce3 LC	278	;; SOURCE.
8a0d9bc8 LC	279	(mlet %store-monad ((build (build-program source version guile-version
8a0d9bc8 LC	280	#:pull-version pull-version))
f0527ce3 LC	281	(system (if system (return system) (current-system))))
	282	(mbegin %store-monad
	283	(show-what-to-build* (list build))
	284	(built-derivations (list build))
f27a7128 LC	285	(let* ((pipe (begin
	286	(setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
	287	(open-pipe* OPEN_READ
	288	(derivation->output-path build)
	289	source system)))
	290	(str (get-string-all pipe))
	291	(status (close-pipe pipe)))
	292	(match str
f0527ce3	293	((? eof-object?)
f27a7128	294	(error "build program failed" (list build status)))
f0527ce3 LC	295	((? derivation-path? drv)
	296	(mbegin %store-monad
	297	(return (newline (current-output-port)))
	298	((store-lift add-temp-root) drv)
	299	(return (read-derivation-from-file drv))))
8a0d9bc8 LC	300	("#f"
	301	;; Unsupported PULL-VERSION.
	302	(return #f))
f0527ce3 LC	303	((? string? str)
f0527ce3 LC	304	(error "invalid build result" (list build str))))))))
f81ac34d LC	305
	306	;; This file is loaded by 'guix pull'; return it the build procedure.
	307	build
	308
cd295fbe LC	309	;; Local Variables:
	310	;; eval: (put 'with-load-path 'scheme-indent-function 1)
	311	;; End:
	312
f81ac34d	313	;;; build-self.scm ends here