[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 (guix build-system gnu)
  #: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))

(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 %localstatedir %storedir %sysconfdir %system)))

(define* (make-config.scm #:key 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
                               %store-directory
                               %state-directory
                               %store-database-directory
                               %config-directory
                               %libz
                               %gzip
                               %bzip2
                               %xz))

                   ;; 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 %store-directory
                       (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
                           %storedir))

                     (define %state-directory
                       ;; This must match `NIX_STATE_DIR' as defined in
                       ;; `nix/local.mk'.
                       (or (getenv "NIX_STATE_DIR")
                           (string-append %localstatedir "/guix")))

                     (define %store-database-directory
                       (or (getenv "NIX_DB_DIR")
                           (string-append %state-directory "/db")))

                     (define %config-directory
                       ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
                       ;; defined in `nix/local.mk'.
                       (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
                           (string-append %sysconfdir "/guix")))

                     (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 %libz
                       #+(and zlib
                              (file-append zlib "/lib/libz")))))))

\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 guile-gcrypt
  ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
  ;; August 2018.  If it has it, it's at least version 0.1.0, which is good
  ;; enough.  If it doesn't, specify our own package because the target Guix
  ;; requires it.
  (match (find-best-packages-by-name "guile-gcrypt" #f)
    (()
     (package
       (name "guile-gcrypt")
       (version "0.1.0")
       (home-page "https://notabug.org/cwebber/guile-gcrypt")
       (source (origin
                 (method url-fetch)
                 (uri (string-append home-page "/archive/v" version ".tar.gz"))
                 (sha256
                  (base32
                   "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
                 (file-name (string-append name "-" version ".tar.gz"))))
       (build-system gnu-build-system)
       (native-inputs
        `(("pkg-config" ,(specification->package "pkg-config"))
          ("autoconf" ,(specification->package "autoconf"))
          ("automake" ,(specification->package "automake"))
          ("texinfo" ,(specification->package "texinfo"))))
       (inputs
        `(("guile" ,(specification->package "guile"))
          ("libgcrypt" ,(specification->package "libgcrypt"))))
       (synopsis "Cryptography library for Guile using Libgcrypt")
       (description
        "Guile-Gcrypt provides a Guile 2.x interface to a subset of the
GNU Libgcrypt crytographic library.  It provides modules for cryptographic
hash functions, message authentication codes (MAC), public-key cryptography,
strong randomness, and more.  It is implemented using the foreign function
interface (FFI) of Guile.")
       (license #f)))                             ;license:gpl3+
    ((package . _)
     package)))

(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)))

  (define fake-gcrypt-hash
    ;; Fake (gcrypt hash) module; see below.
    (scheme-file "hash.scm"
                 #~(define-module (gcrypt hash)
                     #:export (sha1 sha256))))

  (with-imported-modules `(((guix config)
                            => ,(make-config.scm))

                           ;; To avoid relying on 'with-extensions', which was
                           ;; introduced in 0.15.0, provide a fake (gcrypt
                           ;; hash) just so that we can build modules, and
                           ;; adjust %LOAD-PATH later on.
                           ((gcrypt hash) => ,fake-gcrypt-hash)

                           ,@(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 (command-line)
                          ((_ source _ ...)
                           (match %load-path
                             ((front _ ...)
                              (unless (string=? front source) ;already done?
                                (set! %load-path
                                  (list source
                                        (string-append #$guile-gcrypt
                                                       "/share/guile/site/"
                                                       (effective-version))
                                        front)))))))

                        ;; Only load Guile-Gcrypt, our own modules, or those
                        ;; of Guile.
                        (match %load-compiled-path
                          ((front _ ... sys1 sys2)
                           (unless (string-prefix? #$guile-gcrypt front)
                             (set! %load-compiled-path
                               (list (string-append #$guile-gcrypt
                                                    "/lib/guile/"
                                                    (effective-version)
                                                    "/site-ccache")
                                     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)
                        ((_ source system version protocol-version)
                         ;; The current input port normally wraps a file
                         ;; descriptor connected to the daemon, or it is
                         ;; connected to /dev/null.  In the former case, reuse
                         ;; the connection such that we inherit build options
                         ;; such as substitute URLs and so on; in the latter
                         ;; case, attempt to open a new connection.
                         (let* ((proto (string->number protocol-version))
                                (store (if (integer? proto)
                                           (port->connection (duplicate-port
                                                              (current-input-port)
                                                              "w+0")
                                                             #:version proto)
                                           (open-connection))))
                           (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)))
                      (port   ((store-lift nix-server-socket)))
                      (major  ((store-lift nix-server-major-version)))
                      (minor  ((store-lift nix-server-minor-version))))
    (mbegin %store-monad
      (show-what-to-build* (list build))
      (built-derivations (list build))

      ;; Use the port beneath the current store as the stdin of BUILD.  This
      ;; way, we know 'open-pipe*' will not close it on 'exec'.  If PORT is
      ;; not a file port (e.g., it's an SSH channel), then the subprocess's
      ;; stdin will actually be /dev/null.
      (let* ((pipe   (with-input-from-port port
                       (lambda ()
                         (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
                         (open-pipe* OPEN_READ
                                     (derivation->output-path build)
                                     source system version
                                     (if (file-port? port)
                                         (number->string
                                          (logior major minor))
                                         "none")))))
             (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)
ca719424	25	#:use-module (guix build-system gnu)
f81ac34d	26	#:use-module (srfi srfi-1)
b006ba50	27	#:use-module (srfi srfi-19)
f0527ce3	28	#:use-module (rnrs io ports)
838ba73d	29	#:use-module (ice-9 match)
f0527ce3	30	#:use-module (ice-9 popen)
f81ac34d LC	31	#:export (build))
	32
	33	;;; Commentary:
	34	;;;
	35	;;; When loaded, this module returns a monadic procedure of at least one
	36	;;; argument: the source tree to build. It returns a derivation that
	37	;;; builds it.
	38	;;;
cd295fbe LC	39	;;; This file uses modules provided by the already-installed Guix. Those
	40	;;; modules may be arbitrarily old compared to the version we want to
	41	;;; build. Because of that, it must rely on the smallest set of features
	42	;;; that are likely to be provided by the (guix) and (gnu) modules, and by
	43	;;; Guile itself, forever and ever.
	44	;;;
f81ac34d LC	45	;;; Code:
f81ac34d LC	46
cd295fbe	47	\f
f0527ce3 LC	48	;;;
	49	;;; Generating (guix config).
	50	;;;
	51	;;; This is copied from (guix self) because we cannot assume (guix self) is
	52	;;; available at this point.
	53	;;;
	54
	55	(define %dependency-variables
	56	;; (guix config) variables corresponding to dependencies.
e8cb9c01	57	'(%libgcrypt %libz %xz %gzip %bzip2))
f0527ce3 LC	58
	59	(define %persona-variables
	60	;; (guix config) variables that define Guix's persona.
	61	'(%guix-package-name
	62	%guix-version
	63	%guix-bug-report-address
	64	%guix-home-page-url))
	65
	66	(define %config-variables
45779fa6 LC	67	;; (guix config) variables corresponding to Guix configuration.
	68	(letrec-syntax ((variables (syntax-rules ()
	69	((_)
	70	'())
	71	((_ variable rest ...)
	72	(cons `(variable . ,variable)
	73	(variables rest ...))))))
7af5c2a2	74	(variables %localstatedir %storedir %sysconfdir %system)))
f0527ce3	75
ca719424	76	(define* (make-config.scm #:key zlib gzip xz bzip2
f0527ce3 LC	77	(package-name "GNU Guix")
	78	(package-version "0")
	79	(bug-report-address "bug-guix@gnu.org")
	80	(home-page-url "https://gnu.org/s/guix"))
	81
	82	;; Hack so that Geiser is not confused.
	83	(define defmod 'define-module)
	84
	85	(scheme-file "config.scm"
	86	#~(begin
	87	(#$defmod (guix config)
	88	#:export (%guix-package-name
	89	%guix-version
	90	%guix-bug-report-address
	91	%guix-home-page-url
7af5c2a2 LC	92	%store-directory
	93	%state-directory
	94	%store-database-directory
	95	%config-directory
f0527ce3 LC	96	%libz
	97	%gzip
	98	%bzip2
e8cb9c01	99	%xz))
f0527ce3 LC	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
7af5c2a2 LC	108	(define %store-directory
	109	(or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
	110	%storedir))
	111
	112	(define %state-directory
	113	;; This must match `NIX_STATE_DIR' as defined in
	114	;; `nix/local.mk'.
	115	(or (getenv "NIX_STATE_DIR")
	116	(string-append %localstatedir "/guix")))
	117
	118	(define %store-database-directory
	119	(or (getenv "NIX_DB_DIR")
	120	(string-append %state-directory "/db")))
	121
	122	(define %config-directory
	123	;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
	124	;; defined in `nix/local.mk'.
	125	(or (getenv "GUIX_CONFIGURATION_DIRECTORY")
	126	(string-append %sysconfdir "/guix")))
	127
f0527ce3 LC	128	(define %guix-package-name #$package-name)
	129	(define %guix-version #$package-version)
	130	(define %guix-bug-report-address #$bug-report-address)
	131	(define %guix-home-page-url #$home-page-url)
	132
	133	(define %gzip
	134	#+(and gzip (file-append gzip "/bin/gzip")))
	135	(define %bzip2
	136	#+(and bzip2 (file-append bzip2 "/bin/bzip2")))
	137	(define %xz
	138	#+(and xz (file-append xz "/bin/xz")))
	139
f0527ce3 LC	140	(define %libz
f0527ce3 LC	141	#+(and zlib
e8cb9c01	142	(file-append zlib "/lib/libz")))))))
cd295fbe	143
f0527ce3 LC	144	\f
	145	;;;
	146	;;; 'gexp->script'.
	147	;;;
	148	;;; This is our own variant of 'gexp->script' with an extra #:module-path
	149	;;; parameter, which was unavailable in (guix gexp) until commit
	150	;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
	151	;;;
cd295fbe	152
f0527ce3 LC	153	(define (load-path-expression modules path)
	154	"Return as a monadic value a gexp that sets '%load-path' and
	155	'%load-compiled-path' to point to MODULES, a list of module names. MODULES
	156	are searched for in PATH."
	157	(mlet %store-monad ((modules (imported-modules modules
	158	#:module-path path))
	159	(compiled (compiled-modules modules
	160	#:module-path path)))
	161	(return (gexp (eval-when (expand load eval)
	162	(set! %load-path
	163	(cons (ungexp modules) %load-path))
	164	(set! %load-compiled-path
	165	(cons (ungexp compiled)
	166	%load-compiled-path)))))))
	167
	168	(define* (gexp->script name exp
	169	#:key (guile (default-guile))
	170	(module-path %load-path))
	171	"Return an executable script NAME that runs EXP using GUILE, with EXP's
	172	imported modules in its search path."
	173	(mlet %store-monad ((set-load-path
	174	(load-path-expression (gexp-modules exp)
	175	module-path)))
	176	(gexp->derivation name
	177	(gexp
	178	(call-with-output-file (ungexp output)
	179	(lambda (port)
	180	;; Note: that makes a long shebang. When the store
	181	;; is /gnu/store, that fits within the 128-byte
	182	;; limit imposed by Linux, but that may go beyond
	183	;; when running tests.
	184	(format port
	185	"#!~a/bin/guile --no-auto-compile~%!#~%"
	186	(ungexp guile))
	187
	188	(write '(ungexp set-load-path) port)
	189	(write '(ungexp exp) port)
	190	(chmod port #o555))))
	191	#:module-path module-path)))
b006ba50	192
f0527ce3	193	\f
b006ba50 LC	194	(define (date-version-string)
	195	"Return the current date and hour in UTC timezone, for use as a poor
	196	person's version identifier."
cd295fbe	197	;; XXX: Replace with a Git commit id.
b006ba50 LC	198	(date->string (current-date 0) "~Y~m~d.~H"))
b006ba50 LC	199
ca719424 LC	200	(define guile-gcrypt
	201	;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
	202	;; August 2018. If it has it, it's at least version 0.1.0, which is good
	203	;; enough. If it doesn't, specify our own package because the target Guix
	204	;; requires it.
	205	(match (find-best-packages-by-name "guile-gcrypt" #f)
	206	(()
	207	(package
	208	(name "guile-gcrypt")
	209	(version "0.1.0")
	210	(home-page "https://notabug.org/cwebber/guile-gcrypt")
	211	(source (origin
	212	(method url-fetch)
	213	(uri (string-append home-page "/archive/v" version ".tar.gz"))
	214	(sha256
	215	(base32
	216	"1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
	217	(file-name (string-append name "-" version ".tar.gz"))))
	218	(build-system gnu-build-system)
	219	(native-inputs
	220	`(("pkg-config" ,(specification->package "pkg-config"))
	221	("autoconf" ,(specification->package "autoconf"))
	222	("automake" ,(specification->package "automake"))
	223	("texinfo" ,(specification->package "texinfo"))))
	224	(inputs
	225	`(("guile" ,(specification->package "guile"))
	226	("libgcrypt" ,(specification->package "libgcrypt"))))
	227	(synopsis "Cryptography library for Guile using Libgcrypt")
	228	(description
	229	"Guile-Gcrypt provides a Guile 2.x interface to a subset of the
	230	GNU Libgcrypt crytographic library. It provides modules for cryptographic
	231	hash functions, message authentication codes (MAC), public-key cryptography,
	232	strong randomness, and more. It is implemented using the foreign function
	233	interface (FFI) of Guile.")
	234	(license #f))) ;license:gpl3+
	235	((package . _)
	236	package)))
	237
f0527ce3	238	(define* (build-program source version
8a0d9bc8 LC	239	#:optional (guile-version (effective-version))
8a0d9bc8 LC	240	#:key (pull-version 0))
f0527ce3 LC	241	"Return a program that computes the derivation to build Guix from SOURCE."
	242	(define select?
	243	;; Select every module but (guix config) and non-Guix modules.
	244	(match-lambda
	245	(('guix 'config) #f)
	246	(('guix _ ...) #t)
	247	(('gnu _ ...) #t)
	248	(_ #f)))
	249
ca719424 LC	250	(define fake-gcrypt-hash
	251	;; Fake (gcrypt hash) module; see below.
	252	(scheme-file "hash.scm"
	253	#~(define-module (gcrypt hash)
	254	#:export (sha1 sha256))))
	255
f0527ce3	256	(with-imported-modules `(((guix config)
ca719424 LC	257	=> ,(make-config.scm))
	258
	259	;; To avoid relying on 'with-extensions', which was
	260	;; introduced in 0.15.0, provide a fake (gcrypt
	261	;; hash) just so that we can build modules, and
	262	;; adjust %LOAD-PATH later on.
	263	((gcrypt hash) => ,fake-gcrypt-hash)
	264
f0527ce3 LC	265	,@(source-module-closure `((guix store)
	266	(guix self)
	267	(guix derivations)
	268	(gnu packages bootstrap))
	269	(list source)
	270	#:select? select?))
	271	(gexp->script "compute-guix-derivation"
	272	#~(begin
	273	(use-modules (ice-9 match))
	274
	275	(eval-when (expand load eval)
	276	;; Don't augment '%load-path'.
	277	(unsetenv "GUIX_PACKAGE_PATH")
	278
	279	;; (gnu packages …) modules are going to be looked up
	280	;; under SOURCE. (guix config) is looked up in FRONT.
1f1d76a1 LC	281	(match (command-line)
	282	((_ source _ ...)
	283	(match %load-path
	284	((front _ ...)
	285	(unless (string=? front source) ;already done?
ca719424 LC	286	(set! %load-path
	287	(list source
	288	(string-append #$guile-gcrypt
	289	"/share/guile/site/"
	290	(effective-version))
	291	front)))))))
f0527ce3	292
ca719424 LC	293	;; Only load Guile-Gcrypt, our own modules, or those
ca719424 LC	294	;; of Guile.
f0527ce3 LC	295	(match %load-compiled-path
f0527ce3 LC	296	((front _ ... sys1 sys2)
ca719424 LC	297	(unless (string-prefix? #$guile-gcrypt front)
	298	(set! %load-compiled-path
	299	(list (string-append #$guile-gcrypt
	300	"/lib/guile/"
	301	(effective-version)
	302	"/site-ccache")
	303	front sys1 sys2))))))
f0527ce3 LC	304
	305	(use-modules (guix store)
	306	(guix self)
	307	(guix derivations)
	308	(srfi srfi-1))
	309
	310	(define (spin system)
	311	(define spin
	312	(circular-list "-" "\\" "\|" "/" "-" "\\" "\|" "/"))
	313
	314	(format (current-error-port)
	315	"Computing Guix derivation for '~a'... "
	316	system)
	317	(let loop ((spin spin))
	318	(display (string-append "\b" (car spin))
	319	(current-error-port))
	320	(force-output (current-error-port))
	321	(sleep 1)
	322	(loop (cdr spin))))
	323
	324	(match (command-line)
790c3e01 LC	325	((_ source system version protocol-version)
	326	;; The current input port normally wraps a file
	327	;; descriptor connected to the daemon, or it is
	328	;; connected to /dev/null. In the former case, reuse
	329	;; the connection such that we inherit build options
	330	;; such as substitute URLs and so on; in the latter
	331	;; case, attempt to open a new connection.
	332	(let* ((proto (string->number protocol-version))
	333	(store (if (integer? proto)
	334	(port->connection (duplicate-port
	335	(current-input-port)
	336	"w+0")
	337	#:version proto)
	338	(open-connection))))
f0527ce3 LC	339	(call-with-new-thread
	340	(lambda ()
	341	(spin system)))
	342
	343	(display
8a0d9bc8	344	(and=>
f0527ce3	345	(run-with-store store
1f1d76a1	346	(guix-derivation source version
8a0d9bc8 LC	347	#$guile-version
	348	#:pull-version
	349	#$pull-version)
	350	#:system system)
	351	derivation-file-name))))))
f0527ce3	352	#:module-path (list source))))
838ba73d	353
f81ac34d	354	;; The procedure below is our return value.
b006ba50	355	(define* (build source
f0527ce3 LC	356	#:key verbose? (version (date-version-string)) system
	357	(guile-version (match ((@ (guile) version))
	358	("2.2.2" "2.2.2")
	359	(_ (effective-version))))
8a0d9bc8	360	(pull-version 0)
f81ac34d LC	361	#:allow-other-keys
	362	#:rest rest)
	363	"Return a derivation that unpacks SOURCE into STORE and compiles Scheme
	364	files."
f0527ce3 LC	365	;; Build the build program and then use it as a trampoline to build from
f0527ce3 LC	366	;; SOURCE.
8a0d9bc8 LC	367	(mlet %store-monad ((build (build-program source version guile-version
8a0d9bc8 LC	368	#:pull-version pull-version))
790c3e01 LC	369	(system (if system (return system) (current-system)))
	370	(port ((store-lift nix-server-socket)))
	371	(major ((store-lift nix-server-major-version)))
	372	(minor ((store-lift nix-server-minor-version))))
f0527ce3 LC	373	(mbegin %store-monad
	374	(show-what-to-build* (list build))
	375	(built-derivations (list build))
790c3e01 LC	376
	377	;; Use the port beneath the current store as the stdin of BUILD. This
	378	;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is
	379	;; not a file port (e.g., it's an SSH channel), then the subprocess's
	380	;; stdin will actually be /dev/null.
	381	(let* ((pipe (with-input-from-port port
	382	(lambda ()
	383	(setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
	384	(open-pipe* OPEN_READ
	385	(derivation->output-path build)
	386	source system version
	387	(if (file-port? port)
	388	(number->string
	389	(logior major minor))
	390	"none")))))
f27a7128 LC	391	(str (get-string-all pipe))
	392	(status (close-pipe pipe)))
	393	(match str
f0527ce3	394	((? eof-object?)
f27a7128	395	(error "build program failed" (list build status)))
f0527ce3 LC	396	((? derivation-path? drv)
	397	(mbegin %store-monad
	398	(return (newline (current-output-port)))
	399	((store-lift add-temp-root) drv)
	400	(return (read-derivation-from-file drv))))
8a0d9bc8 LC	401	("#f"
	402	;; Unsupported PULL-VERSION.
	403	(return #f))
f0527ce3 LC	404	((? string? str)
f0527ce3 LC	405	(error "invalid build result" (list build str))))))))
f81ac34d LC	406
	407	;; This file is loaded by 'guix pull'; return it the build procedure.
	408	build
	409
cd295fbe LC	410	;; Local Variables:
	411	;; eval: (put 'with-load-path 'scheme-indent-function 1)
	412	;; End:
	413
f81ac34d	414	;;; build-self.scm ends here