You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

467 lines
20 KiB

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