build-aux/build-self.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (build-self)
  20   #:use-module (gnu)
  21   #:use-module (guix)
  22   #:use-module (guix ui)
  23   #:use-module (guix config)
  24   #:use-module (guix modules)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-19)
  27   #:use-module (rnrs io ports)
  28   #:use-module (ice-9 match)
  29   #:use-module (ice-9 popen)
  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 ;;;
  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 ;;;
  44 ;;; Code:
  45
  46 \f
  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))
  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.
  67   (letrec-syntax ((variables (syntax-rules ()
  68                                ((_)
  69                                 '())
  70                                ((_ variable rest ...)
  71                                 (cons `(variable . ,variable)
  72                                       (variables rest ...))))))
  73     (variables %localstatedir %storedir %sysconfdir %system)))
  74
  75 (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
  76                           (package-name "GNU Guix")
  77                           (package-version "0")
  78                           (bug-report-address "bug-guix@gnu.org")
  79                           (home-page-url "https://gnu.org/s/guix"))
  80
  81   ;; Hack so that Geiser is not confused.
  82   (define defmod 'define-module)
  83
  84   (scheme-file "config.scm"
  85                #~(begin
  86                    (#$defmod (guix config)
  87                      #:export (%guix-package-name
  88                                %guix-version
  89                                %guix-bug-report-address
  90                                %guix-home-page-url
  91                                %store-directory
  92                                %state-directory
  93                                %store-database-directory
  94                                %config-directory
  95                                %libgcrypt
  96                                %libz
  97                                %gzip
  98                                %bzip2
  99                                %xz))
 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 %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
 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
 140                      (define %libgcrypt
 141                        #+(and libgcrypt
 142                               (file-append libgcrypt "/lib/libgcrypt")))
 143                      (define %libz
 144                        #+(and zlib
 145                               (file-append zlib "/lib/libz")))))))
 146
 147 \f
 148 ;;;
 149 ;;; 'gexp->script'.
 150 ;;;
 151 ;;; This is our own variant of 'gexp->script' with an extra #:module-path
 152 ;;; parameter, which was unavailable in (guix gexp) until commit
 153 ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
 154 ;;;
 155
 156 (define (load-path-expression modules path)
 157   "Return as a monadic value a gexp that sets '%load-path' and
 158 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
 159 are searched for in PATH."
 160   (mlet %store-monad ((modules  (imported-modules modules
 161                                                   #:module-path path))
 162                       (compiled (compiled-modules modules
 163                                                   #:module-path path)))
 164     (return (gexp (eval-when (expand load eval)
 165                     (set! %load-path
 166                       (cons (ungexp modules) %load-path))
 167                     (set! %load-compiled-path
 168                       (cons (ungexp compiled)
 169                             %load-compiled-path)))))))
 170
 171 (define* (gexp->script name exp
 172                        #:key (guile (default-guile))
 173                        (module-path %load-path))
 174   "Return an executable script NAME that runs EXP using GUILE, with EXP's
 175 imported modules in its search path."
 176   (mlet %store-monad ((set-load-path
 177                        (load-path-expression (gexp-modules exp)
 178                                              module-path)))
 179     (gexp->derivation name
 180                       (gexp
 181                        (call-with-output-file (ungexp output)
 182                          (lambda (port)
 183                            ;; Note: that makes a long shebang.  When the store
 184                            ;; is /gnu/store, that fits within the 128-byte
 185                            ;; limit imposed by Linux, but that may go beyond
 186                            ;; when running tests.
 187                            (format port
 188                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
 189                                    (ungexp guile))
 190
 191                            (write '(ungexp set-load-path) port)
 192                            (write '(ungexp exp) port)
 193                            (chmod port #o555))))
 194                       #:module-path module-path)))
 195
 196 \f
 197 (define (date-version-string)
 198   "Return the current date and hour in UTC timezone, for use as a poor
 199 person's version identifier."
 200   ;; XXX: Replace with a Git commit id.
 201   (date->string (current-date 0) "~Y~m~d.~H"))
 202
 203 (define* (build-program source version
 204                         #:optional (guile-version (effective-version))
 205                         #:key (pull-version 0))
 206   "Return a program that computes the derivation to build Guix from SOURCE."
 207   (define select?
 208     ;; Select every module but (guix config) and non-Guix modules.
 209     (match-lambda
 210       (('guix 'config) #f)
 211       (('guix _ ...)   #t)
 212       (('gnu _ ...)    #t)
 213       (_               #f)))
 214
 215   (with-imported-modules `(((guix config)
 216                             => ,(make-config.scm
 217                                  #:libgcrypt
 218                                  (specification->package "libgcrypt")))
 219                            ,@(source-module-closure `((guix store)
 220                                                       (guix self)
 221                                                       (guix derivations)
 222                                                       (gnu packages bootstrap))
 223                                                     (list source)
 224                                                     #:select? select?))
 225     (gexp->script "compute-guix-derivation"
 226                   #~(begin
 227                       (use-modules (ice-9 match))
 228
 229                       (eval-when (expand load eval)
 230                         ;; Don't augment '%load-path'.
 231                         (unsetenv "GUIX_PACKAGE_PATH")
 232
 233                         ;; (gnu packages …) modules are going to be looked up
 234                         ;; under SOURCE.  (guix config) is looked up in FRONT.
 235                         (match (command-line)
 236                           ((_ source _ ...)
 237                            (match %load-path
 238                              ((front _ ...)
 239                               (unless (string=? front source) ;already done?
 240                                 (set! %load-path (list source front)))))))
 241
 242                         ;; Only load our own modules or those of Guile.
 243                         (match %load-compiled-path
 244                           ((front _ ... sys1 sys2)
 245                            (set! %load-compiled-path
 246                              (list front sys1 sys2)))))
 247
 248                       (use-modules (guix store)
 249                                    (guix self)
 250                                    (guix derivations)
 251                                    (srfi srfi-1))
 252
 253                       (define (spin system)
 254                         (define spin
 255                           (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
 256
 257                         (format (current-error-port)
 258                                 "Computing Guix derivation for '~a'...  "
 259                                 system)
 260                         (let loop ((spin spin))
 261                           (display (string-append "\b" (car spin))
 262                                    (current-error-port))
 263                           (force-output (current-error-port))
 264                           (sleep 1)
 265                           (loop (cdr spin))))
 266
 267                       (match (command-line)
 268                         ((_ source system version protocol-version)
 269                          ;; The current input port normally wraps a file
 270                          ;; descriptor connected to the daemon, or it is
 271                          ;; connected to /dev/null.  In the former case, reuse
 272                          ;; the connection such that we inherit build options
 273                          ;; such as substitute URLs and so on; in the latter
 274                          ;; case, attempt to open a new connection.
 275                          (let* ((proto (string->number protocol-version))
 276                                 (store (if (integer? proto)
 277                                            (port->connection (duplicate-port
 278                                                               (current-input-port)
 279                                                               "w+0")
 280                                                              #:version proto)
 281                                            (open-connection))))
 282                            (call-with-new-thread
 283                             (lambda ()
 284                               (spin system)))
 285
 286                            (display
 287                             (and=>
 288                              (run-with-store store
 289                                (guix-derivation source version
 290                                                 #$guile-version
 291                                                 #:pull-version
 292                                                 #$pull-version)
 293                                #:system system)
 294                              derivation-file-name))))))
 295                   #:module-path (list source))))
 296
 297 ;; The procedure below is our return value.
 298 (define* (build source
 299                 #:key verbose? (version (date-version-string)) system
 300                 (guile-version (match ((@ (guile) version))
 301                                  ("2.2.2" "2.2.2")
 302                                  (_       (effective-version))))
 303                 (pull-version 0)
 304                 #:allow-other-keys
 305                 #:rest rest)
 306   "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
 307 files."
 308   ;; Build the build program and then use it as a trampoline to build from
 309   ;; SOURCE.
 310   (mlet %store-monad ((build  (build-program source version guile-version
 311                                              #:pull-version pull-version))
 312                       (system (if system (return system) (current-system)))
 313                       (port   ((store-lift nix-server-socket)))
 314                       (major  ((store-lift nix-server-major-version)))
 315                       (minor  ((store-lift nix-server-minor-version))))
 316     (mbegin %store-monad
 317       (show-what-to-build* (list build))
 318       (built-derivations (list build))
 319
 320       ;; Use the port beneath the current store as the stdin of BUILD.  This
 321       ;; way, we know 'open-pipe*' will not close it on 'exec'.  If PORT is
 322       ;; not a file port (e.g., it's an SSH channel), then the subprocess's
 323       ;; stdin will actually be /dev/null.
 324       (let* ((pipe   (with-input-from-port port
 325                        (lambda ()
 326                          (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
 327                          (open-pipe* OPEN_READ
 328                                      (derivation->output-path build)
 329                                      source system version
 330                                      (if (file-port? port)
 331                                          (number->string
 332                                           (logior major minor))
 333                                          "none")))))
 334              (str    (get-string-all pipe))
 335              (status (close-pipe pipe)))
 336         (match str
 337           ((? eof-object?)
 338            (error "build program failed" (list build status)))
 339           ((? derivation-path? drv)
 340            (mbegin %store-monad
 341              (return (newline (current-output-port)))
 342              ((store-lift add-temp-root) drv)
 343              (return (read-derivation-from-file drv))))
 344           ("#f"
 345            ;; Unsupported PULL-VERSION.
 346            (return #f))
 347           ((? string? str)
 348            (error "invalid build result" (list build str))))))))
 349
 350 ;; This file is loaded by 'guix pull'; return it the build procedure.
 351 build
 352
 353 ;; Local Variables:
 354 ;; eval: (put 'with-load-path 'scheme-indent-function 1)
 355 ;; End:
 356
 357 ;;; build-self.scm ends here